From: William Harold Newman Date: Sat, 12 Jan 2002 23:22:46 +0000 (+0000) Subject: 0.pre7.125: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=09957fcf57b49ed5ae5f05d62ad12d7ddbfd8e1d;p=sbcl.git 0.pre7.125: more s/#'(lambda/(lambda/ --- diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index f8a688b..8170825 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -367,9 +367,9 @@ x)) thing)) (any-lowers ;; all lowercase, becomes all upper case - (diddle-with #'(lambda (x) (if (stringp x) - (string-upcase x) - x)) thing)) + (diddle-with (lambda (x) (if (stringp x) + (string-upcase x) + x)) thing)) (t ;; no letters? I guess just leave it. thing)))) diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 8d7b718..612524f 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -461,8 +461,8 @@ ;;; (Must be known values return...) (defun compute-debug-returns (fun) (coerce-to-smallest-eltype - (mapcar #'(lambda (loc) - (tn-sc-offset loc)) + (mapcar (lambda (loc) + (tn-sc-offset loc)) (return-info-locations (tail-set-info (lambda-tail-set fun)))))) ;;;; debug functions diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 9875753..ba299a1 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -115,36 +115,36 @@ ((null (block-next block))) (check-block-consistency block))) - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (or (constant-p v) - (and (global-var-p v) - (member (global-var-kind v) - '(:global :special)))) - (barf "strange *FREE-VARIABLES* entry: ~S" v)) - (dolist (n (leaf-refs v)) - (check-node-reached n)) - (when (basic-var-p v) - (dolist (n (basic-var-sets v)) - (check-node-reached n)))) + (maphash (lambda (k v) + (declare (ignore k)) + (unless (or (constant-p v) + (and (global-var-p v) + (member (global-var-kind v) + '(:global :special)))) + (barf "strange *FREE-VARIABLES* entry: ~S" v)) + (dolist (n (leaf-refs v)) + (check-node-reached n)) + (when (basic-var-p v) + (dolist (n (basic-var-sets v)) + (check-node-reached n)))) *free-variables*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (constant-p v) - (barf "strange *CONSTANTS* entry: ~S" v)) - (dolist (n (leaf-refs v)) - (check-node-reached n))) + (maphash (lambda (k v) + (declare (ignore k)) + (unless (constant-p v) + (barf "strange *CONSTANTS* entry: ~S" v)) + (dolist (n (leaf-refs v)) + (check-node-reached n))) *constants*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (unless (or (functional-p v) - (and (global-var-p v) - (eq (global-var-kind v) :global-function))) - (barf "strange *FREE-FUNCTIONS* entry: ~S" v)) - (dolist (n (leaf-refs v)) - (check-node-reached n))) + (maphash (lambda (k v) + (declare (ignore k)) + (unless (or (functional-p v) + (and (global-var-p v) + (eq (global-var-kind v) :global-function))) + (barf "strange *FREE-FUNCTIONS* entry: ~S" v)) + (dolist (n (leaf-refs v)) + (check-node-reached n))) *free-functions*) (clrhash *seen-functions*) (clrhash *seen-blocks*) @@ -643,9 +643,9 @@ (atypes (template-arg-types info)) (rtypes (template-result-types info))) (check-tn-refs (vop-args vop) vop nil - (count-if-not #'(lambda (x) - (and (consp x) - (eq (car x) :constant))) + (count-if-not (lambda (x) + (and (consp x) + (eq (car x) :constant))) atypes) (template-more-args-type info) "args") (check-tn-refs (vop-results vop) vop t @@ -987,7 +987,7 @@ (let ((succ (block-succ block))) (format t "successors~{ c~D~}~%" - (mapcar #'(lambda (x) (cont-num (block-start x))) succ))) + (mapcar (lambda (x) (cont-num (block-start x))) succ))) (values)) ;;; Print a useful representation of a TN. If the TN has a leaf, then do a @@ -1128,10 +1128,10 @@ ;;; Make a list out of all of the recorded conflicts. (defun listify-conflicts-table () (collect ((res)) - (maphash #'(lambda (k v) - (declare (ignore v)) - (when k - (res k))) + (maphash (lambda (k v) + (declare (ignore v)) + (when k + (res k))) *list-conflicts-table*) (clrhash *list-conflicts-table*) (res))) diff --git a/src/compiler/deftype.lisp b/src/compiler/deftype.lisp index 3057faa..e41c6fc 100644 --- a/src/compiler/deftype.lisp +++ b/src/compiler/deftype.lisp @@ -19,7 +19,7 @@ (parse-defmacro arglist whole body name 'deftype :default-default ''*) `(eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-deftype ',name - #'(lambda (,whole) - ,@local-decs - (block ,name ,body)) + (lambda (,whole) + ,@local-decs + (block ,name ,body)) ,@(when doc `(,doc))))))) diff --git a/src/compiler/disassem.lisp b/src/compiler/disassem.lisp index 4af4cf7..93d9eb8 100644 --- a/src/compiler/disassem.lisp +++ b/src/compiler/disassem.lisp @@ -336,16 +336,16 @@ (%make-funstate :args args)) (defun funstate-compatible-p (funstate args) - (every #'(lambda (this-arg-temps) - (let* ((old-arg (car this-arg-temps)) - (new-arg (find (arg-name old-arg) args :key #'arg-name))) - (and new-arg - (every #'(lambda (this-kind-temps) - (funcall (find-arg-form-checker - (car this-kind-temps)) - new-arg - old-arg)) - (cdr this-arg-temps))))) + (every (lambda (this-arg-temps) + (let* ((old-arg (car this-arg-temps)) + (new-arg (find (arg-name old-arg) args :key #'arg-name))) + (and new-arg + (every (lambda (this-kind-temps) + (funcall (find-arg-form-checker + (car this-kind-temps)) + new-arg + old-arg)) + (cdr this-arg-temps))))) (funstate-arg-temps funstate))) (defun arg-or-lose (name funstate) @@ -418,9 +418,9 @@ (values wrapper-name `(defparameter ,wrapper-name ,form))))) (defun filter-overrides (overrides evalp) - (mapcar #'(lambda (override) - (list* (car override) (cadr override) - (munge-fun-refs (cddr override) evalp))) + (mapcar (lambda (override) + (list* (car override) (cadr override) + (munge-fun-refs (cddr override) evalp))) overrides)) (defparameter *arg-function-params* @@ -452,12 +452,12 @@ (defun gen-args-def-form (overrides format-form &optional (evalp t)) (let ((args-var (gensym))) `(let ((,args-var (copy-list (format-args ,format-form)))) - ,@(mapcar #'(lambda (override) - (update-args-form args-var - `',(car override) - (and (cdr override) - (cons :value (cdr override))) - evalp)) + ,@(mapcar (lambda (override) + (update-args-form args-var + `',(car override) + (and (cdr override) + (cons :value (cdr override))) + evalp)) overrides) ,args-var))) @@ -638,10 +638,10 @@ :args ,args-var)) (eval `(progn - ,@(mapcar #'(lambda (arg) - (when (arg-fields arg) - (gen-arg-access-macro-def-form - arg ,args-var ',name))) + ,@(mapcar (lambda (arg) + (when (arg-fields arg) + (gen-arg-access-macro-def-form + arg ,args-var ',name))) ,args-var)))))))))) ;;; FIXME: probably needed only at build-the-system time, not in @@ -691,20 +691,20 @@ can't specify fields except using DEFINE-INSTRUCTION-FORMAT~:>" arg-name)) (setf (arg-fields arg) - (mapcar #'(lambda (bytespec) - (when (> (+ (byte-position bytespec) - (byte-size bytespec)) - format-length) - (error "~@ (+ (byte-position bytespec) + (byte-size bytespec)) + format-length) + (error "~@" - arg-name - bytespec - format-length)) - (correct-dchunk-bytespec-for-endianness - bytespec - format-length - sb!c:*backend-byte-order*)) + arg-name + bytespec + format-length)) + (correct-dchunk-bytespec-for-endianness + bytespec + format-length + sb!c:*backend-byte-order*)) fields))) args)) @@ -752,8 +752,8 @@ ((atom (cadr atk)) (push `(,(cadr atk) ,(cddr atk)) bindings)) (t - (mapc #'(lambda (var form) - (push `(,var ,form) bindings)) + (mapc (lambda (var form) + (push `(,var ,form) bindings)) (cadr atk) (cddr atk)))))) bindings)) @@ -855,35 +855,35 @@ (defmacro def-arg-form-kind ((&rest names) &rest inits) `(let ((kind (make-arg-form-kind :names ',names ,@inits))) - ,@(mapcar #'(lambda (name) - `(setf (getf *arg-form-kinds* ',name) kind)) + ,@(mapcar (lambda (name) + `(setf (getf *arg-form-kinds* ',name) kind)) names))) (def-arg-form-kind (:raw) - :producer #'(lambda (arg funstate) - (declare (ignore funstate)) - (mapcar #'(lambda (bytespec) - `(the (unsigned-byte ,(byte-size bytespec)) - (local-extract ',bytespec))) - (arg-fields arg))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-fields new-arg) - (arg-fields old-arg)))) + :producer (lambda (arg funstate) + (declare (ignore funstate)) + (mapcar (lambda (bytespec) + `(the (unsigned-byte ,(byte-size bytespec)) + (local-extract ',bytespec))) + (arg-fields arg))) + :checker (lambda (new-arg old-arg) + (equal (arg-fields new-arg) + (arg-fields old-arg)))) (def-arg-form-kind (:sign-extended :unfiltered) - :producer #'(lambda (arg funstate) - (let ((raw-forms (gen-arg-forms arg :raw funstate))) - (if (and (arg-sign-extend-p arg) (listp raw-forms)) - (mapcar #'(lambda (form field) - `(the (signed-byte ,(byte-size field)) - (sign-extend ,form - ,(byte-size field)))) - raw-forms - (arg-fields arg)) - raw-forms))) - :checker #'(lambda (new-arg old-arg) - (equal (arg-sign-extend-p new-arg) - (arg-sign-extend-p old-arg)))) + :producer (lambda (arg funstate) + (let ((raw-forms (gen-arg-forms arg :raw funstate))) + (if (and (arg-sign-extend-p arg) (listp raw-forms)) + (mapcar (lambda (form field) + `(the (signed-byte ,(byte-size field)) + (sign-extend ,form + ,(byte-size field)))) + raw-forms + (arg-fields arg)) + raw-forms))) + :checker (lambda (new-arg old-arg) + (equal (arg-sign-extend-p new-arg) + (arg-sign-extend-p old-arg)))) (defun valsrc-equal (f1 f2) (if (null f1) @@ -892,73 +892,73 @@ (value-or-source f2)))) (def-arg-form-kind (:filtering) - :producer #'(lambda (arg funstate) - (let ((sign-extended-forms - (gen-arg-forms arg :sign-extended funstate)) - (pf (arg-prefilter arg))) - (if pf - (values - `(local-filter ,(maybe-listify sign-extended-forms) - ,(source-form pf)) - t) - (values sign-extended-forms nil)))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) + :producer (lambda (arg funstate) + (let ((sign-extended-forms + (gen-arg-forms arg :sign-extended funstate)) + (pf (arg-prefilter arg))) + (if pf + (values + `(local-filter ,(maybe-listify sign-extended-forms) + ,(source-form pf)) + t) + (values sign-extended-forms nil)))) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-prefilter new-arg) (arg-prefilter old-arg)))) (def-arg-form-kind (:filtered :unadjusted) - :producer #'(lambda (arg funstate) - (let ((pf (arg-prefilter arg))) - (if pf - (values `(local-filtered-value ,(arg-position arg)) t) - (gen-arg-forms arg :sign-extended funstate)))) - :checker #'(lambda (new-arg old-arg) - (let ((pf1 (arg-prefilter new-arg)) - (pf2 (arg-prefilter old-arg))) - (if (null pf1) - (null pf2) - (= (arg-position new-arg) - (arg-position old-arg)))))) + :producer (lambda (arg funstate) + (let ((pf (arg-prefilter arg))) + (if pf + (values `(local-filtered-value ,(arg-position arg)) t) + (gen-arg-forms arg :sign-extended funstate)))) + :checker (lambda (new-arg old-arg) + (let ((pf1 (arg-prefilter new-arg)) + (pf2 (arg-prefilter old-arg))) + (if (null pf1) + (null pf2) + (= (arg-position new-arg) + (arg-position old-arg)))))) (def-arg-form-kind (:adjusted :numeric :unlabelled) - :producer #'(lambda (arg funstate) - (let ((filtered-forms (gen-arg-forms arg :filtered funstate)) - (use-label (arg-use-label arg))) - (if (and use-label (not (eq use-label t))) - (list - `(adjust-label ,(maybe-listify filtered-forms) - ,(source-form use-label))) - filtered-forms))) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) + :producer (lambda (arg funstate) + (let ((filtered-forms (gen-arg-forms arg :filtered funstate)) + (use-label (arg-use-label arg))) + (if (and use-label (not (eq use-label t))) + (list + `(adjust-label ,(maybe-listify filtered-forms) + ,(source-form use-label))) + filtered-forms))) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-use-label new-arg) (arg-use-label old-arg)))) (def-arg-form-kind (:labelled :final) - :producer #'(lambda (arg funstate) - (let ((adjusted-forms - (gen-arg-forms arg :adjusted funstate)) - (use-label (arg-use-label arg))) - (if use-label - (let ((form (maybe-listify adjusted-forms))) - (if (and (not (eq use-label t)) - (not (atom adjusted-forms)) - (/= (Length adjusted-forms) 1)) - (pd-error - "cannot label a multiple-field argument ~ + :producer (lambda (arg funstate) + (let ((adjusted-forms + (gen-arg-forms arg :adjusted funstate)) + (use-label (arg-use-label arg))) + (if use-label + (let ((form (maybe-listify adjusted-forms))) + (if (and (not (eq use-label t)) + (not (atom adjusted-forms)) + (/= (Length adjusted-forms) 1)) + (pd-error + "cannot label a multiple-field argument ~ unless using a function: ~S" arg) - `((lookup-label ,form)))) - adjusted-forms))) - :checker #'(lambda (new-arg old-arg) - (let ((lf1 (arg-use-label new-arg)) - (lf2 (arg-use-label old-arg))) - (if (null lf1) (null lf2) t)))) + `((lookup-label ,form)))) + adjusted-forms))) + :checker (lambda (new-arg old-arg) + (let ((lf1 (arg-use-label new-arg)) + (lf2 (arg-use-label old-arg))) + (if (null lf1) (null lf2) t)))) ;;; This is a bogus kind that's just used to ensure that printers are ;;; compatible... (def-arg-form-kind (:printed) - :producer #'(lambda (&rest noise) - (declare (ignore noise)) - (pd-error "bogus! can't use the :printed value of an arg!")) - :checker #'(lambda (new-arg old-arg) - (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) + :producer (lambda (&rest noise) + (declare (ignore noise)) + (pd-error "bogus! can't use the :printed value of an arg!")) + :checker (lambda (new-arg old-arg) + (valsrc-equal (arg-printer new-arg) (arg-printer old-arg)))) (defun remember-printer-use (arg funstate) (set-arg-temps nil nil arg :printed funstate)) @@ -1122,8 +1122,8 @@ test key (sharing-mapcar - #'(lambda (sub-test) - (preprocess-test subj sub-test args)) + (lambda (sub-test) + (preprocess-test subj sub-test args)) body)))) (t form))))) @@ -1147,24 +1147,24 @@ printer :cond (sharing-mapcar - #'(lambda (clause) - (let ((filtered-body - (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) - (cdr clause)))) - (sharing-cons - clause - (preprocess-test (find-first-field-name filtered-body) - (car clause) - args) - filtered-body))) + (lambda (clause) + (let ((filtered-body + (sharing-mapcar + (lambda (sub-printer) + (preprocess-conditionals sub-printer args)) + (cdr clause)))) + (sharing-cons + clause + (preprocess-test (find-first-field-name filtered-body) + (car clause) + args) + filtered-body))) (cdr printer)))) (quote printer) (t (sharing-mapcar - #'(lambda (sub-printer) - (preprocess-conditionals sub-printer args)) + (lambda (sub-printer) + (preprocess-conditionals sub-printer args)) printer))))) ;;; Return a version of the disassembly-template PRINTER with @@ -1196,7 +1196,7 @@ ((eq (car printer) :choose) (pick-printer-choice (cdr printer) args)) (t - (sharing-mapcar #'(lambda (sub) (preprocess-chooses sub args)) + (sharing-mapcar (lambda (sub) (preprocess-chooses sub args)) printer)))) ;;;; some simple functions that help avoid consing when we're just @@ -1226,7 +1226,7 @@ ((symbolp printer) (find printer args :key #'arg-name)) ((listp printer) - (every #'(lambda (x) (all-arg-refs-relevant-p x args)) + (every (lambda (x) (all-arg-refs-relevant-p x args)) printer)) (t t))) @@ -1292,13 +1292,13 @@ ((eq (car source) 'function) `(local-call-global-printer ,source)) ((eq (car source) :cond) - `(cond ,@(mapcar #'(lambda (clause) - `(,(compile-test (find-first-field-name - (cdr clause)) - (car clause) - funstate) - ,@(compile-printer-list (cdr clause) - funstate))) + `(cond ,@(mapcar (lambda (clause) + `(,(compile-test (find-first-field-name + (cdr clause)) + (car clause) + funstate) + ,@(compile-printer-list (cdr clause) + funstate))) (cdr source)))) ;; :IF, :UNLESS, and :WHEN are replaced by :COND during preprocessing (t @@ -1347,7 +1347,7 @@ `(equal ,(listify-fields val-form-1) ,(listify-fields val-form-2))) (t - `(and ,@(mapcar #'(lambda (v1 v2) `(= ,v1 ,v2)) + `(and ,@(mapcar (lambda (v1 v2) `(= ,v1 ,v2)) val-form-1 val-form-2)))))) (defun compile-test (subj test funstate) @@ -1381,8 +1381,8 @@ (arg2 (arg-or-lose (car body) funstate))) (unless (and (= (length (arg-fields arg1)) (length (arg-fields arg2))) - (every #'(lambda (bs1 bs2) - (= (byte-size bs1) (byte-size bs2))) + (every (lambda (bs1 bs2) + (= (byte-size bs1) (byte-size bs2))) (arg-fields arg1) (arg-fields arg2))) (pd-error "can't compare differently sized fields: ~ @@ -1390,10 +1390,10 @@ (compare-fields-form (gen-arg-forms arg1 :numeric funstate) (gen-arg-forms arg2 :numeric funstate)))) ((eq key :or) - `(or ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) + `(or ,@(mapcar (lambda (sub) (compile-test subj sub funstate)) body))) ((eq key :and) - `(and ,@(mapcar #'(lambda (sub) (compile-test subj sub funstate)) + `(and ,@(mapcar (lambda (sub) (compile-test subj sub funstate)) body))) ((eq key :not) `(not ,(compile-test subj (car body) funstate))) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index c1fbd73..a65bf35 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -250,11 +250,11 @@ (defun ,aux-name (num) ;; When converting a number to a float, the limits are ;; the same. - (let* ((lo (bound-func #'(lambda (x) - (coerce x ',type)) + (let* ((lo (bound-func (lambda (x) + (coerce x ',type)) (numeric-type-low num))) - (hi (bound-func #'(lambda (x) - (coerce x ',type)) + (hi (bound-func (lambda (x) + (coerce x ',type)) (numeric-type-high num)))) (specifier-type `(,',type ,(or lo '*) ,(or hi '*))))) @@ -649,11 +649,11 @@ `(defoptimizer (,name derive-type) ((,num)) (one-arg-derive-type ,num - #'(lambda (arg) - (elfun-derive-type-simple arg #',name - ,domain-low ,domain-high - ,def-low-bnd ,def-high-bnd - ,increasingp)) + (lambda (arg) + (elfun-derive-type-simple arg #',name + ,domain-low ,domain-high + ,def-low-bnd ,def-high-bnd + ,increasingp)) #',name))))) ;; These functions are easy because they are defined for the whole ;; real line. @@ -1271,9 +1271,9 @@ (defoptimizer (cis derive-type) ((num)) (one-arg-derive-type num - #'(lambda (arg) - (sb!c::specifier-type - `(complex ,(or (numeric-type-format arg) 'float)))) + (lambda (arg) + (sb!c::specifier-type + `(complex ,(or (numeric-type-format arg) 'float)))) #'cis)) ) ; PROGN diff --git a/src/compiler/ir1final.lisp b/src/compiler/ir1final.lisp index bdf3bca..d0a02e3 100644 --- a/src/compiler/ir1final.lisp +++ b/src/compiler/ir1final.lisp @@ -126,7 +126,7 @@ (maphash #'note-failed-optimization (component-failed-optimizations component)) - (maphash #'(lambda (k v) - (note-assumed-types component k v)) + (maphash (lambda (k v) + (note-assumed-types component k v)) *free-functions*) (values)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index bab067f..08951f8 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1129,7 +1129,7 @@ call `(lambda ,dummies (declare (ignore ,@dummies)) - (values ,@(mapcar #'(lambda (x) `',x) values)))))))) + (values ,@(mapcar (lambda (x) `',x) values)))))))) (values)) @@ -1289,12 +1289,12 @@ (propagate-to-refs var (continuation-type arg)) (let ((use-component (node-component use))) (substitute-leaf-if - #'(lambda (ref) - (cond ((eq (node-component ref) use-component) - t) - (t - (aver (lambda-toplevelish-p (lambda-home fun))) - nil))) + (lambda (ref) + (cond ((eq (node-component ref) use-component) + t) + (t + (aver (lambda-toplevelish-p (lambda-home fun))) + nil))) leaf var)) t))))) ((and (null (rest (leaf-refs var))) @@ -1325,11 +1325,11 @@ (unless (or (functional-entry-fun fun) (lambda-optional-dispatch fun)) (let* ((vars (lambda-vars fun)) - (union (mapcar #'(lambda (arg var) - (when (and arg - (continuation-reoptimize arg) - (null (basic-var-sets var))) - (continuation-type arg))) + (union (mapcar (lambda (arg var) + (when (and arg + (continuation-reoptimize arg) + (null (basic-var-sets var))) + (continuation-type arg))) (basic-combination-args call) vars)) (this-ref (continuation-use (basic-combination-fun call)))) @@ -1342,16 +1342,16 @@ (let ((dest (continuation-dest (node-cont ref)))) (unless (or (eq ref this-ref) (not dest)) (setq union - (mapcar #'(lambda (this-arg old) - (when old - (setf (continuation-reoptimize this-arg) nil) - (type-union (continuation-type this-arg) old))) + (mapcar (lambda (this-arg old) + (when old + (setf (continuation-reoptimize this-arg) nil) + (type-union (continuation-type this-arg) old))) (basic-combination-args dest) union))))) - (mapc #'(lambda (var type) - (when type - (propagate-to-refs var type))) + (mapc (lambda (var type) + (when type + (propagate-to-refs var type))) vars union))) (values)) @@ -1413,11 +1413,11 @@ (multiple-value-bind (types nvals) (values-types (continuation-derived-type arg)) (unless (eq nvals :unknown) - (mapc #'(lambda (var type) - (if (basic-var-sets var) - (propagate-from-sets var type) - (propagate-to-refs var type))) - vars + (mapc (lambda (var type) + (if (basic-var-sets var) + (propagate-from-sets var type) + (propagate-to-refs var type))) + vars (append types (make-list (max (- (length vars) nvals) 0) :initial-element (specifier-type 'null)))))) diff --git a/src/compiler/ir1report.lisp b/src/compiler/ir1report.lisp index c12736a..697e7c4 100644 --- a/src/compiler/ir1report.lisp +++ b/src/compiler/ir1report.lisp @@ -106,8 +106,8 @@ list of subforms suitable for a \"~{~S ~}\" format string." (let ((n-whole (gensym))) `(setf (gethash ',name *source-context-methods*) - #'(lambda (,n-whole) - (destructuring-bind ,lambda-list ,n-whole ,@body))))) + (lambda (,n-whole) + (destructuring-bind ,lambda-list ,n-whole ,@body))))) (defmacro def-source-context (&rest rest) (deprecation-warning 'def-source-context 'define-source-context) @@ -130,9 +130,9 @@ (cond ((atom form) nil) ((>= (length form) 2) (funcall (gethash (first form) *source-context-methods* - #'(lambda (x) - (declare (ignore x)) - (list (first form) (second form)))) + (lambda (x) + (declare (ignore x)) + (list (first form) (second form)))) (rest form))) (t form))) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index daa641f..0c83801 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -497,7 +497,7 @@ ((or (atom opname) (not (eq (car opname) 'lambda))) (compiler-error "illegal function call")) (t - ;; implicitly #'(LAMBDA ..) because the LAMBDA + ;; implicitly (LAMBDA ..) because the LAMBDA ;; expression is the CAR of an executed form (ir1-convert-combination start cont diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 2f96290..1760dbc 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -1012,8 +1012,8 @@ (not (eq pkg (symbol-package :end)))))) (not (member first *deletion-ignored-objects*)) (not (typep first '(or fixnum character))) - (every #'(lambda (x) - (present-in-form first x 0)) + (every (lambda (x) + (present-in-form first x 0)) (source-path-forms path)) (present-in-form first (find-original-source path) 0))) diff --git a/src/compiler/ir2tran.lisp b/src/compiler/ir2tran.lisp index db462db..2fd642e 100644 --- a/src/compiler/ir2tran.lisp +++ b/src/compiler/ir2tran.lisp @@ -318,23 +318,23 @@ (multiple-value-bind (check types) (continuation-check-types cont) (aver (eq check :simple)) (let ((ntypes (length types))) - (mapcar #'(lambda (from to-type assertion) - (let ((temp (make-normal-tn to-type))) - (if assertion - (emit-type-check node block from temp assertion) - (emit-move node block from temp)) - temp)) + (mapcar (lambda (from to-type assertion) + (let ((temp (make-normal-tn to-type))) + (if assertion + (emit-type-check node block from temp assertion) + (emit-move node block from temp)) + temp)) locs ptypes (if (< ntypes nlocs) (append types (make-list (- nlocs ntypes) :initial-element nil)) types)))) - (mapcar #'(lambda (from to-type) - (if (eq (tn-primitive-type from) to-type) - from - (let ((temp (make-normal-tn to-type))) - (emit-move node block from temp) - temp))) + (mapcar (lambda (from to-type) + (if (eq (tn-primitive-type from) to-type) + from + (let ((temp (make-normal-tn to-type))) + (emit-move node block from temp) + temp))) locs ptypes)))) @@ -373,10 +373,10 @@ (unless (eq (tn-primitive-type (car loc)) (car type)) (return nil)))) locs - (mapcar #'(lambda (loc type) - (if (eq (tn-primitive-type loc) type) - loc - (make-normal-tn type))) + (mapcar (lambda (loc type) + (if (eq (tn-primitive-type loc) type) + loc + (make-normal-tn type))) (if (< nlocs ntypes) (append locs (mapcar #'make-normal-tn @@ -420,9 +420,9 @@ (declare (type node node) (type ir2-block block) (list src dest)) (let ((nsrc (length src)) (ndest (length dest))) - (mapc #'(lambda (from to) - (unless (eq from to) - (emit-move node block from to))) + (mapc (lambda (from to) + (unless (eq from to) + (emit-move node block from to))) (if (> ndest nsrc) (append src (make-list (- ndest nsrc) :initial-element (emit-constant nil))) @@ -637,13 +637,13 @@ ;;; this. (defun ir2-convert-let (node block fun) (declare (type combination node) (type ir2-block block) (type clambda fun)) - (mapc #'(lambda (var arg) - (when arg - (let ((src (continuation-tn node block arg)) - (dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) + (mapc (lambda (var arg) + (when arg + (let ((src (continuation-tn node block arg)) + (dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) (lambda-vars fun) (basic-combination-args node)) (values)) @@ -664,10 +664,10 @@ (type (or tn null) old-fp)) (let* ((called-env (physenv-info (lambda-physenv fun))) (this-1env (node-physenv node)) - (actuals (mapcar #'(lambda (x) - (when x - (continuation-tn node block x))) - (combination-args node)))) + (actuals (mapcar (lambda (x) + (when x + (continuation-tn node block x))) + (combination-args node)))) (collect ((temps) (locs)) (dolist (var (lambda-vars fun)) @@ -708,8 +708,8 @@ (multiple-value-bind (temps locs) (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env)) - (mapc #'(lambda (temp loc) - (emit-move node block temp loc)) + (mapc (lambda (temp loc) + (emit-move node block temp loc)) temps locs)) (emit-move node block @@ -727,8 +727,8 @@ (declare (type combination node) (type ir2-block block) (type clambda fun)) (multiple-value-bind (temps locs) (emit-psetq-moves node block fun nil) - (mapc #'(lambda (temp loc) - (emit-move node block temp loc)) + (mapc (lambda (temp loc) + (emit-move node block temp loc)) temps locs)) (values)) @@ -1158,8 +1158,8 @@ (cont-locs (continuation-tns node block cont types)) (nvals (length cont-locs)) (locs (make-standard-value-tns nvals))) - (mapc #'(lambda (val loc) - (emit-move node block val loc)) + (mapc (lambda (val loc) + (emit-move node block val loc)) cont-locs locs) (if (= nvals 1) @@ -1201,15 +1201,15 @@ (fun (ref-leaf (continuation-use (basic-combination-fun node)))) (vars (lambda-vars fun))) (aver (eq (functional-kind fun) :mv-let)) - (mapc #'(lambda (src var) - (when (leaf-refs var) - (let ((dest (leaf-info var))) - (if (lambda-var-indirect var) - (do-make-value-cell node block src dest) - (emit-move node block src dest))))) + (mapc (lambda (src var) + (when (leaf-refs var) + (let ((dest (leaf-info var))) + (if (lambda-var-indirect var) + (do-make-value-cell node block src dest) + (emit-move node block src dest))))) (continuation-tns node block cont - (mapcar #'(lambda (x) - (primitive-type (leaf-type x))) + (mapcar (lambda (x) + (primitive-type (leaf-type x))) vars)) vars)) (values)) @@ -1259,8 +1259,8 @@ ;;; Deliver the values TNs to CONT using MOVE-CONTINUATION-RESULT. (defoptimizer (values ir2-convert) ((&rest values) node block) - (let ((tns (mapcar #'(lambda (x) - (continuation-tn node block x)) + (let ((tns (mapcar (lambda (x) + (continuation-tn node block x)) values))) (move-continuation-result node block tns (node-cont node)))) @@ -1318,8 +1318,8 @@ (once-only ((n-save-bs '(%primitive current-binding-pointer))) `(unwind-protect (progn - (mapc #'(lambda (var val) - (%primitive bind val var)) + (mapc (lambda (var val) + (%primitive bind val var)) ,vars ,vals) ,@body) diff --git a/src/compiler/knownfun.lisp b/src/compiler/knownfun.lisp index 4030b09..9e3d53a 100644 --- a/src/compiler/knownfun.lisp +++ b/src/compiler/knownfun.lisp @@ -239,17 +239,17 @@ ;;; argument. If arg is a list, result is a list. If arg is a vector, result ;;; is a vector with the same element type. (defun sequence-result-nth-arg (n) - #'(lambda (call) - (declare (type combination call)) - (let ((cont (nth (1- n) (combination-args call)))) - (when cont - (let ((type (continuation-type cont))) - (if (array-type-p type) - (specifier-type - `(vector ,(type-specifier (array-type-element-type type)))) - (let ((ltype (specifier-type 'list))) - (when (csubtypep type ltype) - ltype)))))))) + (lambda (call) + (declare (type combination call)) + (let ((cont (nth (1- n) (combination-args call)))) + (when cont + (let ((type (continuation-type cont))) + (if (array-type-p type) + (specifier-type + `(vector ,(type-specifier (array-type-element-type type)))) + (let ((ltype (specifier-type 'list))) + (when (csubtypep type ltype) + ltype)))))))) ;;; Derive the type to be the type specifier which is the N'th arg. (defun result-type-specifier-nth-arg (n) diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp index a728e2e..bb0dcd8 100644 --- a/src/compiler/ltn.lisp +++ b/src/compiler/ltn.lisp @@ -276,8 +276,8 @@ (let ((res (make-ir2-continuation nil))) (if (member (continuation-type-check cont) '(:deleted nil)) (setf (ir2-continuation-locs res) (mapcar #'make-normal-tn types)) - (let* ((proven (mapcar #'(lambda (x) - (make-normal-tn (primitive-type x))) + (let* ((proven (mapcar (lambda (x) + (make-normal-tn (primitive-type x))) (values-types (continuation-proven-type cont)))) (num-proven (length proven)) @@ -730,18 +730,18 @@ (:arg-types (funcall frob "argument types invalid") (funcall frob "argument primitive types:~% ~S" - (mapcar #'(lambda (x) - (primitive-type-name - (continuation-ptype x))) + (mapcar (lambda (x) + (primitive-type-name + (continuation-ptype x))) (combination-args call))) (funcall frob "argument type assertions:~% ~S" - (mapcar #'(lambda (x) - (if (atom x) - x - (ecase (car x) - (:or `(:or .,(mapcar #'primitive-type-name - (cdr x)))) - (:constant `(:constant ,(third x)))))) + (mapcar (lambda (x) + (if (atom x) + x + (ecase (car x) + (:or `(:or .,(mapcar #'primitive-type-name + (cdr x)))) + (:constant `(:constant ,(third x)))))) (template-arg-types template)))) (:conditional (funcall frob "conditional in a non-conditional context")) diff --git a/src/compiler/macros.lisp b/src/compiler/macros.lisp index 9d5328c..89b35bb 100644 --- a/src/compiler/macros.lisp +++ b/src/compiler/macros.lisp @@ -239,10 +239,10 @@ ;;; those in Attr2. (defmacro attributes-union (&rest attributes) `(the attributes - (logior ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logior ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (defmacro attributes-intersection (&rest attributes) `(the attributes - (logand ,@(mapcar #'(lambda (x) `(the attributes ,x)) attributes)))) + (logand ,@(mapcar (lambda (x) `(the attributes ,x)) attributes)))) (declaim (ftype (function (attributes attributes) boolean) attributes=)) #!-sb-fluid (declaim (inline attributes=)) (defun attributes= (attr1 attr2) @@ -431,7 +431,7 @@ ,(if eval-name ``(function ,,arg-types ,,result-type) `'(function ,arg-types ,result-type)) - #'(lambda ,@stuff) + (lambda ,@stuff) ,doc ,(if important t nil) ,when))))))) @@ -815,10 +815,10 @@ (declaim (ftype (function (&optional unsigned-byte stream) (values)) event-statistics)) (defun event-statistics (&optional (min-count 1) (stream *standard-output*)) (collect ((info)) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (>= (event-info-count v) min-count) - (info v))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (>= (event-info-count v) min-count) + (info v))) *event-info*) (dolist (event (sort (info) #'> :key #'event-info-count)) (format stream "~6D: ~A~%" (event-info-count event) @@ -828,9 +828,9 @@ (declaim (ftype (function nil (values)) clear-event-statistics)) (defun clear-event-statistics () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (event-info-count v) 0)) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (event-info-count v) 0)) *event-info*) (values)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 3f6b95e..70f82fa 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -163,11 +163,11 @@ (warning #'compiler-warning-handler)) (let ((undefs (sort *undefined-warnings* #'string< - :key #'(lambda (x) - (let ((x (undefined-warning-name x))) - (if (symbolp x) - (symbol-name x) - (prin1-to-string x))))))) + :key (lambda (x) + (let ((x (undefined-warning-name x))) + (if (symbolp x) + (symbol-name x) + (prin1-to-string x))))))) (dolist (undef undefs) (let ((name (undefined-warning-name undef)) (kind (undefined-warning-kind undef)) @@ -514,14 +514,14 @@ ;;; slots, since they are used to keep track of functions across ;;; component boundaries. (defun clear-constant-info () - (maphash #'(lambda (k v) - (declare (ignore k)) - (setf (leaf-info v) nil)) + (maphash (lambda (k v) + (declare (ignore k)) + (setf (leaf-info v) nil)) *constants*) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (constant-p v) - (setf (leaf-info v) nil))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (constant-p v) + (setf (leaf-info v) nil))) *free-variables*) (values)) @@ -530,14 +530,14 @@ (defun clear-ir1-info (component) (declare (type component component)) (labels ((blast (x) - (maphash #'(lambda (k v) - (declare (ignore k)) - (when (leaf-p v) - (setf (leaf-refs v) - (delete-if #'here-p (leaf-refs v))) - (when (basic-var-p v) - (setf (basic-var-sets v) - (delete-if #'here-p (basic-var-sets v)))))) + (maphash (lambda (k v) + (declare (ignore k)) + (when (leaf-p v) + (setf (leaf-refs v) + (delete-if #'here-p (leaf-refs v))) + (when (basic-var-p v) + (setf (basic-var-sets v) + (delete-if #'here-p (basic-var-sets v)))))) x)) (here-p (x) (eq (node-component x) component))) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 4979d4b..6600514 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -153,8 +153,8 @@ (if (or (eq sb-name 'non-descriptor-stack) (find 'non-descriptor-stack (mapcar #'meta-sc-or-lose alternate-scs) - :key #'(lambda (x) - (sb-name (sc-sb x))))) + :key (lambda (x) + (sb-name (sc-sb x))))) t nil))) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) @@ -331,15 +331,15 @@ (n-type (gensym))) `(let ((,n-vop (template-or-lose ',vop))) ,@(mapcar - #'(lambda (type) - `(let ((,n-type (primitive-type-or-lose ',type))) - ,@(mapcar - #'(lambda (kind) - (let ((slot (or (cdr (assoc kind - *primitive-type-slot-alist*)) - (error "unknown kind: ~S" kind)))) - `(setf (,slot ,n-type) ,n-vop))) - kinds))) + (lambda (type) + `(let ((,n-type (primitive-type-or-lose ',type))) + ,@(mapcar + (lambda (kind) + (let ((slot (or (cdr (assoc kind + *primitive-type-slot-alist*)) + (error "unknown kind: ~S" kind)))) + `(setf (,slot ,n-type) ,n-vop))) + kinds))) types) nil))) @@ -665,14 +665,14 @@ (refs (cons (cons born t) index)))) (incf index))) (let* ((sorted (sort (refs) - #'(lambda (x y) - (let ((x-time (car x)) - (y-time (car y))) - (if (time-spec-order x-time y-time) - (if (time-spec-order y-time x-time) - (and (not (cdr x)) (cdr y)) - nil) - t))) + (lambda (x y) + (let ((x-time (car x)) + (y-time (car y))) + (if (time-spec-order x-time y-time) + (if (time-spec-order y-time x-time) + (and (not (cdr x)) (cdr y)) + nil) + t))) :key #'car)) (oe-type '(mod #.max-vop-tn-refs)) ; :REF-ORDERING element type (te-type '(mod #.(* max-vop-tn-refs 2))) ; :TARGETS element type @@ -774,13 +774,13 @@ (setf (vop-parse-vop-var parse) (gensym)))) (form (if (rest funs) `(sc-case ,tn - ,@(mapcar #'(lambda (x) - `(,(mapcar #'sc-name (car x)) - ,(if load-p - `(,(cdr x) ,n-vop ,tn - ,load-tn) - `(,(cdr x) ,n-vop ,load-tn - ,tn)))) + ,@(mapcar (lambda (x) + `(,(mapcar #'sc-name (car x)) + ,(if load-p + `(,(cdr x) ,n-vop ,tn + ,load-tn) + `(,(cdr x) ,n-vop ,load-tn + ,tn)))) funs)) (if load-p `(,(cdr (first funs)) ,n-vop ,tn ,load-tn) @@ -845,10 +845,10 @@ (tn-ref-tn ,(operand-parse-temp op))))) ((:more-argument :more-result)))) - `#'(lambda (,n-vop) - (let* (,@(access-operands (vop-parse-args parse) - (vop-parse-more-args parse) - `(vop-args ,n-vop)) + `(lambda (,n-vop) + (let* (,@(access-operands (vop-parse-args parse) + (vop-parse-more-args parse) + `(vop-args ,n-vop)) ,@(access-operands (vop-parse-results parse) (vop-parse-more-results parse) `(vop-results ,n-vop)) @@ -865,11 +865,11 @@ ,@(when (vop-parse-node-var parse) `((,(vop-parse-node-var parse) (vop-node ,n-vop)))) ,@(binds)) - (declare (ignore ,@(vop-parse-ignores parse))) - ,@(loads) - (sb!assem:assemble (*code-segment* ,n-vop) - ,@(vop-parse-body parse)) - ,@(saves)))))) + (declare (ignore ,@(vop-parse-ignores parse))) + ,@(loads) + (sb!assem:assemble (*code-segment* ,n-vop) + ,@(vop-parse-body parse)) + ,@(saves)))))) ;;; Given a list of operand specifications as given to DEFINE-VOP, ;;; return a list of OPERAND-PARSE structures describing the fixed diff --git a/src/compiler/x86/arith.lisp b/src/compiler/x86/arith.lisp index a281608..949d73b 100644 --- a/src/compiler/x86/arith.lisp +++ b/src/compiler/x86/arith.lisp @@ -842,28 +842,28 @@ (macrolet ((define-conditional-vop (tran cond unsigned not-cond not-unsigned) `(progn ,@(mapcar - #'(lambda (suffix cost signed) - `(define-vop (;; FIXME: These could be done more - ;; cleanly with SYMBOLICATE. - ,(intern (format nil "~:@(FAST-IF-~A~A~)" - tran suffix)) - ,(intern - (format nil "~:@(FAST-CONDITIONAL~A~)" - suffix))) - (:translate ,tran) - (:generator ,cost - (inst cmp x - ,(if (eq suffix '-c/fixnum) - '(fixnumize y) - 'y)) - (inst jmp (if not-p - ,(if signed - not-cond - not-unsigned) - ,(if signed - cond - unsigned)) - target)))) + (lambda (suffix cost signed) + `(define-vop (;; FIXME: These could be done more + ;; cleanly with SYMBOLICATE. + ,(intern (format nil "~:@(FAST-IF-~A~A~)" + tran suffix)) + ,(intern + (format nil "~:@(FAST-CONDITIONAL~A~)" + suffix))) + (:translate ,tran) + (:generator ,cost + (inst cmp x + ,(if (eq suffix '-c/fixnum) + '(fixnumize y) + 'y)) + (inst jmp (if not-p + ,(if signed + not-cond + not-unsigned) + ,(if signed + cond + unsigned)) + target)))) '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned) '(4 3 6 5 6 5) '(t t t t nil nil))))) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index 4c098f9..04b73a8 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -106,8 +106,8 @@ #+nil ;;pfw obsolete now? (define-alien-type-method (values :result-tn) (type state) - (mapcar #'(lambda (type) - (invoke-alien-type-method :result-tn type state)) + (mapcar (lambda (type) + (invoke-alien-type-method :result-tn type state)) (alien-values-type-values type))) ;;; pfw - from alpha diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 6b4bf08..53d6734 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -769,12 +769,12 @@ ;; doing the call. Therefore, we have to tell the ;; lifetime stuff that we need to use them. ,@(when variable - (mapcar #'(lambda (name offset) - `(:temporary (:sc descriptor-reg - :offset ,offset - :from (:argument 0) - :to :eval) - ,name)) + (mapcar (lambda (name offset) + `(:temporary (:sc descriptor-reg + :offset ,offset + :from (:argument 0) + :to :eval) + ,name)) *register-arg-names* *register-arg-offsets*)) ,@(when (eq return :tail) @@ -1359,8 +1359,8 @@ ,@(when translate `((:policy :fast-safe) (:translate ,translate))) - (:args ,@(mapcar #'(lambda (arg) - `(,arg :scs (any-reg descriptor-reg))) + (:args ,@(mapcar (lambda (arg) + `(,arg :scs (any-reg descriptor-reg))) args)) (:vop-var vop) (:save-p :compute-only) diff --git a/src/compiler/x86/insts.lisp b/src/compiler/x86/insts.lisp index c8e70f1..b764f08 100644 --- a/src/compiler/x86/insts.lisp +++ b/src/compiler/x86/insts.lisp @@ -192,24 +192,23 @@ (sb!disassem:define-argument-type displacement :sign-extend t :use-label #'offset-next - :printer #'(lambda (value stream dstate) - (sb!disassem:maybe-note-assembler-routine value nil dstate) - (print-label value stream dstate))) + :printer (lambda (value stream dstate) + (sb!disassem:maybe-note-assembler-routine value nil dstate) + (print-label value stream dstate))) (sb!disassem:define-argument-type accum - :printer #'(lambda (value stream dstate) - (declare (ignore value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) - (print-reg 0 stream dstate)) - ) + :printer (lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type sb!disassem:disassem-state dstate)) + (print-reg 0 stream dstate))) (sb!disassem:define-argument-type word-accum - :printer #'(lambda (value stream dstate) - (declare (ignore value) - (type stream stream) - (type sb!disassem:disassem-state dstate)) - (print-word-reg 0 stream dstate))) + :printer (lambda (value stream dstate) + (declare (ignore value) + (type stream stream) + (type sb!disassem:disassem-state dstate)) + (print-word-reg 0 stream dstate))) (sb!disassem:define-argument-type reg :printer #'print-reg) @@ -225,43 +224,41 @@ :printer #'print-label) (sb!disassem:define-argument-type imm-data - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-suffix - (width-bits (sb!disassem:dstate-get-prop dstate 'width)) - dstate)) - ) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-suffix + (width-bits (sb!disassem:dstate-get-prop dstate 'width)) + dstate))) (sb!disassem:define-argument-type signed-imm-data - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (let ((width (sb!disassem:dstate-get-prop dstate 'width))) - (sb!disassem:read-signed-suffix (width-bits width) dstate))) - ) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width (sb!disassem:dstate-get-prop dstate 'width))) + (sb!disassem:read-signed-suffix (width-bits width) dstate)))) (sb!disassem:define-argument-type signed-imm-byte - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-signed-suffix 8 dstate))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-signed-suffix 8 dstate))) (sb!disassem:define-argument-type signed-imm-dword - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-signed-suffix 32 dstate))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-signed-suffix 32 dstate))) (sb!disassem:define-argument-type imm-word - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (let ((width - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+))) - (sb!disassem:read-suffix (width-bits width) dstate)))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (let ((width + (or (sb!disassem:dstate-get-prop dstate 'word-width) + +default-operand-size+))) + (sb!disassem:read-suffix (width-bits width) dstate)))) ;;; needed for the ret imm16 instruction (sb!disassem:define-argument-type imm-word-16 - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-suffix 16 dstate))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-suffix 16 dstate))) (sb!disassem:define-argument-type reg/mem :prefilter #'prefilter-reg/mem @@ -291,16 +288,16 @@ (sb!disassem:define-argument-type width :prefilter #'prefilter-width - :printer #'(lambda (value stream dstate) - (if ;; (zerop value) - (or (null value) - (and (numberp value) (zerop value))) ; zzz jrd - (princ 'b stream) - (let ((word-width - ;; set by a prefix instruction - (or (sb!disassem:dstate-get-prop dstate 'word-width) - +default-operand-size+))) - (princ (schar (symbol-name word-width) 0) stream))))) + :printer (lambda (value stream dstate) + (if;; (zerop value) + (or (null value) + (and (numberp value) (zerop value))) ; zzz jrd + (princ 'b stream) + (let ((word-width + ;; set by a prefix instruction + (or (sb!disassem:dstate-get-prop dstate 'word-width) + +default-operand-size+))) + (princ (schar (symbol-name word-width) 0) stream))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *conditions* @@ -548,9 +545,9 @@ ;; The disassembler currently doesn't let you have an instruction > 32 bits ;; long, so we fake it by using a prefilter to read the offset. (label :type 'displacement - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-signed-suffix 32 dstate)))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-signed-suffix 32 dstate)))) (sb!disassem:define-instruction-format (near-jump 8 :default-printer '(:name :tab label)) @@ -558,9 +555,9 @@ ;; The disassembler currently doesn't let you have an instruction > 32 bits ;; long, so we fake it by using a prefilter to read the address. (label :type 'displacement - :prefilter #'(lambda (value dstate) - (declare (ignore value)) ; always nil anyway - (sb!disassem:read-signed-suffix 32 dstate)))) + :prefilter (lambda (value dstate) + (declare (ignore value)) ; always nil anyway + (sb!disassem:read-signed-suffix 32 dstate)))) (sb!disassem:define-instruction-format (cond-set 24 @@ -612,13 +609,13 @@ (if (label-p offset) (emit-back-patch segment 4 ; FIXME: sb!vm:n-word-bytes - #'(lambda (segment posn) - (declare (ignore posn)) - (emit-dword segment - (- (+ (component-header-length) - (or (label-position offset) - 0)) - other-pointer-lowtag)))) + (lambda (segment posn) + (declare (ignore posn)) + (emit-dword segment + (- (+ (component-header-length) + (or (label-position offset) + 0)) + other-pointer-lowtag)))) (emit-dword segment (or offset 0))))) (defun emit-relative-fixup (segment fixup) @@ -1637,10 +1634,10 @@ (emit-byte segment #b11101000) (emit-back-patch segment 4 - #'(lambda (segment posn) - (emit-dword segment - (- (label-position where) - (+ posn 4)))))) + (lambda (segment posn) + (emit-dword segment + (- (label-position where) + (+ posn 4)))))) (fixup (emit-byte segment #b11101000) (emit-relative-fixup segment where)) @@ -1651,10 +1648,10 @@ (defun emit-byte-displacement-backpatch (segment target) (emit-back-patch segment 1 - #'(lambda (segment posn) - (let ((disp (- (label-position target) (1+ posn)))) - (aver (<= -128 disp 127)) - (emit-byte segment disp))))) + (lambda (segment posn) + (let ((disp (- (label-position target) (1+ posn)))) + (aver (<= -128 disp 127)) + (emit-byte segment disp))))) (define-instruction jmp (segment cond &optional where) ;; conditional jumps @@ -1668,39 +1665,38 @@ (cond (where (emit-chooser segment 6 2 - #'(lambda (segment posn delta-if-after) - (let ((disp (- (label-position where posn delta-if-after) - (+ posn 2)))) - (when (<= -128 disp 127) - (emit-byte segment - (dpb (conditional-opcode cond) - (byte 4 0) - #b01110000)) - (emit-byte-displacement-backpatch segment where) - t))) - #'(lambda (segment posn) - (let ((disp (- (label-position where) (+ posn 6)))) - (emit-byte segment #b00001111) + (lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) (emit-byte segment (dpb (conditional-opcode cond) (byte 4 0) - #b10000000)) - (emit-dword segment disp))))) + #b01110000)) + (emit-byte-displacement-backpatch segment where) + t))) + (lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 6)))) + (emit-byte segment #b00001111) + (emit-byte segment + (dpb (conditional-opcode cond) + (byte 4 0) + #b10000000)) + (emit-dword segment disp))))) ((label-p (setq where cond)) (emit-chooser segment 5 0 - #'(lambda (segment posn delta-if-after) - (let ((disp (- (label-position where posn delta-if-after) - (+ posn 2)))) - (when (<= -128 disp 127) - (emit-byte segment #b11101011) - (emit-byte-displacement-backpatch segment where) - t))) - #'(lambda (segment posn) - (let ((disp (- (label-position where) (+ posn 5)))) - (emit-byte segment #b11101001) - (emit-dword segment disp)) - ))) + (lambda (segment posn delta-if-after) + (let ((disp (- (label-position where posn delta-if-after) + (+ posn 2)))) + (when (<= -128 disp 127) + (emit-byte segment #b11101011) + (emit-byte-displacement-backpatch segment where) + t))) + (lambda (segment posn) + (let ((disp (- (label-position where) (+ posn 5)))) + (emit-byte segment #b11101001) + (emit-dword segment disp))))) ((fixup-p where) (emit-byte segment #b11101001) (emit-relative-fixup segment where)) diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 206cf81..af77dd8 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -68,9 +68,9 @@ (error "At least one type must be supplied for TEST-TYPE.")) (cond (fixnump - (when (remove-if #'(lambda (x) - (or (= x even-fixnum-lowtag) - (= x odd-fixnum-lowtag))) + (when (remove-if (lambda (x) + (or (= x even-fixnum-lowtag) + (= x odd-fixnum-lowtag))) lowtags) (error "can't mix fixnum testing with other lowtags")) (when function-p diff --git a/version.lisp-expr b/version.lisp-expr index 24138f4..91b3d19 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.124" +"0.pre7.125"