From: William Harold Newman Date: Wed, 5 Sep 2001 01:37:37 +0000 (+0000) Subject: 0.pre7.33: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f4f18b9dcdaf1948947b1747f5bfa766a1a0ee4c;p=sbcl.git 0.pre7.33: fixed (LOOP FOR KEY BEING EACH HASH-KEY IN HASH COLLECT KEY) bug reported by Alexey Dejneka on sbcl-devel 2001-09-03 some package cleanup in preparation for making byte-interp.lisp IN-PACKAGE SB!BYTECODE.. ..exported &MORE from SB!INT instead of SB!C ..exported MAKE-VALUE-CELL, VALUE-CELL-REF, and VALUE-CELL-SET from SB!KERNEL instead of SB!C, so that they're visible in SB!BYTECODE. also put &MORE onto the LAMBDA-LIST-KEYWORDS list added SB-XC prefixes to LAMBDA-LIST-KEYWORDS usage rearranged macroexpand/uncross/eval operations in cross-compiler PROCESS-TOP-LEVEL-FORM so xcompiling DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS will redefine SB-XC:LAMBDA-LIST-KEYWORDS instead of CL:LAMBDA-LIST-KEYWORDS tweaked PARSE-1-DSD so that it always sets DSD-ACCESSOR, dropping CMU CL's "don't shadow inherited accessor" special case --- diff --git a/NEWS b/NEWS index 896c78a..e361a7d 100644 --- a/NEWS +++ b/NEWS @@ -845,6 +845,8 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: fixes:-). But hopefully any remaining bugs will be simpler, less fundamental, and more fixable then the bugs in the old IR1 interpreter code. +* A bug in LOOP operations on hash tables has been fixed, thanks + to a bug report and patch from Alexey Dejneka. * PPRINT-LOGICAL-BLOCK now copies the *PRINT-LINES* value on entry and uses that copy, rather than the current dynamic value, when it's trying to decide whether to truncate output . Thus e.g. @@ -861,7 +863,8 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: built into the system. * lots of tidying up internally: renaming things so that names are more systematic and consistent, converting C macros to inline - functions, systematizing indentation + functions, systematizing indentation, making symbol packaging + more logical, and so forth * The fasl file version number changed again, for any number of good reasons. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b09d582..b2acff8 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -145,6 +145,12 @@ "SUBTRACT-BIGNUM" "SXHASH-BIGNUM")) #s(sb-cold:package-data + :name "SB!BYTECODE" + :doc "private: stuff related to the bytecode interpreter" + :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL") + :export ()) + + #s(sb-cold:package-data :name "SB!C" :doc "private: implementation of the compiler" ;; (It seems strange to have the compiler USE SB-ALIEN-INTERNALS, @@ -159,7 +165,7 @@ #!+sb-dyncount "SB-DYNCOUNT" "SB!EXT" "SB!FASL" "SB!INT" "SB!KERNEL" "SB!SYS") :reexport ("SLOT" "CODE-INSTRUCTIONS" "FLUSHABLE") - :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "&MORE" + :export ("%ALIEN-FUNCALL" "%CATCH-BREAKUP" "%CONTINUE-UNWIND" "%LISTIFY-REST-ARGS" "%MORE-ARG" "%MORE-ARG-VALUES" "%UNWIND-PROTECT-BREAKUP" @@ -219,7 +225,7 @@ "MAKE-OTHER-IMMEDIATE-TYPE" "MAKE-RANDOM-TN" "MAKE-REPRESENTATION-TN" "MAKE-RESTRICTED-TN" "MAKE-SC-OFFSET" "MAKE-STACK-POINTER-TN" "MAKE-TN-REF" "MAKE-UNWIND-BLOCK" - "MAKE-VALUE-CELL" "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE" + "MAKE-WIRED-TN" "MAYBE-COMPILER-NOTE" "META-PRIMITIVE-TYPE-OR-LOSE" "META-SB-OR-LOSE" "META-SC-NUMBER-OR-LOSE" "META-SC-OR-LOSE" "MORE-ARG-CONTEXT" "MOVABLE" "MOVE" "MULTIPLE-CALL" @@ -247,7 +253,6 @@ "TN-REF-TN" "TN-REF-VOP" "TN-REF-WRITE-P" "TN-SC" "TN-VALUE" "TRACE-TABLE-ENTRY" "TYPE-CHECK-ERROR" "UNBIND" "UNBIND-TO-HERE" "UNSAFE" "UNWIND" "UWP-ENTRY" - "VALUE-CELL-REF" "VALUE-CELL-SET" "VERIFY-ARGUMENT-COUNT" "WRITE-PACKED-BIT-VECTOR" "WRITE-VAR-INTEGER" "WRITE-VAR-STRING" "XEP-ALLOCATE-FRAME" "LABEL-ID" "FIXUP" "FIXUP-FLAVOR" "FIXUP-NAME" "FIXUP-OFFSET" @@ -484,12 +489,6 @@ like *STACK-TOP-HINT*" "DSTATE-CUR-ADDR" "DSTATE-NEXT-ADDR")) #s(sb-cold:package-data - :name "SB!BYTECODE" - :doc "private: stuff related to the bytecode interpreter" - :use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL") - :export ()) - - #s(sb-cold:package-data :name "SB!EXT" :doc "public: miscellaneous supported extensions to the ANSI Lisp spec" ;; FIXME: Why don't we just USE-PACKAGE %KERNEL here instead of importing? @@ -643,6 +642,9 @@ retained, possibly temporariliy, because it might be used internally." "*ALL-MODIFIER-NAMES*" "*BACKUP-EXTENSION*" + ;; lambda list keyword extensions + "&MORE" + ;; INFO stuff doesn't belong in a user-visible package, we ;; should be able to change it without apology. "*INFO-ENVIRONMENT*" @@ -886,6 +888,12 @@ retained, possibly temporariliy, because it might be used internally." "MAXIMIZING" "MINIMIZING" "SUMMING" "*ITERATE-WARNINGS*")) + ;; FIXME: This package is awfully huge. It'd probably be good to + ;; split it. There's at least one natural way to split it: the + ;; implementation of the Lisp type system (e.g. TYPE-INTERSECTION and + ;; SPECIFIER-TYPE) could move to a separate package SB!TYPE. (There's + ;; lots of stuff which currently uses the SB!KERNEL package which + ;; doesn't actually use the type system stuff.) #s(sb-cold:package-data :name "SB!KERNEL" :doc @@ -1074,6 +1082,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE" "MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY" "%MAKE-INSTANCE" + "MAKE-VALUE-CELL" "MAKE-VALUES-TYPE" "MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS" "MEMBER-TYPE-P" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE" @@ -1199,7 +1208,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "UNKNOWN-KEY-ARGUMENT-ERROR" "UNKNOWN-TYPE" "UNKNOWN-TYPE-P" "UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR" - "UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE" + "UNSIGNED-BYTE-32-P" + "VALUE-CELL-REF" "VALUE-CELL-SET" + "VALUES-SPECIFIER-TYPE" "VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP" "VALUES-TYPE" "VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP" diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index 5b237fb..23ad564 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -2201,7 +2201,7 @@ (aver (typep frame 'compiled-frame)) (let ((res (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p res) - (sb!c:value-cell-ref res) + (value-cell-ref res) res))) ;; (This function used to be more interesting, with more type ;; cases here, before the IR1 interpreter went away. It might @@ -2542,7 +2542,7 @@ (aver (typep frame 'compiled-frame)) (let ((current-value (access-compiled-debug-var-slot debug-var frame))) (if (indirect-value-cell-p current-value) - (sb!c:value-cell-set current-value value) + (value-cell-set current-value value) (set-compiled-debug-var-slot debug-var frame value)))) ;; (This function used to be more interesting, with more type ;; cases here, before the IR1 interpreter went away. It might diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 7b16ef2..dd97a6d 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -121,8 +121,12 @@ %name ;; its position in the implementation sequence (index (required-argument) :type fixnum) - ;; Name of accessor, or NIL if this accessor has the same name as an - ;; inherited accessor (which we don't want to shadow.) + ;; the name of the accessor function + ;; + ;; (CMU CL had extra complexity here ("..or NIL if this accessor has + ;; the same name as an inherited accessor (which we don't want to + ;; shadow)") but that behavior doesn't seem to be specified by (or + ;; even particularly consistent with) ANSI, so it's gone in SBCL.) (accessor nil) default ; default value expression (type t) ; declared type specifier @@ -567,10 +571,7 @@ ;;; Parse a slot description for DEFSTRUCT, add it to the description ;;; and return it. If supplied, ISLOT is a pre-initialized DSD that we ;;; modify to get the new slot. This is supplied when handling -;;; included slots. If the new accessor name is already an accessor -;;; for same slot in some included structure, then set the -;;; DSD-ACCESSOR to NIL so that we don't clobber the more general -;;; accessor. +;;; included slots. (defun parse-1-dsd (defstruct spec &optional (islot (make-defstruct-slot-description :%name "" :index 0 @@ -591,7 +592,7 @@ (when (keywordp spec) ;; FIXME: should be style warning (warn "Keyword slot name indicates probable syntax ~ - error in DEFSTRUCT -- ~S." + error in DEFSTRUCT: ~S." spec)) spec)) @@ -601,20 +602,8 @@ :format-arguments (list name))) (setf (dsd-%name islot) (string name)) (setf (dd-slots defstruct) (nconc (dd-slots defstruct) (list islot))) - - (let* ((accname (symbolicate (or (dd-conc-name defstruct) "") name)) - (existing (info :function :accessor-for accname))) - (declare (notinline find)) ; to avoid bug 117 bogowarnings - (if (and (structure-class-p existing) - (not (eq (sb!xc:class-name existing) (dd-name defstruct))) - (string= (dsd-%name (find accname - (dd-slots - (layout-info - (class-layout existing))) - :key #'dsd-accessor)) - name)) - (setf (dsd-accessor islot) nil) - (setf (dsd-accessor islot) accname))) + (setf (dsd-accessor islot) + (symbolicate (or (dd-conc-name defstruct) "") name)) (when default-p (setf (dsd-default islot) default)) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 3513c26..1df85e1 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -581,26 +581,27 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (when (or *loop-duplicate-code* (not rbefore)) (return-from loop-body (makebody))) ;; This outer loop iterates once for each not-first-time flag test - ;; generated plus once more for the forms that don't need a flag test + ;; generated plus once more for the forms that don't need a flag test. (do ((threshold (loop-code-duplication-threshold env))) (nil) (declare (fixnum threshold)) - ;; Go backwards from the ends of before-loop and after-loop merging all - ;; the equivalent forms into the body. + ;; Go backwards from the ends of before-loop and after-loop + ;; merging all the equivalent forms into the body. (do () ((or (null rbefore) (not (equal (car rbefore) (car rafter))))) (push (pop rbefore) main-body) (pop rafter)) (unless rbefore (return (makebody))) - ;; The first forms in RBEFORE & RAFTER (which are the chronologically - ;; last forms in the list) differ, therefore they cannot be moved - ;; into the main body. If everything that chronologically precedes - ;; them either differs or is equal but is okay to duplicate, we can - ;; just put all of rbefore in the prologue and all of rafter after - ;; the body. Otherwise, there is something that is not okay to - ;; duplicate, so it and everything chronologically after it in - ;; rbefore and rafter must go into the body, with a flag test to - ;; distinguish the first time around the loop from later times. - ;; What chronologically precedes the non-duplicatable form will - ;; be handled the next time around the outer loop. + ;; The first forms in RBEFORE & RAFTER (which are the + ;; chronologically last forms in the list) differ, therefore + ;; they cannot be moved into the main body. If everything that + ;; chronologically precedes them either differs or is equal but + ;; is okay to duplicate, we can just put all of rbefore in the + ;; prologue and all of rafter after the body. Otherwise, there + ;; is something that is not okay to duplicate, so it and + ;; everything chronologically after it in rbefore and rafter + ;; must go into the body, with a flag test to distinguish the + ;; first time around the loop from later times. What + ;; chronologically precedes the non-duplicatable form will be + ;; handled the next time around the outer loop. (do ((bb rbefore (cdr bb)) (aa rafter (cdr aa)) (lastdiff nil) @@ -639,9 +640,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (if (null expr) 0 (let ((ans (estimate-code-size expr env))) (declare (fixnum ans)) - ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to get an - ;; alist of optimize quantities back to help quantify how much code we - ;; are willing to duplicate. + ;; @@@@ Use (DECLARATION-INFORMATION 'OPTIMIZE ENV) here to + ;; get an alist of optimize quantities back to help quantify + ;; how much code we are willing to duplicate. ans))) (defvar *special-code-sizes* @@ -910,17 +911,18 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (and *loop-source-code* ; Don't get confused by NILs.. (let ((z (car *loop-source-code*))) (cond ((loop-tequal z 'of-type) - ;; This is the syntactically unambigous form in that the form - ;; of the type specifier does not matter. Also, it is assumed - ;; that the type specifier is unambiguously, and without need - ;; of translation, a common lisp type specifier or pattern - ;; (matching the variable) thereof. + ;; This is the syntactically unambigous form in that + ;; the form of the type specifier does not matter. + ;; Also, it is assumed that the type specifier is + ;; unambiguously, and without need of translation, a + ;; common lisp type specifier or pattern (matching the + ;; variable) thereof. (loop-pop-source) (loop-pop-source)) ((symbolp z) - ;; This is the (sort of) "old" syntax, even though we didn't - ;; used to support all of these type symbols. + ;; This is the (sort of) "old" syntax, even though we + ;; didn't used to support all of these type symbols. (let ((type-spec (or (gethash z (loop-universe-type-symbols *loop-universe*)) @@ -931,11 +933,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (loop-pop-source) type-spec))) (t - ;; This is our sort-of old syntax. But this is only valid for - ;; when we are destructuring, so we will be compulsive (should - ;; we really be?) and require that we in fact be doing variable - ;; destructuring here. We must translate the old keyword - ;; pattern typespec into a fully-specified pattern of real type + ;; This is our sort-of old syntax. But this is only + ;; valid for when we are destructuring, so we will be + ;; compulsive (should we really be?) and require that + ;; we in fact be doing variable destructuring here. We + ;; must translate the old keyword pattern typespec + ;; into a fully-specified pattern of real type ;; specifiers here. (if (consp variable) (unless (consp z) @@ -1377,11 +1380,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; various FOR/AS subdispatches -;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when the THEN -;;; is omitted (other than being more stringent in its placement), and like the -;;; old "FOR x FIRST y THEN z" when the THEN is present. I.e., the first -;;; initialization occurs in the loop body (first-step), not in the variable -;;; binding phase. +;;; ANSI "FOR x = y [THEN z]" is sort of like the old Genera one when +;;; the THEN is omitted (other than being more stringent in its +;;; placement), and like the old "FOR x FIRST y THEN z" when the THEN +;;; is present. I.e., the first initialization occurs in the loop body +;;; (first-step), not in the variable binding phase. (defun loop-ansi-for-equals (var val data-type) (loop-make-iteration-variable var nil data-type) (cond ((loop-tequal (car *loop-source-code*) :then) @@ -1427,9 +1430,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ;;;; list iteration (defun loop-list-step (listvar) - ;; We are not equipped to analyze whether 'FOO is the same as #'FOO here in - ;; any sensible fashion, so let's give an obnoxious warning whenever 'FOO is - ;; used as the stepping function. + ;; We are not equipped to analyze whether 'FOO is the same as #'FOO + ;; here in any sensible fashion, so let's give an obnoxious warning + ;; whenever 'FOO is used as the stepping function. ;; ;; While a Discerning Compiler may deal intelligently with ;; (FUNCALL 'FOO ...), not recognizing FOO may defeat some LOOP @@ -1565,8 +1568,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (apply fun var data-type preps user-data)))) (when *loop-named-variables* (loop-error "Unused USING variables: ~S." *loop-named-variables*)) - ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). Protect the - ;; system from the user and the user from himself. + ;; STUFF is now (bindings prologue-forms . stuff-to-pass-back). + ;; Protect the system from the user and the user from himself. (unless (member (length stuff) '(6 10)) (loop-error "Value passed back by LOOP iteration path function for path ~S has invalid length." path)) @@ -1796,7 +1799,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (dummy-predicate-var nil) (post-steps nil)) (multiple-value-bind (other-var other-p) - (named-variable (if (eq which 'hash-key) 'hash-value 'hash-key)) + (named-variable (ecase which + (:hash-key 'hash-value) + (:hash-value 'hash-key))) ;; @@@@ NAMED-VARIABLE returns a second value of T if the name ;; was actually specified, so clever code can throw away the ;; GENSYM'ed-up variable if it isn't really needed. The @@ -1809,9 +1814,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (bindings `((,variable nil ,data-type) (,ht-var ,(cadar prep-phrases)) ,@(and other-p other-var `((,other-var nil)))))) - (if (eq which 'hash-key) - (setq key-var variable val-var (and other-p other-var)) - (setq key-var (and other-p other-var) val-var variable)) + (ecase which + (:hash-key (setq key-var variable + val-var (and other-p other-var))) + (:hash-value (setq key-var (and other-p other-var) + val-var variable))) (push `(with-hash-table-iterator (,next-fn ,ht-var)) *loop-wrappers*) (when (consp key-var) (setq post-steps diff --git a/src/code/primordial-extensions.lisp b/src/code/primordial-extensions.lisp index 09ec0ca..304c771 100644 --- a/src/code/primordial-extensions.lisp +++ b/src/code/primordial-extensions.lisp @@ -246,7 +246,11 @@ ,@(when doc (list doc)))) (defun %defconstant-eqx-value (symbol expr eqx) (flet ((bummer (explanation) - (error "~@" symbol explanation))) + (error "~@" + symbol + expr + explanation + (symbol-value symbol)))) (cond ((not (boundp symbol)) expr) ((not (constantp symbol)) diff --git a/src/code/print.lisp b/src/code/print.lisp index e2e67d8..cb53bcc 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -1582,7 +1582,7 @@ (case type (#.sb!vm:value-cell-header-type (write-string "value cell " stream) - (output-object (sb!c:value-cell-ref object) stream)) + (output-object (value-cell-ref object) stream)) (t (write-string "unknown pointer object, type=" stream) (let ((*print-base* 16) (*print-radix* t)) diff --git a/src/code/profile.lisp b/src/code/profile.lisp index 02fc54a..500ac97 100644 --- a/src/code/profile.lisp +++ b/src/code/profile.lisp @@ -145,7 +145,7 @@ (declare (type (or pcounter fixnum) count ticks consing profiles)) (values ;; ENCAPSULATION-FUN - (lambda (sb-c:&more arg-context arg-count) + (lambda (&more arg-context arg-count) (declare (optimize speed safety)) ;; Make sure that we're not recursing infinitely. (when (boundp '*computing-profiling-data-for*) diff --git a/src/code/setf-funs.lisp b/src/code/setf-funs.lisp index f26996b..cdeba89 100644 --- a/src/code/setf-funs.lisp +++ b/src/code/setf-funs.lisp @@ -21,7 +21,7 @@ (values-specifier-type (third type))))) (arglist (make-gensym-list (1+ (length args))))) (cond - ((null (intersection args lambda-list-keywords)) + ((null (intersection args sb!xc:lambda-list-keywords)) `(defun (setf ,name) ,arglist (declare ,@(mapcar #'(lambda (arg type) `(type ,type ,arg)) diff --git a/src/cold/defun-load-or-cload-xcompiler.lisp b/src/cold/defun-load-or-cload-xcompiler.lisp index d195581..3445a06 100644 --- a/src/cold/defun-load-or-cload-xcompiler.lisp +++ b/src/cold/defun-load-or-cload-xcompiler.lisp @@ -105,7 +105,6 @@ "FBOUNDP" "FDEFINITION" "FMAKUNBOUND" "FIND-CLASS" "GET-SETF-EXPANSION" - "LAMBDA-LIST-KEYWORDS" "LISP-IMPLEMENTATION-TYPE" "LISP-IMPLEMENTATION-VERSION" "MACRO-FUNCTION" "MACROEXPAND" "MACROEXPAND-1" "*MACROEXPAND-HOOK*" diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 83c2157..22e90b8 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -1404,7 +1404,7 @@ p ;; the branch has two dependents and one of them dpends on (when lambda-list (let ((param (car lambda-list))) (cond - ((member param lambda-list-keywords) + ((member param sb!xc:lambda-list-keywords) (new-lambda-list param) (grovel param (cdr lambda-list))) (t diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index 430918b..a98ec19 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -30,11 +30,18 @@ "The exclusive upper bound on the number of multiple VALUES that you can return.") -;;; FIXME: Shouldn't SB!C::&MORE be in this list? (defconstant-eqx sb!xc:lambda-list-keywords - '(&optional &rest &key &aux &body &whole &allow-other-keys &environment) - #!+sb-doc + '(&allow-other-keys + &aux + &body + &environment + &key + &more + &optional + &rest + &whole) #'equal + #!+sb-doc "symbols which are magical in a lambda list") ;;;; cross-compiler-only versions of CL special variables, so that we diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 18220b1..da56197 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -25,12 +25,13 @@ (let ((cup (lexenv-cleanup lexenv))) (when cup (return cup))))) -;;; Convert the Form in a block inserted between Block1 and Block2 as an -;;; implicit MV-Prog1. The inserted block is returned. Node is used for IR1 -;;; context when converting the form. Note that the block is not assigned a -;;; number, and is linked into the DFO at the beginning. We indicate that we -;;; have trashed the DFO by setting Component-Reanalyze. If Cleanup is -;;; supplied, then convert with that cleanup. +;;; Convert the FORM in a block inserted between BLOCK1 and BLOCK2 as +;;; an implicit MV-PROG1. The inserted block is returned. NODE is used +;;; for IR1 context when converting the form. Note that the block is +;;; not assigned a number, and is linked into the DFO at the +;;; beginning. We indicate that we have trashed the DFO by setting +;;; COMPONENT-REANALYZE. If CLEANUP is supplied, then convert with +;;; that cleanup. (defun insert-cleanup-code (block1 block2 node form &optional cleanup) (declare (type cblock block1 block2) (type node node) (type (or cleanup null) cleanup)) @@ -60,9 +61,9 @@ (:unused nil) (:deleted nil))) -;;; Update continuation use information so that Node is no longer a -;;; use of its Cont. If the old continuation doesn't start its block, -;;; then we don't update the Block-Start-Uses, since it will be +;;; Update continuation use information so that NODE is no longer a +;;; use of its CONT. If the old continuation doesn't start its block, +;;; then we don't update the BLOCK-START-USES, since it will be ;;; deleted when we are done. ;;; ;;; Note: if you call this function, you may have to do a @@ -87,8 +88,8 @@ (setf (node-cont node) nil)) (values)) -;;; Update continuation use information so that Node uses Cont. If -;;; Cont is :Unused, then we set its block to Node's Node-Block (which +;;; Update continuation use information so that NODE uses CONT. If +;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which ;;; must be set.) ;;; ;;; Note: if you call this function, you may have to do a @@ -115,8 +116,8 @@ (setf (node-cont node) cont) (values)) -;;; Return true if Cont is the Node-Cont for Node and Cont is transferred to -;;; immediately after the evaluation of Node. +;;; Return true if CONT is the NODE-CONT for NODE and CONT is +;;; transferred to immediately after the evaluation of NODE. (defun immediately-used-p (cont node) (declare (type continuation cont) (type node node)) (and (eq (node-cont node) cont) @@ -130,9 +131,9 @@ ;;;; continuation substitution -;;; In Old's Dest, replace Old with New. New's Dest must initially be NIL. -;;; When we are done, we call Flush-Dest on Old to clear its Dest and to note -;;; potential optimization opportunities. +;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be +;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST +;;; and to note potential optimization opportunities. (defun substitute-continuation (new old) (declare (type continuation old new)) (aver (not (continuation-dest new))) @@ -1286,14 +1287,15 @@ print only the CAR.") (declaim (type unsigned-byte *enclosing-source-cutoff*)) -;;; We separate the determination of compiler error contexts from the actual -;;; signalling of those errors by objectifying the error context. This allows -;;; postponement of the determination of how (and if) to signal the error. +;;; We separate the determination of compiler error contexts from the +;;; actual signalling of those errors by objectifying the error +;;; context. This allows postponement of the determination of how (and +;;; if) to signal the error. ;;; -;;; We take care not to reference any of the IR1 so that pending potential -;;; error messages won't prevent the IR1 from being GC'd. To this end, we -;;; convert source forms to strings so that source forms that contain IR1 -;;; references (e.g. %DEFUN) don't hold onto the IR. +;;; We take care not to reference any of the IR1 so that pending +;;; potential error messages won't prevent the IR1 from being GC'd. To +;;; this end, we convert source forms to strings so that source forms +;;; that contain IR1 references (e.g. %DEFUN) don't hold onto the IR. (defstruct (compiler-error-context #-no-ansi-print-object (:print-object (lambda (x stream) @@ -1335,10 +1337,10 @@ ;;; no method is defined, then the first two subforms are returned. ;;; Note that this facility implicitly determines the string name ;;; associated with anonymous functions. -;;; So even though SBCL itself only uses this macro within this file, it's a -;;; reasonable thing to put in SB-EXT in case some dedicated user wants to do -;;; some heavy tweaking to make SBCL give more informative output about his -;;; code. +;;; So even though SBCL itself only uses this macro within this file, +;;; it's a reasonable thing to put in SB-EXT in case some dedicated +;;; user wants to do some heavy tweaking to make SBCL give more +;;; informative output about his code. (defmacro def-source-context (name lambda-list &body body) #!+sb-doc "DEF-SOURCE-CONTEXT Name Lambda-List Form* @@ -1375,17 +1377,19 @@ (t form))) -;;; Given a source path, return the original source form and a description -;;; of the interesting aspects of the context in which it appeared. The -;;; context is a list of lists, one sublist per context form. The sublist is a -;;; list of some of the initial subforms of the context form. +;;; Given a source path, return the original source form and a +;;; description of the interesting aspects of the context in which it +;;; appeared. The context is a list of lists, one sublist per context +;;; form. The sublist is a list of some of the initial subforms of the +;;; context form. ;;; -;;; For now, we use the first two subforms of each interesting form. A form is -;;; interesting if the first element is a symbol beginning with "DEF" and it is -;;; not the source form. If there is no DEF-mumble, then we use the outermost -;;; containing form. If the second subform is a list, then in some cases we -;;; return the car of that form rather than the whole form (i.e. don't show -;;; defstruct options, etc.) +;;; For now, we use the first two subforms of each interesting form. A +;;; form is interesting if the first element is a symbol beginning +;;; with "DEF" and it is not the source form. If there is no +;;; DEF-mumble, then we use the outermost containing form. If the +;;; second subform is a list, then in some cases we return the CAR of +;;; that form rather than the whole form (i.e. don't show DEFSTRUCT +;;; options, etc.) (defun find-original-source (path) (declare (list path)) (let* ((rpath (reverse (source-path-original-source path))) @@ -1622,11 +1626,12 @@ (values)) ;;; COMPILER-NOTE is vaguely like COMPILER-ERROR and the other -;;; condition-signalling functions, but it just writes some output instead of -;;; signalling. (In CMU CL, it did signal a condition, but this didn't seem to -;;; work all that well; it was weird to have COMPILE-FILE return with -;;; WARNINGS-P set when the only problem was that the compiler couldn't figure -;;; out how to compile something as efficiently as it liked.) +;;; condition-signalling functions, but it just writes some output +;;; instead of signalling. (In CMU CL, it did signal a condition, but +;;; this didn't seem to work all that well; it was weird to have +;;; COMPILE-FILE return with WARNINGS-P set when the only problem was +;;; that the compiler couldn't figure out how to compile something as +;;; efficiently as it liked.) (defun compiler-note (format-string &rest format-args) (unless (if *compiler-error-context* (policy *compiler-error-context* (= inhibit-warnings 3)) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 5383510..84a9aa8 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -969,8 +969,8 @@ (process-top-level-locally (rest form) path compile-time-too)) ((progn) (process-top-level-progn (rest form) path compile-time-too)) - #+sb-xc-host - ;; Consider: What should we do when we hit e.g. + ;; When we're cross-compiling, consider: what should we + ;; do when we hit e.g. ;; (EVAL-WHEN (:COMPILE-TOPLEVEL) ;; (DEFUN FOO (X) (+ 7 X)))? ;; DEFUN has a macro definition in the cross-compiler, @@ -982,19 +982,40 @@ ;; cross-compilation time. So make sure we do the EVAL ;; here, before we macroexpand. ;; + ;; Then things get even dicier with something like + ;; (DEFCONSTANT-EQX SB!XC:LAMBDA-LIST-KEYWORDS ..) + ;; where we have to make sure that we don't uncross + ;; the SB!XC: prefix before we do EVAL, because otherwise + ;; we'd be trying to redefine the cross-compilation host's + ;; constants. + ;; ;; (Isn't it fun to cross-compile Common Lisp?:-) + #+sb-xc-host (t (when compile-time-too (eval form)) ; letting xc host EVAL do its own macroexpansion - (let* ((uncrossed (uncross form)) - ;; letting our cross-compiler do its macroexpansion too - (expanded (preprocessor-macroexpand uncrossed))) - (if (eq expanded uncrossed) + (let* (;; (We uncross the operator name because things + ;; like SB!XC:DEFCONSTANT and SB!XC:DEFTYPE + ;; should be equivalent to their CL: counterparts + ;; when being compiled as target code. We leave + ;; the rest of the form uncrossed because macros + ;; might yet expand into EVAL-WHEN stuff, and + ;; things inside EVAL-WHEN can't be uncrossed + ;; until after we've EVALed them in the + ;; cross-compilation host.) + (slightly-uncrossed (cons (uncross (first form)) + (rest form))) + (expanded (preprocessor-macroexpand slightly-uncrossed))) + (if (eq expanded slightly-uncrossed) + ;; (Now that we're no longer processing toplevel + ;; forms, and hence no longer need to worry about + ;; EVAL-WHEN, we can uncross everything.) (convert-and-maybe-compile expanded path) - ;; Note that we also have to demote - ;; COMPILE-TIME-TOO to NIL, no matter what it was - ;; before, since otherwise we'd tend to EVAL - ;; subforms more than once. + ;; (We have to demote COMPILE-TIME-TOO to NIL + ;; here, no matter what it was before, since + ;; otherwise we'd tend to EVAL subforms more than + ;; once, because of WHEN COMPILE-TIME-TOO form + ;; above.) (process-top-level-form expanded path nil)))) ;; When we're not cross-compiling, we only need to ;; macroexpand once, so we can follow the 1-thru-6 diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index c21db65..0e2975b 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -1419,8 +1419,7 @@ (more-result (when more-results (car (last all-results)))) (conditional (vop-parse-conditional-p parse))) - `( - :type (specifier-type '(function () nil)) + `(:type (specifier-type '(function () nil)) :arg-types (list ,@(mapcar #'make-operand-type args)) :more-args-type ,(when more-args (make-operand-type more-arg)) :result-types ,(if conditional @@ -1435,14 +1434,14 @@ (defparameter *slot-inherit-alist* '((:generator-function . vop-info-generator-function)))) -;;; Something to help with inheriting VOP-Info slots. We return a -;;; keyword/value pair that can be passed to the constructor. SLOT is -;;; the keyword name of the slot, Parse is a form that evaluates to -;;; the VOP-Parse structure for the VOP inherited. If PARSE is NIL, -;;; then we do nothing. If the TEST form evaluates to true, then we -;;; return a form that selects the named slot from the VOP-Info -;;; structure corresponding to PARSE. Otherwise, we return the FORM so -;;; that the slot is recomputed. +;;; This is something to help with inheriting VOP-Info slots. We +;;; return a keyword/value pair that can be passed to the constructor. +;;; SLOT is the keyword name of the slot, Parse is a form that +;;; evaluates to the VOP-Parse structure for the VOP inherited. If +;;; PARSE is NIL, then we do nothing. If the TEST form evaluates to +;;; true, then we return a form that selects the named slot from the +;;; VOP-Info structure corresponding to PARSE. Otherwise, we return +;;; the FORM so that the slot is recomputed. (defmacro inherit-vop-info (slot parse test form) `(if (and ,parse ,test) (list ,slot `(,',(or (cdr (assoc slot *slot-inherit-alist*)) @@ -1486,10 +1485,11 @@ (make-generator-function parse))) :variant (list ,@variant)))) -;;; Define the symbol NAME to be a Virtual OPeration in the compiler. If -;;; specified, INHERITS is the name of a VOP that we default unspecified -;;; information from. Each SPEC is a list beginning with a keyword indicating -;;; the interpretation of the other forms in the SPEC: +;;; Define the symbol NAME to be a Virtual OPeration in the compiler. +;;; If specified, INHERITS is the name of a VOP that we default +;;; unspecified information from. Each SPEC is a list beginning with a +;;; keyword indicating the interpretation of the other forms in the +;;; SPEC: ;;; ;;; :Args {(Name {Key Value}*)}* ;;; :Results {(Name {Key Value}*)}* diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index 9628902..fdc1fd3 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -68,7 +68,7 @@ (unless (member state '(:required :optional)) (compiler-error "misplaced &REST in lambda list: ~S" list)) (setq state :rest)) - (sb!c:&more + (&more (unless (member state '(:required :optional)) (compiler-error "misplaced &MORE in lambda list: ~S" list)) (setq morep t diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp new file mode 100644 index 0000000..4aa64ab --- /dev/null +++ b/tests/loop.pure.lisp @@ -0,0 +1,24 @@ +;;;; miscellaneous tests of LOOP-related stuff + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +;;; The bug reported by Alexei Dejneka on sbcl-devel 2001-09-03 +;;; is fixed now. +(assert (equal (let ((hash (make-hash-table))) + (setf (gethash 'key1 hash) 'val1) + (setf (gethash 'key2 hash) 'val2) + (sort (loop for key being each hash-key in hash + collect key) + #'string<)) + '(key1 key2))) diff --git a/version.lisp-expr b/version.lisp-expr index dba0ec6..64e2199 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.32" +"0.pre7.33"