From: William Harold Newman Date: Sun, 31 Dec 2000 16:29:27 +0000 (+0000) Subject: 0.6.9.14: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git 0.6.9.14: renamed more PCL stuff for unintern after warm init CONSTANTLY now returns only a single value, as per ANSI. removed CONSTANT-FUNCTION declaration support PROCLAIM now recognizes ANSI abbreviated type declarations, sharing code with DECLARE to do so. DECLARE no longer supports old-style (CLTL1) FUNCTION decls. removed some PCL nonstandard decls renamed other nonstandard PCL decls to look more private removed (DECLARE (SB-PCL::CLASS ..)) hack in DECLARE logic --- diff --git a/BUGS b/BUGS index 39c0299..2add6a7 100644 --- a/BUGS +++ b/BUGS @@ -833,17 +833,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 72: (DECLAIM (OPTIMIZE ..)) doesn't work properly inside LOCALLY forms. -73: - PROCLAIM and DECLAIM don't recognize the ANSI abbreviated type - declaration syntax for user-defined types, although DECLARE does. - E.g. - (deftype foo () '(integer 3 19)) - (defvar *foo*) - (declaim (foo *foo*)) ; generates warning - (defun foo+ (x y) - (declare (foo x y)) ; works OK - (+ x y)) - 74: As noted in the ANSI specification for COERCE, (COERCE 3 'COMPLEX) gives a result which isn't COMPLEX. The result type optimizer diff --git a/NEWS b/NEWS index b4f3952..4130634 100644 --- a/NEWS +++ b/NEWS @@ -626,10 +626,13 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: * Fasl file format version numbers have increased again, because a rearrangement of internal implementation packages made some dumped symbols in old fasl files unreadable in new cores. -?? #'(SETF DOCUMENTATION) is now defined. +?? (DECLAIM (OPTIMIZE ..)) now works. +* DECLARE/DECLAIM/PROCLAIM logic is more nearly ANSI in general, with + many fewer weird special cases. * Bug #17 (differing COMPILE-FILE behavior between logical and physical pathnames) has been fixed, and some related misbehavior too, thanks to a patch from Martin Atzmueller. +?? #'(SETF DOCUMENTATION) is now defined. * More compiler warnings in src/runtime/ are gone, thanks to patches from Martin Atzmueller. * Martin Atzmueller pointed out that bug 37 was fixed by his patches diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index c41fe96..5595415 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -525,9 +525,8 @@ like *STACK-TOP-HINT*" ;; now? -- WHN 19991206 ;; extended declarations.. - "CONSTANT-FUNCTION" "END-BLOCK" "FREEZE-TYPE" - "INHIBIT-WARNINGS" - "MAYBE-INLINE" "OPTIMIZE-INTERFACE" "START-BLOCK" + "FREEZE-TYPE" "INHIBIT-WARNINGS" + "MAYBE-INLINE" "OPTIMIZE-INTERFACE" ;; ..and variables to control compiler policy "*INLINE-EXPANSION-LIMIT*" @@ -1089,7 +1088,7 @@ is a good idea, but see SB-SYS for blurring of boundaries." "TYPE-DIFFERENCE" "TYPE-EXPAND" "TYPE-INTERSECT" "TYPE-INTERSECTION" "TYPE-SPECIFIER" - "*STANDARD-TYPE-NAMES*" "TYPE-UNION" "TYPE/=" "TYPE=" + "TYPE-UNION" "TYPE/=" "TYPE=" "TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY" "UNDEFINED-SYMBOL-ERROR" "UNION-TYPE" "UNION-TYPE-P" "UNION-TYPE-TYPES" "UNKNOWN-ERROR" diff --git a/src/code/byte-interp.lisp b/src/code/byte-interp.lisp index 0aa9212..36177ae 100644 --- a/src/code/byte-interp.lisp +++ b/src/code/byte-interp.lisp @@ -1013,7 +1013,7 @@ ;;; Call a function with some arguments popped off of the interpreter ;;; stack, and restore the SP to the specifier value. (defun byte-apply (function num-args restore-sp) - (declare (function function) (type index num-args)) + (declare (type function function) (type index num-args)) (let ((start (- (current-stack-pointer) num-args))) (declare (type stack-pointer start)) (macrolet ((frob () diff --git a/src/code/class.lisp b/src/code/class.lisp index 909d869..c9f2271 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -638,7 +638,7 @@ ;;; always of the desired class. The second result is any existing ;;; LAYOUT for this name. (defun insured-find-class (name predicate constructor) - (declare (function predicate constructor)) + (declare (type function predicate constructor)) (let* ((old (sb!xc:find-class name nil)) (res (if (and old (funcall predicate old)) old diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 074ee18..b6dd324 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -189,8 +189,8 @@ (t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*"))))) (/show0 "done with loop over cold toplevel forms and fixups") - ;; Set sane values again, so that the user sees sane values instead of - ;; whatever is left over from the last DECLAIM/PROCLAIM. + ;; Set sane values again, so that the user sees sane values instead + ;; of whatever is left over from the last DECLAIM/PROCLAIM. (show-and-call !policy-cold-init-or-resanify) ;; Only do this after toplevel forms have run, 'cause that's where diff --git a/src/code/early-cl.lisp b/src/code/early-cl.lisp index 46c6c88..f8a1aa2 100644 --- a/src/code/early-cl.lisp +++ b/src/code/early-cl.lisp @@ -14,9 +14,8 @@ ;;; Common Lisp special variables which have SB-XC versions (proclaim '(special sb!xc:*macroexpand-hook*)) -;;; the Common Lisp defined type specifier symbols -(declaim (type list *standard-type-names*)) -(defparameter *standard-type-names* +;;; the Common Lisp defined type spec symbols +(defparameter *!standard-type-names* '(array atom bignum bit bit-vector character compiled-function complex cons double-float extended-char fixnum float function hash-table integer keyword list long-float nil null number package diff --git a/src/code/list.lisp b/src/code/list.lisp index c3812dc..35d5671 100644 --- a/src/code/list.lisp +++ b/src/code/list.lisp @@ -499,27 +499,16 @@ (arg0-p (funcall function arg0)) (t (funcall function)))))) -(defun constantly (value &optional (val1 nil val1-p) (val2 nil val2-p) - &rest more-values) - #!+sb-doc - "Builds a function that always returns VALUE, and possibly MORE-VALUES." - (cond (more-values - (let ((list (list* value val1 val2 more-values))) - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values-list list)))) - (val2-p - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values value val1 val2))) - (val1-p - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - (values value val1))) - (t - (lambda () - (declare (optimize-interface (speed 3) (safety 0))) - value)))) +(defun constantly (value) + #!+sb-doc + "Return a function that always returns VALUE." + (lambda () + ;; KLUDGE: This declaration is a hack to make the closure ignore + ;; all its arguments without consing a &REST list or anything. + ;; Perhaps once DYNAMIC-EXTENT is implemented we won't need to + ;; screw around with this kind of thing. + (declare (optimize-interface (speed 3) (safety 0))) + value)) ;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP)) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 5a2ea1c..421fc97 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -497,8 +497,8 @@ (ecase (fits-on-line-p stream (block-start-section-end next) force-newlines-p) ((t) - ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. + ;; Just nuke the whole logical block and make it look + ;; like one nice long literal. (let ((end (block-start-block-end next))) (expand-tabs stream end) (setf tail (cdr (member end tail))))) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index 166e38a..1494806 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -19,11 +19,6 @@ ;;; a test that the host Lisp object OBJECT translates to a target SBCL ;;; type TYPE. (This behavior is needed e.g. to test for the validity of ;;; numeric subtype bounds read when cross-compiling.) -;;; -;;; KLUDGE: In classic CMU CL this was wrapped in a (DECLAIM (START-BLOCK -;;; TYPEP %TYPEP CLASS-CELL-TYPEP)) to make calls efficient. Once I straighten -;;; out bootstrapping and cross-compiling issues it'd likely be a good idea to -;;; do this again. -- WHN 19990413 (defun typep (object type) #!+sb-doc "Return T iff OBJECT is of type TYPE." diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index 6567e42..56e44d9 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -144,8 +144,6 @@ (defmacro !define-type-method ((class method &rest more-methods) lambda-list &body body) - #!+sb-doc - "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*" (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD"))) `(progn (defun ,name ,lambda-list ,@body) diff --git a/src/code/type-init.lisp b/src/code/type-init.lisp index 8088a76..0c12825 100644 --- a/src/code/type-init.lisp +++ b/src/code/type-init.lisp @@ -43,7 +43,7 @@ ;;; built-in symbol type specifiers (/show0 "precomputing built-in symbol type specifiers") -(precompute-types *standard-type-names*) +(precompute-types *!standard-type-names*) ;;; FIXME: It should be possible to do this in the cross-compiler, ;;; but currently the cross-compiler's type system is too dain-bramaged to diff --git a/src/compiler/dump.lisp b/src/compiler/dump.lisp index 672c196..e88f9ba 100644 --- a/src/compiler/dump.lisp +++ b/src/compiler/dump.lisp @@ -26,9 +26,9 @@ (:print-object (lambda (x s) (print-unreadable-object (x s :type t) (prin1 (namestring (fasl-file-stream x)) s))))) - ;; The stream we dump to. + ;; the stream we dump to (stream (required-argument) :type stream) - ;; Hashtables we use to keep track of dumped constants so that we + ;; hashtables we use to keep track of dumped constants so that we ;; can get them from the table rather than dumping them again. The ;; EQUAL-TABLE is used for lists and strings, and the EQ-TABLE is ;; used for everything else. We use a separate EQ table to avoid @@ -37,7 +37,7 @@ ;; the EQ table. (equal-table (make-hash-table :test 'equal) :type hash-table) (eq-table (make-hash-table :test 'eq) :type hash-table) - ;; The table's current free pointer: the next offset to be used. + ;; the table's current free pointer: the next offset to be used (table-free 0 :type index) ;; an alist (PACKAGE . OFFSET) of the table offsets for each package ;; we have currently located. @@ -111,10 +111,10 @@ (dotimes (i 4) (write-byte (ldb (byte 8 (* 8 i)) num) stream)))) -;;; Dump NUM to the fasl stream, represented by N bytes. This works for either -;;; signed or unsigned integers. There's no range checking -- if you don't -;;; specify enough bytes for the number to fit, this function cheerfully -;;; outputs the low bytes. +;;; Dump NUM to the fasl stream, represented by N bytes. This works +;;; for either signed or unsigned integers. There's no range checking +;;; -- if you don't specify enough bytes for the number to fit, this +;;; function cheerfully outputs the low bytes. (defun dump-integer-as-n-bytes (num bytes file) (declare (integer num) (type index bytes) (type fasl-file file)) (do ((n num (ash n -8)) @@ -124,23 +124,22 @@ (dump-byte (logand n #xff) file)) (values)) -;;; Setting this variable to an (UNSIGNED-BYTE 32) value causes DUMP-FOP to use -;;; it as a counter and emit a FOP-NOP4 with the counter value before every -;;; ordinary fop. This can make it easier to follow the progress of FASLOAD -;;; when debugging/testing/experimenting. -#!+sb-show (defvar *fop-nop4-count* 0) +;;; Setting this variable to an (UNSIGNED-BYTE 32) value causes +;;; DUMP-FOP to use it as a counter and emit a FOP-NOP4 with the +;;; counter value before every ordinary fop. This can make it easier +;;; to follow the progress of FASLOAD when +;;; debugging/testing/experimenting. +#!+sb-show (defvar *fop-nop4-count* nil) #!+sb-show (declaim (type (or (unsigned-byte 32) null) *fop-nop4-count*)) -;;; FIXME: The default value here should become NIL once I get the system to -;;; run. ;;; Dump the FOP code for the named FOP to the specified fasl-file. ;;; -;;; FIXME: This should be a function, with a compiler macro expansion for the -;;; common constant-FS case. (Among other things, that'll stop it from -;;; EVALing ,FILE multiple times.) +;;; FIXME: This should be a function, with a compiler macro expansion +;;; for the common constant-FS case. (Among other things, that'll stop +;;; it from EVALing ,FILE multiple times.) ;;; -;;; FIXME: Compiler macros, frozen classes, inlining, and similar optimizations -;;; should be conditional on #!+SB-FROZEN. +;;; FIXME: Compiler macros, frozen classes, inlining, and similar +;;; optimizations should be conditional on #!+SB-FROZEN. (defmacro dump-fop (fs file) (let* ((fs (eval fs)) (val (get fs 'sb!impl::fop-code))) @@ -153,11 +152,11 @@ (dump-byte ',val ,file)) (error "compiler bug: ~S is not a legal fasload operator." fs)))) -;;; Dump a FOP-Code along with an integer argument, choosing the FOP based -;;; on whether the argument will fit in a single byte. +;;; Dump a FOP-Code along with an integer argument, choosing the FOP +;;; based on whether the argument will fit in a single byte. ;;; -;;; FIXME: This, like DUMP-FOP, should be a function with a compiler-macro -;;; expansion. +;;; FIXME: This, like DUMP-FOP, should be a function with a +;;; compiler-macro expansion. (defmacro dump-fop* (n byte-fop word-fop file) (once-only ((n-n n) (n-file file)) @@ -457,7 +456,8 @@ ;;;; LOAD-TIME-VALUE and MAKE-LOAD-FORM support -;;; Emit a funcall of the function and return the handle for the result. +;;; Emit a funcall of the function and return the handle for the +;;; result. (defun fasl-dump-load-time-value-lambda (fun file) (declare (type clambda fun) (type fasl-file file)) (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) @@ -467,8 +467,8 @@ (dump-byte 0 file)) (dump-pop file)) -;;; Return T iff CONSTANT has not already been dumped. It's been dumped -;;; if it's in the EQ table. +;;; Return T iff CONSTANT has not already been dumped. It's been +;;; dumped if it's in the EQ table. (defun fasl-constant-already-dumped (constant file) (if (or (gethash constant (fasl-file-eq-table file)) (gethash constant (fasl-file-valid-structures file))) @@ -484,8 +484,8 @@ (setf (gethash constant table) handle)) (values)) -;;; Note that the specified structure can just be dumped by enumerating the -;;; slots. +;;; Note that the specified structure can just be dumped by +;;; enumerating the slots. (defun fasl-validate-structure (structure file) (setf (gethash structure (fasl-file-valid-structures file)) t) (values)) @@ -569,12 +569,13 @@ ;;;; symbol dumping ;;; Return the table index of PKG, adding the package to the table if -;;; necessary. During cold load, we read the string as a normal string so that -;;; we can do the package lookup at cold load time. +;;; necessary. During cold load, we read the string as a normal string +;;; so that we can do the package lookup at cold load time. ;;; -;;; KLUDGE: Despite the parallelism in names, the functionality of this -;;; function is not parallel to other functions DUMP-FOO, e.g. DUMP-SYMBOL -;;; and DUMP-LIST. -- WHN 19990119 +;;; FIXME: Despite the parallelism in names, the functionality of +;;; this function is not parallel to other functions DUMP-FOO, e.g. +;;; DUMP-SYMBOL and DUMP-LIST. The mapping between names and behavior +;;; should be made more consistent. (defun dump-package (pkg file) (declare (type package pkg) (type fasl-file file) (values index) (inline assoc)) @@ -668,7 +669,8 @@ (dump-fop 'sb!impl::fop-list* file) (dump-byte 255 file))))) -;;; If N > 255, must build list with one list operator, then list* operators. +;;; If N > 255, must build list with one LIST operator, then LIST* +;;; operators. (defun terminate-undotted-list (n file) (declare (type index n) (type fasl-file file)) @@ -702,8 +704,9 @@ (dump-vector x file) (dump-multi-dim-array x file))) -;;; Dump the vector object. If it's not simple, then actually dump a simple -;;; version of it. But we enter the original in the EQ or EQUAL tables. +;;; Dump the vector object. If it's not simple, then actually dump a +;;; simple version of it. But we enter the original in the EQ or EQUAL +;;; tables. (defun dump-vector (x file) (let ((simple-version (if (array-header-p x) (coerce x 'simple-array) @@ -788,10 +791,11 @@ (t ; harder cases, not supported in cross-compiler (dump-raw-bytes vec bytes file)))) (dump-signed-vector (size bytes) - ;; Note: Dumping specialized signed vectors isn't supported in - ;; the cross-compiler. (All cases here end up trying to call - ;; DUMP-RAW-BYTES, which isn't provided in the cross-compilation - ;; host, only on the target machine.) + ;; Note: Dumping specialized signed vectors isn't + ;; supported in the cross-compiler. (All cases here end + ;; up trying to call DUMP-RAW-BYTES, which isn't + ;; provided in the cross-compilation host, only on the + ;; target machine.) (unless data-only (dump-fop 'sb!impl::fop-signed-int-vector file) (dump-unsigned-32 len file) @@ -914,11 +918,12 @@ (error "internal error, code-length=~D, nwritten=~D" code-length nwritten))) - ;; KLUDGE: It's not clear what this is trying to do, but it looks as though - ;; it's an implicit undocumented dependence on a 4-byte wordsize which could - ;; be painful in porting. Note also that there are other undocumented - ;; modulo-4 things scattered throughout the code and conditionalized - ;; with GENGC, and I don't know what those do either. -- WHN 19990323 + ;; KLUDGE: It's not clear what this is trying to do, but it looks as + ;; though it's an implicit undocumented dependence on a 4-byte + ;; wordsize which could be painful in porting. Note also that there + ;; are other undocumented modulo-4 things scattered throughout the + ;; code and conditionalized with GENGC, and I don't know what those + ;; do either. -- WHN 19990323 #!+gengc (unless (zerop (logand code-length 3)) (dotimes (i (- 4 (logand code-length 3))) (dump-byte 0 fasl-file))) @@ -932,19 +937,19 @@ (declare (list fixups) (type fasl-file fasl-file)) (dolist (info fixups) ;; FIXME: Packing data with LIST in NOTE-FIXUP and unpacking them - ;; with FIRST, SECOND, and THIRD here is hard to follow and maintain. - ;; Perhaps we could define a FIXUP-INFO structure to use instead, and - ;; rename *FIXUPS* to *FIXUP-INFO-LIST*? + ;; with FIRST, SECOND, and THIRD here is hard to follow and + ;; maintain. Perhaps we could define a FIXUP-INFO structure to use + ;; instead, and rename *FIXUPS* to *FIXUP-INFO-LIST*? (let* ((kind (first info)) (fixup (second info)) (name (fixup-name fixup)) (flavor (fixup-flavor fixup)) (offset (third info))) - ;; FIXME: This OFFSET is not what's called OFFSET in - ;; the FIXUP structure, it's what's called POSN in NOTE-FIXUP. - ;; (As far as I can tell, FIXUP-OFFSET is not actually an offset, - ;; it's an internal label used instead of NAME for :CODE-OBJECT - ;; fixups. Notice that in the :CODE-OBJECT case, NAME is ignored.) + ;; FIXME: This OFFSET is not what's called OFFSET in the FIXUP + ;; structure, it's what's called POSN in NOTE-FIXUP. (As far as + ;; I can tell, FIXUP-OFFSET is not actually an offset, it's an + ;; internal label used instead of NAME for :CODE-OBJECT fixups. + ;; Notice that in the :CODE-OBJECT case, NAME is ignored.) (dump-fop 'sb!impl::fop-normal-load fasl-file) (let ((*cold-load-dump* t)) (dump-object kind fasl-file)) @@ -977,12 +982,13 @@ ;;; Dump out the constant pool and code-vector for component, push the ;;; result in the table, and return the offset. ;;; -;;; The only tricky thing is handling constant-pool references to functions. -;;; If we have already dumped the function, then we just push the code pointer. -;;; Otherwise, we must create back-patching information so that the constant -;;; will be set when the function is eventually dumped. This is a bit awkward, -;;; since we don't have the handle for the code object being dumped while we -;;; are dumping its constants. +;;; The only tricky thing is handling constant-pool references to +;;; functions. If we have already dumped the function, then we just +;;; push the code pointer. Otherwise, we must create back-patching +;;; information so that the constant will be set when the function is +;;; eventually dumped. This is a bit awkward, since we don't have the +;;; handle for the code object being dumped while we are dumping its +;;; constants. ;;; ;;; We dump trap objects in any unused slots or forward referenced slots. (defun dump-code-object (component @@ -1017,9 +1023,12 @@ ;; Dump the offset of the trace table. (dump-object code-length fasl-file) - ;; KLUDGE: Now that we don't have GENGC, the trace table is hardwired - ;; to be empty. Could we get rid of trace tables? What are the - ;; virtues of GENGC vs. GENCGC vs. whatnot? + ;; FIXME: As long as we don't have GENGC, the trace table is + ;; hardwired to be empty. So we might be able to get rid of + ;; trace tables? However, we should probably wait for the first + ;; port to a system where CMU CL uses GENGC to see whether GENGC + ;; is really gone. (I.e. maybe other non-X86 ports will want to + ;; use it, just as in CMU CL.) ;; Dump the constants, noting any :entries that have to be fixed up. (do ((i sb!vm:code-constants-offset (1+ i))) @@ -1072,14 +1081,14 @@ (dump-unsigned-32 num-consts fasl-file) (dump-unsigned-32 total-length fasl-file)))) - ;; These two dumps are only ones which contribute to our TOTAL-LENGTH - ;; value. + ;; These two dumps are only ones which contribute to our + ;; TOTAL-LENGTH value. (dump-segment code-segment code-length fasl-file) (dump-i-vector packed-trace-table fasl-file :data-only t) - ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it dumps aren't - ;; included in the TOTAL-LENGTH passed to our FOP-CODE/FOP-SMALL-CODE - ;; fop. + ;; DUMP-FIXUPS does its own internal DUMP-FOPs: the bytes it + ;; dumps aren't included in the TOTAL-LENGTH passed to our + ;; FOP-CODE/FOP-SMALL-CODE fop. (dump-fixups fixups fasl-file) (dump-fop 'sb!impl::fop-sanctify-for-execution fasl-file) @@ -1106,12 +1115,13 @@ (dump-fop 'sb!impl::fop-sanctify-for-execution file) (dump-pop file)) -;;; Dump a function-entry data structure corresponding to Entry to File. -;;; Code-Handle is the table offset of the code object for the component. +;;; Dump a function-entry data structure corresponding to ENTRY to +;;; FILE. CODE-HANDLE is the table offset of the code object for the +;;; component. ;;; -;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the cold -;;; loader can instantiate the definition at cold-load time, allowing forward -;;; references to functions in top-level forms. +;;; If the entry is a DEFUN, then we also dump a FOP-FSET so that the +;;; cold loader can instantiate the definition at cold-load time, +;;; allowing forward references to functions in top-level forms. (defun dump-one-entry (entry code-handle file) (declare (type entry-info entry) (type index code-handle) (type fasl-file file)) @@ -1129,8 +1139,8 @@ (dump-fop 'sb!impl::fop-fset file)) handle))) -;;; Alter the code object referenced by Code-Handle at the specified Offset, -;;; storing the object referenced by Entry-Handle. +;;; Alter the code object referenced by CODE-HANDLE at the specified +;;; OFFSET, storing the object referenced by ENTRY-HANDLE. (defun dump-alter-code-object (code-handle offset entry-handle file) (declare (type index code-handle entry-handle offset) (type fasl-file file)) (dump-push code-handle file) @@ -1141,8 +1151,8 @@ file) (values)) -;;; Dump the code, constants, etc. for component. We pass in the assembler -;;; fixups, code vector and node info. +;;; Dump the code, constants, etc. for component. We pass in the +;;; assembler fixups, code vector and node info. (defun fasl-dump-component (component code-segment code-length @@ -1174,9 +1184,10 @@ (setf (gethash entry (fasl-file-entry-table file)) entry-handle) (let ((old (gethash entry (fasl-file-patch-table file)))) - ;; KLUDGE: All this code is shared with FASL-DUMP-BYTE-COMPONENT, - ;; and should probably be gathered up into a named function - ;; (DUMP-PATCHES?) called from both functions. + ;; FIXME: All this code is shared with + ;; FASL-DUMP-BYTE-COMPONENT, and should probably be gathered + ;; up into a named function (DUMP-PATCHES?) called from both + ;; functions. (when old (dolist (patch old) (dump-alter-code-object (car patch) @@ -1203,8 +1214,8 @@ (dump-push info-handle file) (push info-handle (fasl-file-debug-info file)))) - ;; The "trace table" is initialized by loader to hold a list of all byte - ;; functions in this code object (for debug info.) + ;; The "trace table" is initialized by loader to hold a list of + ;; all byte functions in this code object (for debug info.) (dump-object nil file) ;; Dump the constants. @@ -1270,8 +1281,8 @@ code-handle))) ;;; Dump a BYTE-FUNCTION object. We dump the layout and -;;; funcallable-instance info, but rely on the loader setting up the correct -;;; funcallable-instance-function. +;;; funcallable-instance info, but rely on the loader setting up the +;;; correct funcallable-instance-function. (defun dump-byte-function (xep code-handle file) (let ((nslots (- (get-closure-length xep) ;; 1- for header @@ -1313,7 +1324,8 @@ (remhash info patch-table)))))) (values)) -;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at load time. +;;; Dump a FOP-FUNCALL to call an already dumped top-level lambda at +;;; load time. (defun fasl-dump-top-level-lambda-call (fun file) (declare (type clambda fun) (type fasl-file file)) (let ((handle (gethash (leaf-info fun) (fasl-file-entry-table file)))) @@ -1323,9 +1335,10 @@ (dump-byte 0 file)) (values)) -;;; Compute the correct list of DEBUG-SOURCE structures and backpatch all of -;;; the dumped DEBUG-INFO structures. We clear the FASL-FILE-DEBUG-INFO, -;;; so that subsequent components with different source info may be dumped. +;;; Compute the correct list of DEBUG-SOURCE structures and backpatch +;;; all of the dumped DEBUG-INFO structures. We clear the +;;; FASL-FILE-DEBUG-INFO, so that subsequent components with different +;;; source info may be dumped. (defun fasl-dump-source-info (info file) (declare (type source-info info) (type fasl-file file)) (let ((res (debug-source-for-info info)) @@ -1344,8 +1357,6 @@ ;;;; dumping structures (defun dump-structure (struct file) - ;; FIXME: Probably *DUMP-ONLY-VALID-STRUCTURES* should become constantly T, - ;; right? (when *dump-only-valid-structures* (unless (gethash struct (fasl-file-valid-structures file)) (error "attempt to dump invalid structure:~% ~S~%How did this happen?" diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 4051d4d..23e2d88 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1225,8 +1225,7 @@ (defknown identity (t) t (movable foldable flushable unsafe) :derive-type #'result-type-first-arg) -;;; &OPTIONAL is to agree with the optimization in the interpreter stub. -(defknown constantly (t &optional t t &rest t) function (movable flushable)) +(defknown constantly (t) function (movable flushable)) (defknown complement (function) function (movable flushable)) ;;;; magical compiler frobs @@ -1283,8 +1282,7 @@ ;;; describing the actual function called. ;;; ;;; FIXME: It would be nice to make structure slot accessors be -;;; ordinary functions (proclaimed as SB-EXT:CONSTANT-FUNCTION, but -;;; otherwise ordinary). +;;; ordinary functions. (defknown %slot-accessor (t) t (flushable)) (defknown %slot-setter (t t) t (unsafe)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 508e896..7427325 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -800,7 +800,7 @@ ;;; If a lambda-var being bound, we intersect the type with the vars ;;; type, otherwise we add a type-restriction on the var. If a symbol ;;; macro, we just wrap a THE around the expansion. -(defun process-type-declaration (decl res vars) +(defun process-type-decl (decl res vars) (declare (list decl vars) (type lexenv res)) (let ((type (specifier-type (first decl)))) (collect ((restr nil cons) @@ -843,12 +843,12 @@ :variables (new-vars)) res)))) -;;; Somewhat similar to Process-Type-Declaration, but handles +;;; This is somewhat similar to PROCESS-TYPE-DECL, but handles ;;; declarations for function variables. In addition to allowing ;;; declarations for functions being bound, we must also deal with ;;; declarations that constrain the type of lexically apparent ;;; functions. -(defun process-ftype-declaration (spec res names fvars) +(defun process-ftype-decl (spec res names fvars) (declare (list spec names fvars) (type lexenv res)) (let ((type (specifier-type spec))) (collect ((res nil cons)) @@ -871,7 +871,7 @@ ;;; Process a special declaration, returning a new LEXENV. A non-bound ;;; special declaration is instantiated by throwing a special variable ;;; into the variables. -(defun process-special-declaration (spec res vars) +(defun process-special-decl (spec res vars) (declare (list spec vars) (type lexenv res)) (collect ((new-venv nil cons)) (dolist (name (cdr spec)) @@ -915,7 +915,7 @@ ;;; Parse an inline/notinline declaration. If it's a local function we're ;;; defining, set its INLINEP. If a global function, add a new FENV entry. -(defun process-inline-declaration (spec res fvars) +(defun process-inline-decl (spec res fvars) (let ((sense (cdr (assoc (first spec) *inlinep-translations* :test #'eq))) (new-fenv ())) (dolist (name (rest spec)) @@ -952,7 +952,7 @@ ;;; Process an ignore/ignorable declaration, checking for various losing ;;; conditions. -(defun process-ignore-declaration (spec vars fvars) +(defun process-ignore-decl (spec vars fvars) (declare (list spec vars fvars)) (dolist (name (rest spec)) (let ((var (find-in-bindings-or-fbindings name vars fvars))) @@ -985,71 +985,52 @@ #!+sb-doc "If true, processing of the VALUES declaration is inhibited.") -;;; Process a single declaration spec, agumenting the specified LEXENV -;;; Res and returning it as a result. Vars and Fvars are as described in +;;; Process a single declaration spec, augmenting the specified LEXENV +;;; RES and returning it as a result. VARS and FVARS are as described in ;;; PROCESS-DECLS. -(defun process-1-declaration (spec res vars fvars cont) +(defun process-1-decl (raw-spec res vars fvars cont) (declare (list spec vars fvars) (type lexenv res) (type continuation cont)) - (case (first spec) - (special (process-special-declaration spec res vars)) - (ftype - (unless (cdr spec) - (compiler-error "No type specified in FTYPE declaration: ~S" spec)) - (process-ftype-declaration (second spec) res (cddr spec) fvars)) - (function - ;; Handle old style FUNCTION declaration, which is an abbreviation for - ;; FTYPE. Args are name, arglist, result type. - (cond ((and (proper-list-of-length-p spec 3 4) - (listp (third spec))) - (process-ftype-declaration `(function ,@(cddr spec)) res - (list (second spec)) - fvars)) - (t - (process-type-declaration spec res vars)))) - ((inline notinline maybe-inline) - (process-inline-declaration spec res fvars)) - ((ignore ignorable) - (process-ignore-declaration spec vars fvars) - res) - (optimize - (make-lexenv - :default res - :policy (process-optimize-declaration spec (lexenv-policy res)))) - (optimize-interface - (make-lexenv - :default res - :interface-policy (process-optimize-declaration - spec - (lexenv-interface-policy res)))) - (type - (process-type-declaration (cdr spec) res vars)) - (values - (if *suppress-values-declaration* - res - (let ((types (cdr spec))) - (do-the-stuff (if (eql (length types) 1) - (car types) - `(values ,@types)) - cont res 'values)))) - (dynamic-extent - (when (policy nil (> speed inhibit-warnings)) - (compiler-note - "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) - res) - (t - (let ((what (first spec))) - (cond ((member what *standard-type-names*) - (process-type-declaration spec res vars)) - ((and (not (and (symbolp what) - (string= (symbol-name what) "CLASS"))) ; pcl hack - (or (info :type :kind what) - (and (consp what) (info :type :translator (car what))))) - (process-type-declaration spec res vars)) - ((info :declaration :recognized what) - res) - (t - (compiler-warning "unrecognized declaration ~S" spec) - res)))))) + (let ((spec (canonized-decl-spec raw-spec))) + (case (first spec) + (special (process-special-decl spec res vars)) + (ftype + (unless (cdr spec) + (compiler-error "No type specified in FTYPE declaration: ~S" spec)) + (process-ftype-decl (second spec) res (cddr spec) fvars)) + ((inline notinline maybe-inline) + (process-inline-decl spec res fvars)) + ((ignore ignorable) + (process-ignore-decl spec vars fvars) + res) + (optimize + (make-lexenv + :default res + :policy (process-optimize-decl spec (lexenv-policy res)))) + (optimize-interface + (make-lexenv + :default res + :interface-policy (process-optimize-decl + spec + (lexenv-interface-policy res)))) + (type + (process-type-decl (cdr spec) res vars)) + (values + (if *suppress-values-declaration* + res + (let ((types (cdr spec))) + (do-the-stuff (if (eql (length types) 1) + (car types) + `(values ,@types)) + cont res 'values)))) + (dynamic-extent + (when (policy nil (> speed inhibit-warnings)) + (compiler-note + "The DYNAMIC-EXTENT declaration is not implemented (ignored).")) + res) + (t + (unless (info :declaration :recognized (first spec)) + (compiler-warning "unrecognized declaration ~S" raw-spec)) + res)))) ;;; Use a list of DECLARE forms to annotate the lists of LAMBDA-VAR ;;; and FUNCTIONAL structures which are being bound. In addition to @@ -1068,10 +1049,10 @@ (compiler-error "malformed declaration specifier ~S in ~S" spec decl)) - (setq env (process-1-declaration spec env vars fvars cont)))) + (setq env (process-1-decl spec env vars fvars cont)))) env) -;;; Return the Specvar for Name to use when we see a local SPECIAL +;;; Return the SPECVAR for NAME to use when we see a local SPECIAL ;;; declaration. If there is a global variable of that name, then ;;; check that it isn't a constant and return it. Otherwise, create an ;;; anonymous GLOBAL-VAR. diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index 8545d00..792c37c 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -69,8 +69,8 @@ ;;; Return a new POLICY containing the policy information represented ;;; by the optimize declaration SPEC. Any parameters not specified are ;;; defaulted from the POLICY argument. -(declaim (ftype (function (list policy) policy) process-optimize-declaration)) -(defun process-optimize-declaration (spec policy) +(declaim (ftype (function (list policy) policy) process-optimize-decl)) +(defun process-optimize-decl (spec policy) (let ((result policy)) ; may have new entries pushed on it below (dolist (q-and-v-or-just-q (cdr spec)) (multiple-value-bind (quality raw-value) @@ -90,11 +90,29 @@ result))))) result)) -(defun sb!xc:proclaim (form) - (unless (consp form) - (error "malformed PROCLAIM spec: ~S" form)) - (let ((kind (first form)) - (args (rest form))) +;;; ANSI defines the declaration (FOO X Y) to be equivalent to +;;; (TYPE FOO X Y) when FOO is a type specifier. This function +;;; implements that by converting (FOO X Y) to (TYPE FOO X Y). +(defun canonized-decl-spec (decl-spec) + (let ((id (first decl-spec))) + (unless (symbolp id) + (error "The declaration identifier is not a symbol: ~S" what)) + (let ((id-is-type (info :type :kind id)) + (id-is-declared-decl (info :declaration :recognized id))) + (cond ((and id-is-type id-is-declared-decl) + (compiler-error + "ambiguous declaration ~S:~% ~ + ~S was declared as a DECLARATION, but is also a type name." + decl-spec id)) + (id-is-type + (cons 'type decl-spec)) + (t + decl-spec))))) + +(defun sb!xc:proclaim (raw-form) + (let* ((form (canonized-decl-spec raw-form)) + (kind (first form)) + (args (rest form))) (case kind (special (dolist (name args) @@ -193,11 +211,10 @@ (declare (ignore layout)) (setf (class-state subclass) :sealed)))))))) (optimize - (setq *default-policy* - (process-optimize-declaration form *default-policy*))) + (setq *default-policy* (process-optimize-decl form *default-policy*))) (optimize-interface (setq *default-interface-policy* - (process-optimize-declaration form *default-interface-policy*))) + (process-optimize-decl form *default-interface-policy*))) ((inline notinline maybe-inline) (dolist (name args) (proclaim-as-function-name name) @@ -206,21 +223,14 @@ (inline :inline) (notinline :notinline) (maybe-inline :maybe-inline))))) - (constant-function - (let ((info (make-function-info - :attributes (ir1-attributes movable foldable flushable - unsafe)))) - (dolist (name args) - (proclaim-as-function-name name) - (setf (info :function :info name) info)))) (declaration (dolist (decl args) (unless (symbolp decl) - (error "The declaration to be recognized is not a symbol: ~S" decl)) + (error "In~% ~S~%the declaration to be recognized is not a ~ + symbol:~% ~S" + form decl)) (setf (info :declaration :recognized decl) t))) (t - (cond ((member kind *standard-type-names*) - (sb!xc:proclaim `(type ,@form))) ; FIXME: ,@ instead of . , - ((not (info :declaration :recognized kind)) - (warn "unrecognized proclamation: ~S" form)))))) + (unless (info :declaration :recognized kind) + (compiler-warning "unrecognized declaration ~S" raw-form))))) (values)) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 148e700..121e1ee 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -18,11 +18,10 @@ (def-source-transform not (x) `(if ,x nil t)) (def-source-transform null (x) `(if ,x nil t)) -;;; ENDP is just NULL with a LIST assertion. +;;; ENDP is just NULL with a LIST assertion. The assertion will be +;;; optimized away when SAFETY optimization is low; hopefully that +;;; is consistent with ANSI's "should return an error". (def-source-transform endp (x) `(null (the list ,x))) -;;; FIXME: Is THE LIST a strong enough assertion for ANSI's "should -;;; return an error"? (THE LIST is optimized away when safety is low; -;;; does that satisfy the spec?) ;;; We turn IDENTITY into PROG1 so that it is obvious that it just ;;; returns the first value of its argument. Ditto for VALUES with one @@ -31,15 +30,11 @@ (def-source-transform values (x) `(prog1 ,x)) ;;; Bind the values and make a closure that returns them. -(def-source-transform constantly (value &rest values) - (let ((temps (make-gensym-list (1+ (length values)))) - (dum (gensym))) - `(let ,(loop for temp in temps and - value in (list* value values) - collect `(,temp ,value)) - #'(lambda (&rest ,dum) - (declare (ignore ,dum)) - (values ,@temps))))) +(def-source-transform constantly (value) + (let ((rest (gensym "CONSTANTLY-REST-"))) + `(lambda (&rest ,rest) + (declare (ignore ,rest)) + ,value))) ;;; If the function has a known number of arguments, then return a ;;; lambda with the appropriate fixed number of args. If the diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 2ddea34..a8b28ee 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -101,18 +101,18 @@ bootstrapping. real-add-named-method) )) -;;; For each of the early functions, arrange to have it point to its early -;;; definition. Do this in a way that makes sure that if we redefine one -;;; of the early definitions the redefinition will take effect. This makes -;;; development easier. +;;; For each of the early functions, arrange to have it point to its +;;; early definition. Do this in a way that makes sure that if we +;;; redefine one of the early definitions the redefinition will take +;;; effect. This makes development easier. ;;; -;;; The function which generates the redirection closure is pulled out into -;;; a separate piece of code because of a bug in ExCL which causes this not -;;; to work if it is inlined. +;;; The function which generates the redirection closure is pulled out +;;; into a separate piece of code because of a bug in ExCL which +;;; causes this not to work if it is inlined. ;;; FIXME: We no longer need to worry about ExCL now, so we could unscrew this. (eval-when (:load-toplevel :execute) -(defun redirect-early-function-internal (real early) +(defun !redirect-early-function-internal (real early) (setf (gdefinition real) (set-function-name #'(lambda (&rest args) @@ -122,7 +122,7 @@ bootstrapping. (dolist (fns *!early-functions*) (let ((name (car fns)) (early-name (cadr fns))) - (redirect-early-function-internal name early-name))) + (!redirect-early-function-internal name early-name))) ) ; EVAL-WHEN @@ -251,10 +251,6 @@ bootstrapping. initargs)) (defmacro defmethod (&rest args &environment env) - (declare (arglist name - {method-qualifier}* - specialized-lambda-list - &body body)) (multiple-value-bind (name qualifiers lambda-list body) (parse-defmethod args) (multiple-value-bind (proto-gf proto-method) @@ -472,8 +468,8 @@ bootstrapping. (extract-declarations body env) (values `(lambda ,unspecialized-lambda-list ,@(when documentation `(,documentation)) - (declare (method-name ,(list name qualifiers specializers))) - (declare (method-lambda-list ,@lambda-list)) + (declare (%method-name ,(list name qualifiers specializers))) + (declare (%method-lambda-list ,@lambda-list)) ,@declarations ,@real-body) unspecialized-lambda-list specializers)))) @@ -502,8 +498,8 @@ bootstrapping. method-lambda)) (multiple-value-bind (documentation declarations real-body) (extract-declarations (cddr method-lambda) env) - (let* ((name-decl (get-declaration 'method-name declarations)) - (sll-decl (get-declaration 'method-lambda-list declarations)) + (let* ((name-decl (get-declaration '%method-name declarations)) + (sll-decl (get-declaration '%method-lambda-list declarations)) (method-name (when (consp name-decl) (car name-decl))) (generic-function-name (when method-name (car method-name))) (specialized-lambda-list (or sll-decl (cadr method-lambda)))) @@ -517,13 +513,15 @@ bootstrapping. (calls (list nil)) (class-declarations `(declare - ;; FIXME: These nonstandard (DECLARE (SB-PCL::CLASS FOO BAR)) - ;; declarations should go away but as of 0.6.9.10, it's not - ;; as simple as just deleting them. + ;; These declarations seem to be used by PCL to pass + ;; information to itself; when I tried to delete 'em + ;; ca. 0.6.10 it didn't work. I'm not sure how + ;; they work, but note the (VARIABLE-DECLARATION '%CLASS ..) + ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 ,@(remove nil (mapcar (lambda (a s) (and (symbolp s) (neq s 't) - `(class ,a ,s))) + `(%class ,a ,s))) parameters specializers)) ;; These TYPE declarations weren't in the original @@ -1619,7 +1617,7 @@ bootstrapping. (unless was-valid-p (let ((name (if (eq *boot-state* 'complete) (generic-function-name gf) - (early-gf-name gf)))) + (!early-gf-name gf)))) (esetf (gf-precompute-dfun-and-emf-p arg-info) (let* ((sym (if (atom name) name (cadr name))) (pkg-list (cons *pcl-package* @@ -1727,7 +1725,7 @@ bootstrapping. (defvar *sgf-name-index* (!bootstrap-slot-index 'standard-generic-function 'name)) -(defun early-gf-name (gf) +(defun !early-gf-name (gf) (instance-ref (get-slots gf) *sgf-name-index*)) (defun gf-lambda-list (gf) @@ -1883,18 +1881,20 @@ bootstrapping. (defun early-method-standard-accessor-slot-name (early-method) (seventh (fifth early-method))) -;;; Fetch the specializers of an early method. This is basically just a -;;; simple accessor except that when the second argument is t, this converts -;;; the specializers from symbols into class objects. The class objects -;;; are cached in the early method, this makes bootstrapping faster because -;;; the class objects only have to be computed once. +;;; Fetch the specializers of an early method. This is basically just +;;; a simple accessor except that when the second argument is t, this +;;; converts the specializers from symbols into class objects. The +;;; class objects are cached in the early method, this makes +;;; bootstrapping faster because the class objects only have to be +;;; computed once. +;;; ;;; NOTE: -;;; the second argument should only be passed as T by early-lookup-method. -;;; this is to implement the rule that only when there is more than one -;;; early method on a generic function is the conversion from class names -;;; to class objects done. -;;; the corresponds to the fact that we are only allowed to have one method -;;; on any generic function up until the time classes exist. +;;; The second argument should only be passed as T by +;;; early-lookup-method. This is to implement the rule that only when +;;; there is more than one early method on a generic function is the +;;; conversion from class names to class objects done. This +;;; corresponds to the fact that we are only allowed to have one +;;; method on any generic function up until the time classes exist. (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) (eq (car early-method) :early-method)) @@ -1933,8 +1933,8 @@ bootstrapping. (add-method gf new))) ;;; This is the early version of ADD-METHOD. Later this will become a -;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has special -;;; knowledge about ADD-METHOD. +;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has +;;; special knowledge about ADD-METHOD. (defun add-method (generic-function method) (when (not (fsc-instance-p generic-function)) (error "Early ADD-METHOD didn't get a funcallable instance.")) @@ -1942,7 +1942,8 @@ bootstrapping. (error "Early ADD-METHOD didn't get an early method.")) (push method (early-gf-methods generic-function)) (set-arg-info generic-function :new-method method) - (unless (assoc (early-gf-name generic-function) *!generic-function-fixups* + (unless (assoc (!early-gf-name generic-function) + *!generic-function-fixups* :test #'equal) (update-dfun generic-function))) @@ -1956,7 +1957,8 @@ bootstrapping. (setf (early-gf-methods generic-function) (remove method (early-gf-methods generic-function))) (set-arg-info generic-function) - (unless (assoc (early-gf-name generic-function) *!generic-function-fixups* + (unless (assoc (!early-gf-name generic-function) + *!generic-function-fixups* :test #'equal) (update-dfun generic-function))) @@ -2063,9 +2065,9 @@ bootstrapping. (set-methods gf methods)))) (sb-int:/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS")) -;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument into -;;; the 'real' arguments. This is where the syntax of DEFMETHOD is really -;;; implemented. +;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument +;;; into the 'real' arguments. This is where the syntax of DEFMETHOD +;;; is really implemented. (defun parse-defmethod (cdr-of-form) ;;(declare (values name qualifiers specialized-lambda-list body)) (let ((name (pop cdr-of-form)) @@ -2107,7 +2109,6 @@ bootstrapping. (unparse-specializers (method-specializers specializers-or-method)))) (defun parse-method-or-spec (spec &optional (errorp t)) - ;;(declare (values generic-function method method-name)) (let (gf method name temp) (if (method-p spec) (setq method spec @@ -2181,10 +2182,11 @@ bootstrapping. and not allowing any parameter specializers to follow~%~ to follow it." arg)) - ;; When we are at a lambda-list keyword, the parameters don't - ;; include the lambda-list keyword; the lambda-list does include - ;; the lambda-list keyword; and no specializers are allowed to - ;; follow the lambda-list keywords (at least for now). + ;; When we are at a lambda-list keyword, the parameters + ;; don't include the lambda-list keyword; the lambda-list + ;; does include the lambda-list keyword; and no + ;; specializers are allowed to follow the lambda-list + ;; keywords (at least for now). (multiple-value-bind (parameters lambda-list) (parse-specialized-lambda-list (cdr arglist) t) (values parameters @@ -2210,10 +2212,10 @@ bootstrapping. (eval-when (:load-toplevel :execute) (setq *boot-state* 'early)) -;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET which used -;;; %WALKER stuff. That suggests to me that maybe the code walker stuff was -;;; only used for implementing stuff like that; maybe it's not needed any more? -;;; Hunt down what it was used for and see. +;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET +;;; which used %WALKER stuff. That suggests to me that maybe the code +;;; walker stuff was only used for implementing stuff like that; maybe +;;; it's not needed any more? Hunt down what it was used for and see. (defmacro with-slots (slots instance &body body) (let ((in (gensym))) @@ -2223,7 +2225,7 @@ bootstrapping. (third instance) instance))) (and (symbolp instance) - `((declare (variable-rebinding ,in ,instance))))) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) (let ((variable-name @@ -2247,7 +2249,7 @@ bootstrapping. (third instance) instance))) (and (symbolp instance) - `((declare (variable-rebinding ,in ,instance))))) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar #'(lambda (slot-entry) (let ((variable-name (car slot-entry)) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 000103f..2168017 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -265,8 +265,8 @@ ;;; Initialize a class metaobject. ;;; -;;; FIXME: This and most stuff in this file is probably only needed at init -;;; time. +;;; FIXME: This and most stuff in this file is probably only needed at +;;; init time. (defun !bootstrap-initialize-class (metaclass-name class name class-eq-wrapper source direct-supers direct-subclasses cpl wrapper @@ -279,6 +279,10 @@ (set-slot 'source source) (set-slot 'type (if (eq class (find-class 't)) t + ;; FIXME: Could this just be CLASS instead + ;; of `(CLASS ,CLASS)? If not, why not? + ;; (See also similar expression in + ;; SHARED-INITIALIZE :BEFORE (CLASS).) `(class ,class))) (set-slot 'class-eq-specializer (let ((spec (allocate-standard-instance class-eq-wrapper))) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index d04a904..cf28f2e 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -254,7 +254,7 @@ (let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*) (name (if (early-gf-p generic-function) - (early-gf-name generic-function) + (!early-gf-name generic-function) (generic-function-name generic-function))) (arg-info (cons nreq applyp)) (effective-method-lambda (expand-effective-method-function @@ -347,15 +347,19 @@ ;;;; the file defcombin.lisp. This is because EQL methods can't appear in the ;;;; bootstrap. ;;;; -;;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION -;;;; classes has to appear here for this reason. This code must conform to -;;;; the code in the file defcombin.lisp, look there for more details. +;;;; The DEFCLASS for the METHOD-COMBINATION and +;;;; STANDARD-METHOD-COMBINATION classes has to appear here for this +;;;; reason. This code must conform to the code in the file +;;;; defcombin.lisp, look there for more details. (defun compute-effective-method (generic-function combin applicable-methods) (standard-compute-effective-method generic-function combin applicable-methods)) +;;; FIXME: As of sbcl-0.6.10, the bindings of *INVALID-METHOD-ERROR* +;;; and *METHOD-COMBINATION-ERROR* are never changed, even within the +;;; dynamic scope of method combination functions. (defvar *invalid-method-error* #'(lambda (&rest args) (declare (ignore args)) @@ -364,7 +368,6 @@ of a method combination function (inside the body of~%~ DEFINE-METHOD-COMBINATION or a method on the generic~%~ function COMPUTE-EFFECTIVE-METHOD)."))) - (defvar *method-combination-error* #'(lambda (&rest args) (declare (ignore args)) @@ -389,11 +392,9 @@ ; (call-next-method)))) (defun invalid-method-error (&rest args) - (declare (arglist method format-string &rest format-arguments)) (apply *invalid-method-error* args)) (defun method-combination-error (&rest args) - (declare (arglist format-string &rest format-arguments)) (apply *method-combination-error* args)) ;This definition now appears in defcombin.lisp. diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 99fcb3d..c2ee95e 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -78,10 +78,12 @@ ;;; classes has been defined, the real definition of LOAD-DEFCLASS is ;;; installed by the file defclass.lisp (defmacro defclass (name direct-superclasses direct-slots &rest options) - (declare (indentation 2 4 3 1)) (expand-defclass name direct-superclasses direct-slots options)) (defun expand-defclass (name supers slots options) + ;; FIXME: We should probably just ensure that the relevant + ;; DEFVAR/DEFPARAMETERs occur before this definition, rather + ;; than locally declaring them SPECIAL. (declare (special *defclass-times* *boot-state* *the-class-structure-class*)) (setq supers (copy-tree supers) slots (copy-tree slots) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 3789c6b..1daa52f 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -46,21 +46,20 @@ need to get a fresh lisp (reboot) and then load PCL.")) ) ; EVAL-WHEN -;;; This is like fdefinition on the Lispm. If Common Lisp had something like -;;; function specs I wouldn't need this. On the other hand, I don't like the -;;; way this really works so maybe function specs aren't really right either? -;;; -;;; I also don't understand the real implications of a Lisp-1 on this sort of -;;; thing. Certainly some of the lossage in all of this is because these -;;; SPECs name global definitions. -;;; -;;; Note that this implementation is set up so that an implementation which -;;; has a 'real' function spec mechanism can use that instead and in that way -;;; get rid of setf generic function names. +;;; comments from CMU CL version of PCL: +;;; This is like fdefinition on the Lispm. If Common Lisp had +;;; something like function specs I wouldn't need this. On the other +;;; hand, I don't like the way this really works so maybe function +;;; specs aren't really right either? +;;; I also don't understand the real implications of a Lisp-1 on this +;;; sort of thing. Certainly some of the lossage in all of this is +;;; because these SPECs name global definitions. +;;; Note that this implementation is set up so that an implementation +;;; which has a 'real' function spec mechanism can use that instead +;;; and in that way get rid of setf generic function names. (defmacro parse-gspec (spec (non-setf-var . non-setf-case) (setf-var . setf-case)) - (declare (indentation 1 1)) #+setf (declare (ignore setf-var setf-case)) (once-only (spec) `(cond (#-setf (symbolp ,spec) #+setf t @@ -384,17 +383,17 @@ (push (list class-name symbol) *built-in-wrapper-symbols*) symbol))) -(pushnew 'class *variable-declarations*) -(pushnew 'variable-rebinding *variable-declarations*) +(pushnew '%class *variable-declarations*) +(pushnew '%variable-rebinding *variable-declarations*) (defun variable-class (var env) (caddr (variable-declaration 'class var env))) (defvar *name->class->slotd-table* (make-hash-table)) -;;; This is used by combined methods to communicate the next methods to -;;; the methods they call. This variable is captured by a lexical variable -;;; of the methods to give it the proper lexical scope. +;;; This is used by combined methods to communicate the next methods +;;; to the methods they call. This variable is captured by a lexical +;;; variable of the methods to give it the proper lexical scope. (defvar *next-methods* nil) (defvar *not-an-eql-specializer* '(not-an-eql-specializer)) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index e1c28ba..0879c32 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -300,13 +300,11 @@ And so, we are saved. (defun accessor-miss-function (gf dfun-info) (ecase (dfun-info-accessor-type dfun-info) (reader - #'(lambda (arg) - (declare (pcl-fast-call)) - (accessor-miss gf nil arg dfun-info))) + (lambda (arg) + (accessor-miss gf nil arg dfun-info))) (writer - #'(lambda (new arg) - (declare (pcl-fast-call)) - (accessor-miss gf new arg dfun-info))))) + (lambda (new arg) + (accessor-miss gf new arg dfun-info))))) #-sb-fluid (declaim (sb-ext:freeze-type dfun-info)) @@ -392,9 +390,8 @@ And so, we are saved. (funcall (get-dfun-constructor 'emit-checking metatypes applyp) cache function - #'(lambda (&rest args) - (declare (pcl-fast-call)) - (checking-miss generic-function args dfun-info))) + (lambda (&rest args) + (checking-miss generic-function args dfun-info))) cache dfun-info))))) @@ -450,9 +447,8 @@ And so, we are saved. (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) cache - #'(lambda (&rest args) - (declare (pcl-fast-call)) - (caching-miss generic-function args dfun-info))) + (lambda (&rest args) + (caching-miss generic-function args dfun-info))) cache dfun-info)))) @@ -511,9 +507,8 @@ And so, we are saved. (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache - #'(lambda (&rest args) - (declare (pcl-fast-call)) - (constant-value-miss generic-function args dfun-info))) + (lambda (&rest args) + (constant-value-miss generic-function args dfun-info))) cache dfun-info)))) @@ -1504,7 +1499,7 @@ And so, we are saved. (defun update-dfun (generic-function &optional dfun cache info) (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p - (early-gf-name generic-function) + (!early-gf-name generic-function) (generic-function-name generic-function))) (ocache (gf-dfun-cache generic-function))) (set-dfun generic-function dfun cache info) diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp index e8a0e06..90c8f38 100644 --- a/src/pcl/env.lisp +++ b/src/pcl/env.lisp @@ -48,7 +48,7 @@ ;;; You can also provide a method object in the place of the method ;;; spec, in which case that method object will be traced. ;;; -;;; For untrace-method, if an argument is given, that method is untraced. +;;; For UNTRACE-METHOD, if an argument is given, that method is untraced. ;;; If no argument is given, all traced methods are untraced. (defclass traced-method (method) ((method :initarg :method) @@ -108,41 +108,6 @@ (symbol-function name)) |# -;(defun compile-method (spec) -; (multiple-value-bind (gf method name) -; (parse-method-or-spec spec) -; (declare (ignore gf)) -; (compile name (method-function method)) -; (setf (method-function method) (symbol-function name)))) - -;;; not used in SBCL -#| -(defmacro undefmethod (&rest args) - (declare (arglist name {method-qualifier}* specializers)) - `(undefmethod-1 ',args)) - -(defun undefmethod-1 (args) - (multiple-value-bind (gf method) - (parse-method-or-spec args) - (when (and gf method) - (remove-method gf method) - method))) -|# - -;;; FIXME: Delete these. -#| -(pushnew :pcl *features*) -(pushnew :portable-commonloops *features*) -(pushnew :pcl-structures *features*) -|# - -;;; FIXME: This was for some unclean bootstrapping thing we don't -;;; need in SBCL, right? So we can delete it, right? -;;; #+cmu -;;; (when (find-package "OLD-PCL") -;;; (setf (symbol-function (find-symbol "PRINT-OBJECT" :old-pcl)) -;;; (symbol-function 'sb-pcl::print-object))) - ;;;; MAKE-LOAD-FORM ;; Overwrite the old bootstrap non-generic MAKE-LOAD-FORM function with a diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 119ae16..92f8ffc 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -27,26 +27,21 @@ (in-package "SB-PCL") (declaim (declaration - ;; FIXME: Since none of these are supported in SBCL, the - ;; declarations using them are just noise now that this is - ;; not a portable package any more, and could be deleted. - values ; I use this so that Zwei can remind - ; me what values a function returns. - arglist ; Tells me what the pretty arglist - ; of something (which probably takes - ; &REST args) is. - indentation ; Tells ZWEI how to indent things - ; like DEFCLASS. - class - variable-rebinding - pcl-fast-call - method-name - method-lambda-list)) - -;;; These are age-old functions which CommonLisp cleaned-up away. They -;;; probably exist in other packages in all CommonLisp -;;; implementations, but I will leave it to the compiler to optimize -;;; into calls to them. + ;; These three nonstandard declarations seem to be used + ;; privately within PCL itself to pass information around, + ;; so we can't just delete them. + %class + %method-name + %method-lambda-list + ;; This declaration may also be used within PCL to pass + ;; information around, I'm not sure. -- WHN 2000-12-30 + %variable-rebinding)) + +;;; comment from CMU CL PCL: +;;; These are age-old functions which CommonLisp cleaned-up away. They +;;; probably exist in other packages in all CommonLisp +;;; implementations, but I will leave it to the compiler to optimize +;;; into calls to them. ;;; ;;; FIXME: MEMQ, ASSQ, and DELQ are already defined in SBCL, and we should ;;; use those. POSQ and NEQ aren't defined in SBCL, and are used too often @@ -59,16 +54,16 @@ (defmacro posq (item list) `(position ,item ,list :test #'eq)) (defmacro neq (x y) `(not (eq ,x ,y))) -;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and CONSTANTLY-0, -;;; and boost them up to SB-INT. +;;; FIXME: Rename these to CONSTANTLY-T, CONSTANTLY-NIL, and +;;; CONSTANTLY-0, and boost them up to SB-INT. (defun true (&rest ignore) (declare (ignore ignore)) t) (defun false (&rest ignore) (declare (ignore ignore)) nil) (defun zero (&rest ignore) (declare (ignore ignore)) 0) -;;; ONCE-ONLY does the same thing as it does in zetalisp. I should -;;; have just lifted it from there but I am honest. Not only that but -;;; this one is written in Common Lisp. I feel a lot like -;;; bootstrapping, or maybe more like rebuilding Rome. +;;; comment from original CMU CL PCL: ONCE-ONLY does the same thing as +;;; it does in zetalisp. I should have just lifted it from there but I +;;; am honest. Not only that but this one is written in Common Lisp. I +;;; feel a lot like bootstrapping, or maybe more like rebuilding Rome. ;;; ;;; FIXME: We should only need one ONCE-ONLY in SBCL, and there's one ;;; in SB-INT already. Can we use only one of these in both places? @@ -130,8 +125,6 @@ body))) ) ; EVAL-WHEN -;;; FIXME: This seems to only be used to get 'METHOD-NAME and -;;; METHOD-LAMBDA-LIST declarations. They aren't ANSI. Are they important? (defun get-declaration (name declarations &optional default) (dolist (d declarations default) (dolist (form (cdr d)) @@ -202,11 +195,6 @@ (defvar *find-class* (make-hash-table :test 'eq)) -(defun make-constant-function (value) - #'(lambda (object) - (declare (ignore object)) - value)) - (defun function-returning-nil (x) (declare (ignore x)) nil) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 8f5dedc..071261b 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -446,6 +446,8 @@ (defmethod shared-initialize :before ((class class) slot-names &key name) (declare (ignore slot-names name)) + ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, + ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) (setf (slot-value class 'type) `(class ,class)) (setf (slot-value class 'class-eq-specializer) (make-instance 'class-eq-specializer :class class))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 54ebc82..dbf5fa8 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -63,7 +63,7 @@ (defvar *slot-name-lists-inner* (make-hash-table :test 'equal)) (defvar *slot-name-lists-outer* (make-hash-table :test 'equal)) -;entries in this are lists of (table . pv-offset-list) +;;; Entries in this are lists of (table . pv-offset-list). (defvar *pv-key-to-pv-table-table* (make-hash-table :test 'equal)) (defun intern-pv-table (&key slot-name-lists call-list) @@ -250,9 +250,6 @@ (defvar *pv-table-cache-update-info* nil) -;called by: -;(method shared-initialize :after (structure-class t)) -;update-slots (defun update-pv-table-cache-info (class) (let ((slot-names-for-pv-table-update nil) (new-icui nil)) @@ -361,34 +358,24 @@ (optimize-writer slots parameter gf-name form))))) (unless (and (consp (cadr form)) (eq 'instance-accessor-parameter (caadr form))) - (or #|| - (cond ((and (= len 2) (symbolp fname)) - (let ((gf-name (gethash fname *gf-declared-reader-table*))) - (when gf-name - (maybe-optimize-reader)))) - ((= len 3) - (let ((gf-name (gethash fname *gf-declared-writer-table*))) - (when gf-name - (maybe-optimize-writer))))) - ||# - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer)))))))))))))) + (when (and (eq *boot-state* 'complete) + (generic-function-p gf)) + (let ((methods (generic-function-methods gf))) + (when methods + (let* ((gf-name (generic-function-name gf)) + (arg-info (gf-arg-info gf)) + (metatypes (arg-info-metatypes arg-info)) + (nreq (length metatypes)) + (applyp (arg-info-applyp arg-info))) + (when (null applyp) + (cond ((= nreq 1) + (when (some #'standard-reader-method-p methods) + (maybe-optimize-reader))) + ((and (= nreq 2) + (consp gf-name) + (eq (car gf-name) 'setf)) + (when (some #'standard-writer-method-p methods) + (maybe-optimize-writer))))))))))))) (defun optimize-generic-function-call (form required-parameters @@ -398,24 +385,6 @@ (declare (ignore required-parameters env slots calls)) (or (and (eq (car form) 'make-instance) (expand-make-instance-form form)) - #|| - (maybe-expand-accessor-form form required-parameters slots env) - (let* ((fname (car form)) - (len (length form)) - (gf (if (symbolp fname) - (and (fboundp fname) - (unencapsulated-fdefinition fname)) - (and (gboundp fname) - (gdefinition fname)))) - (gf-name (and (fsc-instance-p gf) - (if (early-gf-p gf) - (early-gf-name gf) - (generic-function-name gf))))) - (when gf-name - (multiple-value-bind (nreq restp) - (get-generic-function-info gf) - (optimize-gf-call slots calls form nreq restp env)))) - ||# form)) (defun can-optimize-access (form required-parameters env) @@ -427,32 +396,32 @@ (slot-name (eval (caddr form)))) ; known to be constant (can-optimize-access1 var required-parameters env type slot-name))) -;;; FIXME: This looks like an internal helper function for CAN-OPTIMIZE-ACCESS, -;;; and it is used that way, but -;;; it's also called bare from several places in the code. Perhaps -;;; the two functions should be renamed fo CAN-OPTIMIZE-ACCESS-FOR-FORM -;;; and CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword +;;; FIXME: This looks like an internal helper function for +;;; CAN-OPTIMIZE-ACCESS, and it is used that way, but it's also called +;;; bare from several places in the code. Perhaps the two functions +;;; should be renamed CAN-OPTIMIZE-ACCESS-FOR-FORM and +;;; CAN-OPTIMIZE-ACCESS-FOR-VAR. If so, I'd just as soon use keyword ;;; args instead of optional ones, too. (defun can-optimize-access1 (var required-parameters env &optional type slot-name) (when (and (consp var) (eq 'the (car var))) - ;; FIXME: We should assert list of length 3 here. Or maybe we should just - ;; define EXTRACT-THE, replace the whole + ;; FIXME: We should assert list of length 3 here. Or maybe we + ;; should just define EXTRACT-THE, replace the whole ;; (WHEN ..) ;; form with ;; (AWHEN (EXTRACT-THE VAR) ;; (SETF VAR IT)) - ;; and then use EXTRACT-THE similarly to clean up the other tests against - ;; 'THE scattered through the PCL code. + ;; and then use EXTRACT-THE similarly to clean up the other tests + ;; against 'THE scattered through the PCL code. (setq var (caddr var))) (when (symbolp var) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding + (let* ((rebound? (caddr (variable-declaration '%variable-rebinding var env))) (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) (when parameter-or-nil - (let* ((class-name (caddr (variable-declaration 'class + (let* ((class-name (caddr (variable-declaration '%class parameter-or-nil env))) (class (find-class class-name nil))) @@ -490,19 +459,21 @@ (defun optimize-slot-boundp (slots sparameter form) (if sparameter (destructuring-bind - ;; FIXME: In CMU CL ca. 19991205, this binding list had a fourth - ;; element in it, NEW-VALUE. It's hard to see how that could possibly - ;; be right, since SLOT-BOUNDP has no NEW-VALUE. Since it was causing - ;; a failure in building PCL for SBCL, so I changed it to match the - ;; definition of SLOT-BOUNDP (and also to match the list used in the - ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded out by - ;; this, since this is old code which has worked for ages to build - ;; PCL for CMU CL, so it's hard to see why it should need a patch - ;; like this in order to build PCL for SBCL. I'd like to return to - ;; this and find a test case which exercises this function both in - ;; CMU CL, to see whether it's really a previously-unexercised bug or - ;; whether I've misunderstood something (and, presumably, patched it - ;; wrong). + ;; FIXME: In CMU CL ca. 19991205, this binding list had a + ;; fourth element in it, NEW-VALUE. It's hard to see how + ;; that could possibly be right, since SLOT-BOUNDP has no + ;; NEW-VALUE. Since it was causing a failure in building PCL + ;; for SBCL, so I changed it to match the definition of + ;; SLOT-BOUNDP (and also to match the list used in the + ;; similar OPTIMIZE-SLOT-VALUE, above). However, I'm weirded + ;; out by this, since this is old code which has worked for + ;; ages to build PCL for CMU CL, so it's hard to see why it + ;; should need a patch like this in order to build PCL for + ;; SBCL. I'd like to return to this and find a test case + ;; which exercises this function both in CMU CL, to see + ;; whether it's really a previously-unexercised bug or + ;; whether I've misunderstood something (and, presumably, + ;; patched it wrong). (slot-boundp-symbol instance slot-name-form) form (declare (ignore slot-boundp-symbol instance)) @@ -526,10 +497,10 @@ (optimize-accessor-call slots :write sparameter gf-name new-value)) form)) -;;; The SLOTS argument is an alist, the CAR of each entry is the name of -;;; a required parameter to the function. The alist is in order, so the -;;; position of an entry in the alist corresponds to the argument's position -;;; in the lambda list. +;;; The SLOTS argument is an alist, the CAR of each entry is the name +;;; of a required parameter to the function. The alist is in order, so +;;; the position of an entry in the alist corresponds to the +;;; argument's position in the lambda list. (defun optimize-instance-access (slots read/write sparameter @@ -603,7 +574,7 @@ (eq (car form) 'the)) (setq form (caddr form))) (or (and (symbolp form) - (let* ((rebound? (caddr (variable-declaration 'variable-rebinding + (let* ((rebound? (caddr (variable-declaration '%variable-rebinding form env))) (parameter-or-nil (car (assq (or rebound? form) slots)))) (when parameter-or-nil @@ -619,7 +590,7 @@ *unspecific-arg*))) (defun optimize-gf-call (slots calls gf-call-form nreq restp env) - (unless (eq (car gf-call-form) 'make-instance) ; needs more work + (unless (eq (car gf-call-form) 'make-instance) ; XXX needs more work (let* ((args (cdr gf-call-form)) (all-args-p (eq (car gf-call-form) 'make-instance)) (non-required-args (nthcdr nreq args)) @@ -653,8 +624,8 @@ (define-walker-template instance-accessor-parameter) (defmacro instance-accessor-parameter (x) x) -;; It is safe for these two functions to be wrong. -;; They just try to guess what the most likely case will be. +;;; It is safe for these two functions to be wrong. They just try to +;;; guess what the most likely case will be. (defun generate-fast-class-slot-access-p (class-form slot-name-form) (let ((class (and (constantp class-form) (eval class-form))) (slot-name (and (constantp slot-name-form) (eval slot-name-form)))) @@ -671,7 +642,9 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (skip-optimize-slot-value-by-class-p class slot-name type)))))) + (and slotd (skip-optimize-slot-value-by-class-p class + slot-name + type)))))) (defun skip-optimize-slot-value-by-class-p (class slot-name type) (let ((slotd (find-slot-definition class slot-name))) @@ -786,18 +759,20 @@ ;;; This magic function has quite a job to do indeed. ;;; -;;; The careful reader will recall that contains all of the optimized -;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is -;;; a call to either INSTANCE-READ or INSTANCE-WRITE. +;;; The careful reader will recall that contains all of the +;;; optimized slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. +;;; Each of these is a call to either INSTANCE-READ or INSTANCE-WRITE. ;;; -;;; At the time these calls were produced, the first argument was specified as -;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset -;;; arguments into the actual number that is the correct offset into the pv. +;;; At the time these calls were produced, the first argument was +;;; specified as the symbol .PV-OFFSET.; what we have to do now is +;;; convert those pv-offset arguments into the actual number that is +;;; the correct offset into the pv. ;;; -;;; But first, oh but first, we sort a bit so that for each argument we -;;; have the slots in alphabetical order. This canonicalizes the PV-TABLE's a -;;; bit and will hopefully lead to having fewer PV's floating around. Even if -;;; the gain is only modest, it costs nothing. +;;; But first, oh but first, we sort a bit so that for each +;;; argument we have the slots in alphabetical order. This +;;; canonicalizes the PV-TABLE's a bit and will hopefully lead to +;;; having fewer PV's floating around. Even if the gain is only +;;; modest, it costs nothing. (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists @@ -880,19 +855,20 @@ (symbol-or-cons-lessp (car a) (car b)))))))) (defun sort-slots (slots) - (mapcar #'(lambda (parameter-entry) - (cons (car parameter-entry) - (sort (cdr parameter-entry) ;slot entries - #'symbol-or-cons-lessp - :key #'car))) + (mapcar (lambda (parameter-entry) + (cons (car parameter-entry) + (sort (cdr parameter-entry) ;slot entries + #'symbol-or-cons-lessp + :key #'car))) slots)) (defun sort-calls (calls) (sort calls #'symbol-or-cons-lessp :key #'car)) -;;; This needs to work in terms of metatypes and also needs to work for -;;; automatically generated reader and writer functions. -;;; -- Automatically generated reader and writer functions use this stuff too. +;;;; This needs to work in terms of metatypes and also needs to work +;;;; for automatically generated reader and writer functions. +;;;; Automatically generated reader and writer functions use this +;;;; stuff too. (defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol) &body body) @@ -914,7 +890,7 @@ slot-vars pv-parameters)) ,@body))) -;This gets used only when the default make-method-lambda is overriden. +;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden. (defmacro pv-env ((pv calls pv-table-symbol pv-parameters) &rest forms) `(let* ((.pv-table. ,pv-table-symbol) @@ -933,17 +909,17 @@ ;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If ;; SBCL doesn't have 'em, VALUES should probably be removed from ;; this list. - '(values method-name method-lambda-list + '(values %method-name %method-lambda-list optimize ftype inline notinline)) (defvar *variable-declarations-with-argument* - '(class + '(%class type)) (defvar *variable-declarations-without-argument* '(ignore ignorable special dynamic-extent - ;; FIXME: Possibly this entire list and variable should go away. + ;; FIXME: Possibly this entire list and variable could go away. ;; If not, certainly we should remove all these built-in typenames ;; from the list, and replace them with a test for "is it a type ;; name?" (CLTL1 allowed only built-in type names as declarations, @@ -982,9 +958,12 @@ ;; FIXME: This warning, and perhaps the ;; various *VARIABLE-DECLARATIONS-FOO* and/or ;; *NON-VARIABLE-DECLARATIONS* variables, - ;; should probably go away now that we're not + ;; could probably go away now that we're not ;; trying to be portable between different - ;; CLTL1 hosts the way PCL was. + ;; CLTL1 hosts the way PCL was. (Note that to + ;; do this right, we need to be able to handle + ;; user-defined (DECLAIM (DECLARATION FOO)) + ;; stuff.) (warn "The declaration ~S is not understood by ~S.~@ Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ (Assuming it is a variable declaration without argument)." @@ -1068,10 +1047,11 @@ ,@body))) ',initargs)))) -;;; Use arrays and hash tables and the fngen stuff to make this much better. It -;;; doesn't really matter, though, because a function returned by this will get -;;; called only when the user explicitly funcalls a result of method-function. -;;; BUT, this is needed to make early methods work. +;;; Use arrays and hash tables and the fngen stuff to make this much +;;; better. It doesn't really matter, though, because a function +;;; returned by this will get called only when the user explicitly +;;; funcalls a result of method-function. BUT, this is needed to make +;;; early methods work. (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) diff --git a/version.lisp-expr b/version.lisp-expr index c0cda32..494ef3e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.13" +"0.6.9.14"