From: William Harold Newman Date: Sat, 12 Jan 2002 01:40:11 +0000 (+0000) Subject: 0.pre7.122: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=74a48d09e08aead6f67204878bdf9be4f448e1e8;p=sbcl.git 0.pre7.122: belatedly removed BUGS entry 38 (fixed by MNA in 0.pre7.120) Now that bug 138 is fixed, I can s/#'(lambda/(lambda/ to my heart's content -- in theory. But what have we here, another bizarre xc bug? Apparently. So... ...added #!+SB-SHOW ID slot to some fundamental compiler data structures ...(eventually found that MULTIPLE-VALUE-BIND macro definition is sensitive to s/#'(lambda/(lambda/, which sorta makes sense) --- diff --git a/BUGS b/BUGS index a833316..e5fb392 100644 --- a/BUGS +++ b/BUGS @@ -218,11 +218,6 @@ WORKAROUND: (Also, verify that the compiler handles declared function return types as assertions.) -38: - DEFMETHOD doesn't check the syntax of &REST argument lists properly, - accepting &REST even when it's not followed by an argument name: - (DEFMETHOD FOO ((X T) &REST) NIL) - 41: TYPEP of VALUES types is sometimes implemented very inefficiently, e.g. in (DEFTYPE INDEXOID () '(INTEGER 0 1000)) diff --git a/src/code/array.lisp b/src/code/array.lisp index f2b646a..8adb473 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -492,20 +492,20 @@ "Return the type of the elements of the array" (let ((widetag (widetag-of array))) (macrolet ((pick-element-type (&rest stuff) - `(cond ,@(mapcar #'(lambda (stuff) - (cons - (let ((item (car stuff))) - (cond ((eq item t) - t) - ((listp item) - (cons 'or - (mapcar (lambda (x) - `(= widetag ,x)) - item))) - (t - `(= widetag ,item)))) - (cdr stuff))) - stuff)))) + `(cond ,@(mapcar (lambda (stuff) + (cons + (let ((item (car stuff))) + (cond ((eq item t) + t) + ((listp item) + (cons 'or + (mapcar (lambda (x) + `(= widetag ,x)) + item))) + (t + `(= widetag ,item)))) + (cdr stuff))) + stuff)))) ;; FIXME: The data here are redundant with ;; *SPECIALIZED-ARRAY-ELEMENT-TYPE-PROPERTIES*. (pick-element-type @@ -930,9 +930,9 @@ (defun zap-array-data-aux (old-data old-dims offset new-data new-dims) (declare (fixnum offset)) - (let ((limits (mapcar #'(lambda (x y) - (declare (fixnum x y)) - (1- (the fixnum (min x y)))) + (let ((limits (mapcar (lambda (x y) + (declare (fixnum x y)) + (1- (the fixnum (min x y)))) old-dims new-dims))) (macrolet ((bump-index-list (index limits) `(do ((subscripts ,index (cdr subscripts)) diff --git a/src/code/condition.lisp b/src/code/condition.lisp index ce6dbd3..d7517ae 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -109,7 +109,7 @@ ;; cold-loadable code. -- WHN 19990928 (declare (notinline sb!xc:find-class)) (find-class 'condition))) - #'(lambda (cond stream) + (lambda (cond stream) (format stream "Condition ~S was signalled." (type-of cond)))) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -361,11 +361,11 @@ (let ((name (condition-slot-name slot))) (dolist (reader (condition-slot-readers slot)) (setf (fdefinition reader) - #'(lambda (condition) + (lambda (condition) (condition-reader-function condition name)))) (dolist (writer (condition-slot-writers slot)) (setf (fdefinition writer) - #'(lambda (new-value condition) + (lambda (new-value condition) (condition-writer-function condition new-value name)))))) ;; Compute effective slots and set up the class and hairy slots diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 071a476..69182e8 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -1278,12 +1278,12 @@ (simple-string name)) (let ((name-len (length name))) (position name variables - :test #'(lambda (x y) - (let* ((y (debug-var-symbol-name y)) - (y-len (length y))) - (declare (simple-string y)) - (and (>= y-len name-len) - (string= x y :end1 name-len :end2 name-len)))) + :test (lambda (x y) + (let* ((y (debug-var-symbol-name y)) + (y-len (length y))) + (declare (simple-string y)) + (and (>= y-len name-len) + (string= x y :end1 name-len :end2 name-len)))) :end (or end (length variables))))) ;;; Return a list representing the lambda-list for DEBUG-FUN. The @@ -2697,15 +2697,15 @@ (declare (ignorable ,n-frame)) (symbol-macrolet ,(specs) ,form)) 'function))) - #'(lambda (frame) - ;; This prevents these functions from being used in any - ;; location other than a function return location, so - ;; maybe this should only check whether frame's - ;; DEBUG-FUN is the same as loc's. - (unless (code-location= (frame-code-location frame) loc) - (debug-signal 'frame-fun-mismatch - :code-location loc :form form :frame frame)) - (funcall res frame)))))) + (lambda (frame) + ;; This prevents these functions from being used in any + ;; location other than a function return location, so maybe + ;; this should only check whether FRAME's DEBUG-FUN is the + ;; same as LOC's. + (unless (code-location= (frame-code-location frame) loc) + (debug-signal 'frame-fun-mismatch + :code-location loc :form form :frame frame)) + (funcall res frame)))))) ;;;; breakpoints @@ -2816,31 +2816,31 @@ (defun fun-end-starter-hook (starter-bpt debug-fun) (declare (type breakpoint starter-bpt) (type compiled-debug-fun debug-fun)) - #'(lambda (frame breakpoint) - (declare (ignore breakpoint) - (type frame frame)) - (let ((lra-sc-offset - (sb!c::compiled-debug-fun-return-pc - (compiled-debug-fun-compiler-debug-fun debug-fun)))) - (multiple-value-bind (lra component offset) - (make-bogus-lra - (get-context-value frame - lra-save-offset - lra-sc-offset)) - (setf (get-context-value frame - lra-save-offset - lra-sc-offset) - lra) - (let ((end-bpts (breakpoint-%info starter-bpt))) - (let ((data (breakpoint-data component offset))) - (setf (breakpoint-data-breakpoints data) end-bpts) - (dolist (bpt end-bpts) - (setf (breakpoint-internal-data bpt) data))) - (let ((cookie (make-fun-end-cookie lra debug-fun))) - (setf (gethash component *fun-end-cookies*) cookie) - (dolist (bpt end-bpts) - (let ((fun (breakpoint-cookie-fun bpt))) - (when fun (funcall fun frame cookie)))))))))) + (lambda (frame breakpoint) + (declare (ignore breakpoint) + (type frame frame)) + (let ((lra-sc-offset + (sb!c::compiled-debug-fun-return-pc + (compiled-debug-fun-compiler-debug-fun debug-fun)))) + (multiple-value-bind (lra component offset) + (make-bogus-lra + (get-context-value frame + lra-save-offset + lra-sc-offset)) + (setf (get-context-value frame + lra-save-offset + lra-sc-offset) + lra) + (let ((end-bpts (breakpoint-%info starter-bpt))) + (let ((data (breakpoint-data component offset))) + (setf (breakpoint-data-breakpoints data) end-bpts) + (dolist (bpt end-bpts) + (setf (breakpoint-internal-data bpt) data))) + (let ((cookie (make-fun-end-cookie lra debug-fun))) + (setf (gethash component *fun-end-cookies*) cookie) + (dolist (bpt end-bpts) + (let ((fun (breakpoint-cookie-fun bpt))) + (when fun (funcall fun frame cookie)))))))))) ;;; This takes a FUN-END-COOKIE and a frame, and it returns ;;; whether the cookie is still valid. A cookie becomes invalid when @@ -2969,9 +2969,9 @@ (defun deactivate-compiled-breakpoint (breakpoint) (if (eq (breakpoint-kind breakpoint) :fun-end) (let ((starter (breakpoint-start-helper breakpoint))) - (unless (find-if #'(lambda (bpt) - (and (not (eq bpt breakpoint)) - (eq (breakpoint-status bpt) :active))) + (unless (find-if (lambda (bpt) + (and (not (eq bpt breakpoint)) + (eq (breakpoint-status bpt) :active))) (breakpoint-%info starter)) (deactivate-compiled-breakpoint starter))) (let* ((data (breakpoint-internal-data breakpoint)) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 5e6dd5a..535b429 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -210,19 +210,19 @@ Function and macro commands: (cond ((sb!di:code-location-p place) (find place info-list :key #'breakpoint-info-place - :test #'(lambda (x y) (and (sb!di:code-location-p y) - (sb!di:code-location= x y))))) + :test (lambda (x y) (and (sb!di:code-location-p y) + (sb!di:code-location= x y))))) (t (find place info-list - :test #'(lambda (x-debug-fun y-info) - (let ((y-place (breakpoint-info-place y-info)) - (y-breakpoint (breakpoint-info-breakpoint - y-info))) - (and (sb!di:debug-fun-p y-place) - (eq x-debug-fun y-place) - (or (not kind) - (eq kind (sb!di:breakpoint-kind - y-breakpoint)))))))))) + :test (lambda (x-debug-fun y-info) + (let ((y-place (breakpoint-info-place y-info)) + (y-breakpoint (breakpoint-info-breakpoint + y-info))) + (and (sb!di:debug-fun-p y-place) + (eq x-debug-fun y-place) + (or (not kind) + (eq kind (sb!di:breakpoint-kind + y-breakpoint)))))))))) ;;; If LOC is an unknown location, then try to find the block start ;;; location. Used by source printing to some information instead of @@ -748,18 +748,18 @@ reset to ~S." (print-frame-call *current-frame* :verbosity 2) (loop (catch 'debug-loop-catcher - (handler-bind ((error #'(lambda (condition) - (when *flush-debug-errors* - (clear-input *debug-io*) - (princ condition) - ;; FIXME: Doing input on *DEBUG-IO* - ;; and output on T seems broken. - (format t - "~&error flushed (because ~ - ~S is set)" - '*flush-debug-errors*) - (/show0 "throwing DEBUG-LOOP-CATCHER") - (throw 'debug-loop-catcher nil))))) + (handler-bind ((error (lambda (condition) + (when *flush-debug-errors* + (clear-input *debug-io*) + (princ condition) + ;; FIXME: Doing input on *DEBUG-IO* + ;; and output on T seems broken. + (format t + "~&error flushed (because ~ + ~S is set)" + '*flush-debug-errors*) + (/show0 "throwing DEBUG-LOOP-CATCHER") + (throw 'debug-loop-catcher nil))))) ;; We have to bind level for the restart function created by ;; WITH-SIMPLE-RESTART. (let ((level *debug-command-level*) @@ -836,9 +836,9 @@ reset to ~S." name)))) (location (sb!di:frame-code-location *current-frame*)) ;; Let's only deal with valid variables. - (vars (remove-if-not #'(lambda (v) - (eq (sb!di:debug-var-validity v location) - :valid)) + (vars (remove-if-not (lambda (v) + (eq (sb!di:debug-var-validity v location) + :valid)) temp))) (declare (list vars)) (cond ((null vars) @@ -879,9 +879,9 @@ reset to ~S." ;; name. ((and (not exact) (find-if-not - #'(lambda (v) - (string= (sb!di:debug-var-symbol-name v) - (sb!di:debug-var-symbol-name (car vars)))) + (lambda (v) + (string= (sb!di:debug-var-symbol-name v) + (sb!di:debug-var-symbol-name (car vars)))) (cdr vars))) (error "specification ambiguous:~%~{ ~A~%~}" (mapcar #'sb!di:debug-var-symbol-name @@ -1063,9 +1063,9 @@ argument") (dolist (restart restarts) (let ((name (string (restart-name restart)))) (let ((restart-fun - #'(lambda () - (/show0 "in restart-command closure, about to i-r-i") - (invoke-restart-interactively restart)))) + (lambda () + (/show0 "in restart-command closure, about to i-r-i") + (invoke-restart-interactively restart)))) (push (cons (prin1-to-string num) restart-fun) commands) (unless (or (null (restart-name restart)) (find name commands :key #'car :test #'string=)) @@ -1166,9 +1166,9 @@ argument") (nth num *debug-restarts*)) (symbol (find num *debug-restarts* :key #'restart-name - :test #'(lambda (sym1 sym2) - (string= (symbol-name sym1) - (symbol-name sym2))))) + :test (lambda (sym1 sym2) + (string= (symbol-name sym1) + (symbol-name sym2))))) (t (format t "~S is invalid as a restart name.~%" num) (return-from restart-debug-command nil))))) @@ -1344,10 +1344,10 @@ argument") (setq *cached-readtable* (copy-readtable)) (set-dispatch-macro-character #\# #\. - #'(lambda (stream sub-char &rest rest) - (declare (ignore rest sub-char)) - (let ((token (read stream t nil t))) - (format nil "#.~S" token))) + (lambda (stream sub-char &rest rest) + (declare (ignore rest sub-char)) + (let ((token (read stream t nil t))) + (format nil "#.~S" token))) *cached-readtable*)) (let ((*readtable* *cached-readtable*)) (read *cached-source-stream*)))) diff --git a/src/code/defboot.lisp b/src/code/defboot.lisp index fef50bf..b11c1d2 100644 --- a/src/code/defboot.lisp +++ b/src/code/defboot.lisp @@ -58,8 +58,8 @@ ((list-of-symbols-p vars) (let ((temps (make-gensym-list (length vars)))) `(multiple-value-bind ,temps ,value-form - ,@(mapcar #'(lambda (var temp) - `(setq ,var ,temp)) + ,@(mapcar (lambda (var temp) + `(setq ,var ,temp)) vars temps) ,(car temps)))) (t (error "Vars is not a list of symbols: ~S" vars)))) diff --git a/src/code/defpackage.lisp b/src/code/defpackage.lisp index ec8763c..08ca514 100644 --- a/src/code/defpackage.lisp +++ b/src/code/defpackage.lisp @@ -128,8 +128,8 @@ (error "bogus ~A name: ~S" kind name)))) (defun stringify-names (names kind) - (mapcar #'(lambda (name) - (stringify-name name kind)) + (mapcar (lambda (name) + (stringify-name name kind)) names)) (defun %defpackage (name nicknames size shadows shadowing-imports @@ -190,7 +190,7 @@ package)))) ;; Handle exports. (let ((old-exports nil) - (exports (mapcar #'(lambda (sym-name) (intern sym-name package)) + (exports (mapcar (lambda (sym-name) (intern sym-name package)) exports))) (do-external-symbols (sym package) (push sym old-exports)) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 5c3eb5c..d3fc916 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -721,7 +721,7 @@ (dolist (included-slot (dd-slots included-structure)) (let* ((included-name (dsd-name included-slot)) (modified (or (find included-name modified-slots - :key #'(lambda (x) (if (atom x) x (car x))) + :key (lambda (x) (if (atom x) x (car x))) :test #'string=) `(,included-name)))) (parse-1-dsd dd @@ -1141,15 +1141,15 @@ (let ((temp (gensym)) (etype (dd-element-type dd))) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type (and ,type ,etype) ,var)) + (declare ,@(mapcar (lambda (var type) `(type (and ,type ,etype) ,var)) vars types)) (let ((,temp (make-array ,(dd-length dd) :element-type ',(dd-element-type dd)))) - ,@(mapcar #'(lambda (x) - `(setf (aref ,temp ,(cdr x)) ',(car x))) + ,@(mapcar (lambda (x) + `(setf (aref ,temp ,(cdr x)) ',(car x))) (find-name-indices dd)) - ,@(mapcar #'(lambda (dsd value) - `(setf (aref ,temp ,(dsd-index dsd)) ,value)) + ,@(mapcar (lambda (dsd value) + `(setf (aref ,temp ,(dsd-index dsd)) ,value)) (dd-slots dd) values) ,temp)))) (defun create-list-constructor (dd cons-name arglist vars types values) @@ -1160,8 +1160,7 @@ (setf (elt vals (dsd-index dsd)) val)) `(defun ,cons-name ,arglist - (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var)) - vars types)) + (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types)) (list ,@vals)))) (defun create-structure-constructor (dd cons-name arglist vars types values) (let* ((instance (gensym "INSTANCE")) @@ -1275,9 +1274,9 @@ (funcall creator defstruct (first boa) (arglist) (vars) (types) - (mapcar #'(lambda (slot) - (or (find (dsd-name slot) (vars) :test #'string=) - (dsd-default slot))) + (mapcar (lambda (slot) + (or (find (dsd-name slot) (vars) :test #'string=) + (dsd-default slot))) (dd-slots defstruct)))))) ;;; Grovel the constructor options, and decide what constructors (if diff --git a/src/code/dyncount.lisp b/src/code/dyncount.lisp index c14cb73..2ad918e 100644 --- a/src/code/dyncount.lisp +++ b/src/code/dyncount.lisp @@ -172,10 +172,10 @@ comments from CMU CL: (without-gcing (dolist (space spaces) (sb!vm::map-allocated-objects - #'(lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (clear-dyncount-info object))) + (lambda (object type-code size) + (declare (ignore type-code size)) + (when (dyncount-info-p object) + (clear-dyncount-info object))) space))))) ;;; Call NOTE-DYNCOUNT-INFO on all DYNCOUNT-INFO structure allocated in the @@ -193,12 +193,12 @@ comments from CMU CL: (without-gcing (dolist (space spaces) (sb!vm::map-allocated-objects - #'(lambda (object type-code size) - (declare (ignore type-code size)) - (when (dyncount-info-p object) - (note-dyncount-info object) - (when clear - (clear-dyncount-info object)))) + (lambda (object type-code size) + (declare (ignore type-code size)) + (when (dyncount-info-p object) + (note-dyncount-info object) + (when clear + (clear-dyncount-info object)))) space)))) (let ((counts (make-hash-table :test 'equal))) @@ -232,8 +232,8 @@ comments from CMU CL: (clear-vop-counts spaces) (apply function args) (if by-space - (mapcar #'(lambda (space) - (get-vop-counts (list space) :clear t)) + (mapcar (lambda (space) + (get-vop-counts (list space) :clear t)) spaces) (get-vop-counts spaces))) @@ -403,10 +403,10 @@ comments from CMU CL: (defun sort-result (table by) (sort (hash-list table) #'> - :key #'(lambda (x) - (abs (ecase by - (:count (vop-stats-count x)) - (:cost (vop-stats-cost x))))))) + :key (lambda (x) + (abs (ecase by + (:count (vop-stats-count x)) + (:cost (vop-stats-cost x))))))) ;;; Report about VOPs in the list of stats structures. (defun entry-report (entries cut-off compensated compare total-cost) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 8c1b308..4d84e8c 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -462,8 +462,8 @@ (,n-cache ,var-name)) (declare (type fixnum ,n-index)) ,@(sets) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) (values-names)) (values))))) @@ -479,8 +479,8 @@ (dotimes (i nargs) (arg-sets `(setf (svref ,n-cache (+ ,n-index ,i)) nil))) (arg-sets)) - ,@(mapcar #'(lambda (i val) - `(setf (svref ,n-cache ,i) ,val)) + ,@(mapcar (lambda (i val) + `(setf (svref ,n-cache ,i) ,val)) (values-indices) default-values)) (values))) diff --git a/src/code/early-setf.lisp b/src/code/early-setf.lisp index 8a21d7a..e532da6 100644 --- a/src/code/early-setf.lisp +++ b/src/code/early-setf.lisp @@ -174,8 +174,8 @@ GET-SETF-EXPANSION directly." `(let* ,(nreverse bindlist) ,@(nreverse storelist) ,resultvar)) (multiple-value-bind (sm1 sm2 sm3 sm4 sm5) (get-setf-method (first arglist) env) - (mapc #'(lambda (var val) - (push `(,var ,val) bindlist)) + (mapc (lambda (var val) + (push `(,var ,val) bindlist)) sm1 sm2) (push `(,lastvar ,sm5) bindlist) @@ -378,13 +378,13 @@ GET-SETF-EXPANSION directly." `(eval-when (:compile-toplevel :load-toplevel :execute) (assign-setf-macro ',access-fn - #'(lambda (,access-form-var ,env-var) - (declare (ignore ,env-var)) - (%defsetf ,access-form-var ,(length store-variables) - #'(lambda (,arglist-var) - ,@local-decs - (block ,access-fn - ,body)))) + (lambda (,access-form-var ,env-var) + (declare (ignore ,env-var)) + (%defsetf ,access-form-var ,(length store-variables) + (lambda (,arglist-var) + ,@local-decs + (block ,access-fn + ,body)))) nil ',doc)))))) (t @@ -432,9 +432,9 @@ GET-SETF-EXPANSION directly." :environment environment) `(eval-when (:compile-toplevel :load-toplevel :execute) (assign-setf-macro ',access-fn - #'(lambda (,whole ,environment) - ,@local-decs - (block ,access-fn ,body)) + (lambda (,whole ,environment) + ,@local-decs + (block ,access-fn ,body)) nil ',doc))))) diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp index aea8b57..105ee6f 100644 --- a/src/code/fd-stream.lisp +++ b/src/code/fd-stream.lisp @@ -154,9 +154,9 @@ (setf (fd-stream-handler stream) (sb!sys:add-fd-handler (fd-stream-fd stream) :output - #'(lambda (fd) - (declare (ignore fd)) - (do-output-later stream))))) + (lambda (fd) + (declare (ignore fd)) + (do-output-later stream))))) (t (nconc (fd-stream-output-later stream) (list (list base start end reuse-sap))))) @@ -203,38 +203,38 @@ (declare (optimize (speed 1))) (cons 'progn (mapcar - #'(lambda (buffering) - (let ((function - (intern (let ((*print-case* :upcase)) - (format nil name-fmt (car buffering)))))) - `(progn - (defun ,function (stream byte) - ,(unless (eq (car buffering) :none) - `(when (< (fd-stream-obuf-length stream) - (+ (fd-stream-obuf-tail stream) - ,size)) - (flush-output-buffer stream))) - ,@body - (incf (fd-stream-obuf-tail stream) ,size) - ,(ecase (car buffering) - (:none - `(flush-output-buffer stream)) - (:line - `(when (eq (char-code byte) (char-code #\Newline)) - (flush-output-buffer stream))) - (:full - )) - (values)) - (setf *output-routines* - (nconc *output-routines* - ',(mapcar - #'(lambda (type) - (list type - (car buffering) - function - size)) - (cdr buffering))))))) - bufferings))) + (lambda (buffering) + (let ((function + (intern (let ((*print-case* :upcase)) + (format nil name-fmt (car buffering)))))) + `(progn + (defun ,function (stream byte) + ,(unless (eq (car buffering) :none) + `(when (< (fd-stream-obuf-length stream) + (+ (fd-stream-obuf-tail stream) + ,size)) + (flush-output-buffer stream))) + ,@body + (incf (fd-stream-obuf-tail stream) ,size) + ,(ecase (car buffering) + (:none + `(flush-output-buffer stream)) + (:line + `(when (eq (char-code byte) (char-code #\Newline)) + (flush-output-buffer stream))) + (:full + )) + (values)) + (setf *output-routines* + (nconc *output-routines* + ',(mapcar + (lambda (type) + (list type + (car buffering) + function + size)) + (cdr buffering))))))) + bufferings))) (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED" 1 diff --git a/src/code/final.lisp b/src/code/final.lisp index e3685dc..5b9d1ba 100644 --- a/src/code/final.lisp +++ b/src/code/final.lisp @@ -34,19 +34,19 @@ (sb!sys:without-gcing (setf *objects-pending-finalization* (delete object *objects-pending-finalization* - :key #'(lambda (pair) - (values (weak-pointer-value (car pair)))))))) + :key (lambda (pair) + (values (weak-pointer-value (car pair)))))))) nil) (defun finalize-corpses () (setf *objects-pending-finalization* - (delete-if #'(lambda (pair) - (multiple-value-bind (object valid) - (weak-pointer-value (car pair)) - (declare (ignore object)) - (unless valid - (funcall (cdr pair)) - t))) + (delete-if (lambda (pair) + (multiple-value-bind (object valid) + (weak-pointer-value (car pair)) + (declare (ignore object)) + (unless valid + (funcall (cdr pair)) + t))) *objects-pending-finalization*)) nil) diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index 8260291..5723d47 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -33,9 +33,9 @@ ;;; Return a mask with all the specified float trap bits set. (defun float-trap-mask (names) (reduce #'logior - (mapcar #'(lambda (x) - (or (cdr (assoc x *float-trap-alist*)) - (error "unknown float trap kind: ~S" x))) + (mapcar (lambda (x) + (or (cdr (assoc x *float-trap-alist*)) + (error "unknown float trap kind: ~S" x))) names))) ) ; EVAL-WHEN @@ -105,9 +105,9 @@ (flet ((exc-keys (bits) (macrolet ((frob () `(collect ((res)) - ,@(mapcar #'(lambda (x) - `(when (logtest bits ,(cdr x)) - (res ',(car x)))) + ,@(mapcar (lambda (x) + `(when (logtest bits ,(cdr x)) + (res ',(car x)))) *float-trap-alist*) (res)))) (frob)))) diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 7d52587..712deb3 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -673,21 +673,21 @@ (t (make-alien-enum-type :name name :signed signed :from from-alist - :to (mapcar #'(lambda (x) (cons (cdr x) (car x))) + :to (mapcar (lambda (x) (cons (cdr x) (car x))) from-alist) :kind :alist)))))) (define-alien-type-method (enum :unparse) (type) `(enum ,(alien-enum-type-name type) ,@(let ((prev -1)) - (mapcar #'(lambda (mapping) - (let ((sym (car mapping)) - (value (cdr mapping))) - (prog1 - (if (= (1+ prev) value) - sym - `(,sym ,value)) - (setf prev value)))) + (mapcar (lambda (mapping) + (let ((sym (car mapping)) + (value (cdr mapping))) + (prog1 + (if (= (1+ prev) value) + sym + `(,sym ,value)) + (setf prev value)))) (alien-enum-type-from type))))) (define-alien-type-method (enum :type=) (type1 type2) @@ -706,14 +706,14 @@ (+ ,alien ,(alien-enum-type-offset type)))) (:alist `(ecase ,alien - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) + ,@(mapcar (lambda (mapping) + `(,(car mapping) ,(cdr mapping))) (alien-enum-type-to type)))))) (define-alien-type-method (enum :deport-gen) (type value) `(ecase ,value - ,@(mapcar #'(lambda (mapping) - `(,(car mapping) ,(cdr mapping))) + ,@(mapcar (lambda (mapping) + `(,(car mapping) ,(cdr mapping))) (alien-enum-type-from type)))) ;;;; the FLOAT types @@ -856,7 +856,7 @@ (unless (typep (first dims) '(or index null)) (error "The first dimension is not a non-negative fixnum or NIL: ~S" (first dims))) - (let ((loser (find-if-not #'(lambda (x) (typep x 'index)) + (let ((loser (find-if-not (lambda (x) (typep x 'index)) (rest dims)))) (when loser (error "A dimension is not a non-negative fixnum: ~S" loser)))) @@ -999,11 +999,11 @@ ,(alien-record-type-name type) ,@(unless (member type *record-types-already-unparsed* :test #'eq) (push type *record-types-already-unparsed*) - (mapcar #'(lambda (field) - `(,(alien-record-field-name field) - ,(%unparse-alien-type (alien-record-field-type field)) - ,@(if (alien-record-field-bits field) - (list (alien-record-field-bits field))))) + (mapcar (lambda (field) + `(,(alien-record-field-name field) + ,(%unparse-alien-type (alien-record-field-type field)) + ,@(if (alien-record-field-bits field) + (list (alien-record-field-bits field))))) (alien-record-type-fields type))))) ;;; Test the record fields. The depth is limiting in case of cyclic diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index c0dba38..c82c568 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -115,6 +115,18 @@ (defvar *trace-table*) (defvar *undefined-warnings*) (defvar *warnings-p*) + +;;; unique ID for the next object created (to let us track object +;;; identity even across GC, useful for understanding weird compiler +;;; bugs where something is supposed to be unique but is instead +;;; exists as duplicate objects) +#!+sb-show +(progn + (defvar *object-id-counter* 0) + (defun new-object-id () + (prog1 + *object-id-counter* + (incf *object-id-counter*)))) ;;;; miscellaneous utilities diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 6cc0210..0774feb 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -144,6 +144,8 @@ (defstruct (node (:constructor nil) (:copier nil)) + ;; unique ID for debugging + #!+sb-show (id (new-object-id) :read-only t) ;; the bottom-up derived type for this node. This does not take into ;; consideration output type assertions on this node (actually on its CONT). (derived-type *wild-type* :type ctype) @@ -337,6 +339,8 @@ ;;; structures to be reclaimed after the compilation of each ;;; component. (defstruct (component (:copier nil)) + ;; unique ID for debugging + #!+sb-show (id (new-object-id) :read-only t) ;; the kind of component ;; ;; (The terminology here is left over from before @@ -433,6 +437,7 @@ (reanalyze-funs nil :type list)) (defprinter (component :identity t) name + #!+sb-show id (reanalyze :test reanalyze)) ;;; Check that COMPONENT is suitable for roles which involve adding @@ -610,6 +615,8 @@ ;;; hacking the flow graph. (def!struct (leaf (:make-load-form-fun ignore-it) (:constructor nil)) + ;; unique ID for debugging + #!+sb-show (id (new-object-id) :read-only t) ;; (For public access to this slot, use LEAF-SOURCE-NAME.) ;; ;; the name of LEAF as it appears in the source, e.g. 'FOO or '(SETF @@ -697,6 +704,7 @@ :type (member :special :global-function :global))) (defprinter (global-var :identity t) %source-name + #!+sb-show id (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) kind) @@ -735,6 +743,7 @@ (functional nil :type (or functional null))) (defprinter (defined-fun :identity t) %source-name + #!+sb-show id inlinep (functional :test functional)) @@ -883,7 +892,8 @@ (plist () :type list)) (defprinter (functional :identity t) %source-name - %debug-name) + %debug-name + #!+sb-show id) ;;; FUNCTIONAL name operations (defun functional-debug-name (functional) @@ -964,6 +974,7 @@ (defprinter (clambda :conc-name lambda- :identity t) %source-name %debug-name + #!+sb-show id (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) (vars :prin1 (mapcar #'leaf-source-name vars))) @@ -1024,6 +1035,7 @@ (defprinter (optional-dispatch :identity t) %source-name %debug-name + #!+sb-show id (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) arglist @@ -1101,6 +1113,7 @@ (constraints nil :type (or sset null))) (defprinter (lambda-var :identity t) %source-name + #!+sb-show id (type :test (not (eq type *universal-type*))) (where-from :test (not (eq where-from :assumed))) (ignorep :test ignorep) @@ -1118,6 +1131,7 @@ ;; The leaf referenced. (leaf nil :type leaf)) (defprinter (ref :identity t) + #!+sb-show id leaf) ;;; Naturally, the IF node always appears at the end of a block. @@ -1187,6 +1201,7 @@ (:constructor make-combination (fun)) (:copier nil))) (defprinter (combination :identity t) + #!+sb-show id (fun :prin1 (continuation-use fun)) (args :prin1 (mapcar (lambda (x) (if x @@ -1247,11 +1262,12 @@ ;;; cleanup. (defstruct (entry (:include node) (:copier nil)) - ;; All of the Exit nodes for potential non-local exits to this point. + ;; All of the EXIT nodes for potential non-local exits to this point. (exits nil :type list) ;; The cleanup for this entry. NULL only temporarily. (cleanup nil :type (or cleanup null))) -(defprinter (entry :identity t)) +(defprinter (entry :identity t) + #!+sb-show id) ;;; The EXIT node marks the place at which exit code would be emitted, ;;; if necessary. This is interposed between the uses of the exit @@ -1270,6 +1286,7 @@ ;; then no value is desired (as in GO). (value nil :type (or continuation null))) (defprinter (exit :identity t) + #!+sb-show id (entry :test entry) (value :test value))