From 77360ee4a1f94c41b807be7ad0e8687199fceef1 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 13 Nov 2000 18:16:46 +0000 Subject: [PATCH] 0.6.8.17: deleted more unused stuff --- BUGS | 26 +-- package-data-list.lisp-expr | 8 +- src/code/alien-type.lisp | 14 +- src/code/class.lisp | 10 +- src/code/cold-init.lisp | 51 +++-- src/code/cross-type.lisp | 20 +- src/code/debug-info.lisp | 52 ++--- src/code/debug.lisp | 26 +-- src/code/describe.lisp | 36 ++-- src/code/early-type.lisp | 4 +- src/code/gc.lisp | 10 +- src/code/globals.lisp | 14 +- src/code/hash-table.lisp | 29 +-- src/code/host-alieneval.lisp | 7 +- src/code/interr.lisp | 3 - src/code/irrat.lisp | 29 ++- src/code/late-type.lisp | 204 ++++++++++---------- src/code/show.lisp | 33 ---- src/code/signal.lisp | 4 +- src/code/toplevel.lisp | 12 -- src/code/type-class.lisp | 46 ++--- src/code/typedefs.lisp | 2 +- src/compiler/backend.lisp | 2 +- src/compiler/checkgen.lisp | 287 +++++++++++++++------------- src/compiler/debug-dump.lisp | 1 - src/compiler/early-c.lisp | 2 +- src/compiler/generic/genesis.lisp | 3 +- src/compiler/generic/primtype.lisp | 14 +- src/compiler/generic/vm-macs.lisp | 2 - src/compiler/generic/vm-type.lisp | 27 +-- src/compiler/main.lisp | 27 +-- src/compiler/seqtran.lisp | 18 ++ src/compiler/typetran.lisp | 22 +++ src/compiler/x86/backend-parms.lisp | 3 +- src/compiler/x86/c-call.lisp | 2 +- src/compiler/x86/call.lisp | 30 +-- src/compiler/x86/nlx.lisp | 6 +- src/compiler/x86/vm.lisp | 6 +- src/pcl/walk.lisp | 356 ++++++++++++++--------------------- tests/compound-cons.impure.lisp | 40 ++-- version.lisp-expr | 2 +- 41 files changed, 704 insertions(+), 786 deletions(-) diff --git a/BUGS b/BUGS index 395fbab..0a80569 100644 --- a/BUGS +++ b/BUGS @@ -320,16 +320,6 @@ returning an array as first value always. Process inferior-lisp exited abnormally with code 1 I haven't noticed a repeatable case of this yet. -28: - The system accepts DECLAIM in most places where DECLARE would be - accepted, without even issuing a warning. ANSI allows this, but since - it's fairly easy to mistype DECLAIM instead of DECLARE, and the - meaning is rather different, and it's unlikely that the user - has a good reason for doing DECLAIM not at top level, it would be - good to issue a STYLE-WARNING when this happens. A possible - fix would be to issue STYLE-WARNINGs for DECLAIMs not at top level, - or perhaps to issue STYLE-WARNINGs for any EVAL-WHEN not at top level. - 29: some sort of bug in inlining and RETURN-FROM in sbcl-0.6.5: Compiling (DEFUN BAR? (X) @@ -780,7 +770,7 @@ Error in function C::GET-LAMBDA-TO-COMPILE: and GO forms are removed (leaving the SETF in ordinary, non-looping code), or if the TAGBODY and GO forms are retained, but the assigned value becomes 0.0 instead of (- (ROW-MAJOR-AREF A I)). - + KNOWN BUGS RELATED TO THE IR1 INTERPRETER @@ -840,3 +830,17 @@ IR1-3a: "no!"))) and while EVAL doesn't print the "right now!" messages, the first FUNCALL on the value returned by EVAL causes both of them to be printed. + +IR1-4: + The system accepts DECLAIM in most places where DECLARE would be + accepted, without even issuing a warning. ANSI allows this, but since + it's fairly easy to mistype DECLAIM instead of DECLARE, and the + meaning is rather different, and it's unlikely that the user + has a good reason for doing DECLAIM not at top level, it would be + good to issue a STYLE-WARNING when this happens. A possible + fix would be to issue STYLE-WARNINGs for DECLAIMs not at top level, + or perhaps to issue STYLE-WARNINGs for any EVAL-WHEN not at top level. + [This is considered an IR1-interpreter-related bug because until + EVAL-WHEN is rewritten, which won't happen until after the IR1 + interpreter is gone, the system's notion of what's a top-level form + and what's not will remain too confused to fix this problem.] diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 45404f1..52f4296 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1727,8 +1727,12 @@ structure representations" :doc "internal: a code walker used by PCL" :use ("CL") :export ("DEFINE-WALKER-TEMPLATE" "WALK-FORM" - "*WALK-FORM-EXPAND-MACROS-P*" "NESTED-WALK-FORM" + "*WALK-FORM-EXPAND-MACROS-P*" "VARIABLE-LEXICAL-P" "VARIABLE-SPECIAL-P" "VARIABLE-GLOBALLY-SPECIAL-P" "*VARIABLE-DECLARATIONS*" "VARIABLE-DECLARATION" - "MACROEXPAND-ALL"))) + + ;; These were expored from the original PCL version of this + ;; package, but aren't used in SBCL. + ;;"NESTED-WALK-FORM" "MACROEXPAND-ALL" + ))) diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp index 0a28be1..40e3ea1 100644 --- a/src/code/alien-type.lisp +++ b/src/code/alien-type.lisp @@ -21,17 +21,17 @@ (:constructor %make-alien-type-type (alien-type))) (alien-type nil :type alien-type)) -(define-type-class alien) +(!define-type-class alien) -(define-type-method (alien :unparse) (type) +(!define-type-method (alien :unparse) (type) `(alien ,(unparse-alien-type (alien-type-type-alien-type type)))) -(define-type-method (alien :simple-subtypep) (type1 type2) +(!define-type-method (alien :simple-subtypep) (type1 type2) (values (alien-subtype-p (alien-type-type-alien-type type1) (alien-type-type-alien-type type2)) t)) -;;; KLUDGE: This DEFINE-SUPERCLASSES gets executed much later than the +;;; KLUDGE: This !DEFINE-SUPERCLASSES gets executed much later than the ;;; others (toplevel form time instead of cold load init time) because ;;; ALIEN-VALUE itself is a structure which isn't defined until fairly ;;; late. @@ -40,16 +40,16 @@ ;;; It's sufficiently unlike the others that it's a bit of a pain, and ;;; it doesn't seem to be put to any good use either in type inference or ;;; in type declarations. -(define-superclasses alien ((alien-value)) progn) +(!define-superclasses alien ((alien-value)) progn) -(define-type-method (alien :simple-=) (type1 type2) +(!define-type-method (alien :simple-=) (type1 type2) (let ((alien-type-1 (alien-type-type-alien-type type1)) (alien-type-2 (alien-type-type-alien-type type2))) (values (or (eq alien-type-1 alien-type-2) (alien-type-= alien-type-1 alien-type-2)) t))) -(def-type-translator alien (&optional (alien-type nil)) +(!def-type-translator alien (&optional (alien-type nil)) (typecase alien-type (null (make-alien-type-type)) diff --git a/src/code/class.lisp b/src/code/class.lisp index 4c67377..4e928a0 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -660,16 +660,16 @@ ;;;; CLASS type operations -(define-type-class sb!xc:class) +(!define-type-class sb!xc:class) ;;; Simple methods for TYPE= and SUBTYPEP should never be called when ;;; the two classes are equal, since there are EQ checks in those ;;; operations. -(define-type-method (sb!xc:class :simple-=) (type1 type2) +(!define-type-method (sb!xc:class :simple-=) (type1 type2) (assert (not (eq type1 type2))) (values nil t)) -(define-type-method (sb!xc:class :simple-subtypep) (class1 class2) +(!define-type-method (sb!xc:class :simple-subtypep) (class1 class2) (assert (not (eq class1 class2))) (let ((subclasses (class-subclasses class2))) (if (and subclasses (gethash class1 subclasses)) @@ -697,7 +697,7 @@ ;;; they are structure classes, since a subclass of both might be ;;; defined. If either class is sealed, we can eliminate this ;;; possibility. -(define-type-method (sb!xc:class :simple-intersection) (class1 class2) +(!define-type-method (sb!xc:class :simple-intersection) (class1 class2) (declare (type sb!xc:class class1 class2)) (cond ((eq class1 class2) class1) ((let ((subclasses (class-subclasses class2))) @@ -716,7 +716,7 @@ (t (values class1 nil)))) -(define-type-method (sb!xc:class :unparse) (type) +(!define-type-method (sb!xc:class :unparse) (type) (class-proper-name type)) ;;;; PCL stuff diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index 3f24bb5..7d607f8 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -45,29 +45,30 @@ ;;; a SIMPLE-VECTOR set by genesis (defvar *!load-time-values*) +(defun !cold-lose (msg) + (%primitive print msg) + (%primitive print "too early in cold init to recover from errors") + (%halt)) + #!+gengc (defun do-load-time-value-fixup (object offset index) (declare (type index offset)) - (macrolet ((lose (msg) - `(progn - (%primitive print ,msg) - (%halt)))) - (let ((value (svref *!load-time-values* index))) - (typecase object - (list - (case offset - (0 (setf (car object) value)) - (1 (setf (cdr object) value)) - (t (lose "bogus offset in cons cell")))) - (instance - (setf (%instance-ref object (- offset sb!vm:instance-slots-offset)) - value)) - (code-component - (setf (code-header-ref object offset) value)) - (simple-vector - (setf (svref object (- offset sb!vm:vector-data-offset)) value)) - (t - (lose "unknown kind of object for load-time-value fixup")))))) + (let ((value (svref *!load-time-values* index))) + (typecase object + (list + (case offset + (0 (setf (car object) value)) + (1 (setf (cdr object) value)) + (t (!cold-lose "bogus offset in cons cell")))) + (instance + (setf (%instance-ref object (- offset sb!vm:instance-slots-offset)) + value)) + (code-component + (setf (code-header-ref object offset) value)) + (simple-vector + (setf (svref object (- offset sb!vm:vector-data-offset)) value)) + (t + (!cold-lose "unknown kind of object for load-time-value fixup"))))) (eval-when (:compile-toplevel :execute) ;; FIXME: Perhaps we should make SHOW-AND-CALL-AND-FMAKUNBOUND, too, @@ -185,12 +186,8 @@ (fourth toplevel-thing) (fifth toplevel-thing))) (t - (%primitive print - "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*") - (%halt)))) - (t - (%primitive print "bogus function in *!REVERSED-COLD-TOPLEVELS*") - (%halt))))) + (!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*")))) + (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 @@ -268,7 +265,7 @@ and so forth) unless RECKLESSLY-P is non-NIL. On UNIX-like systems, UNIX-STATUS is used as the status code." (declare (type (signed-byte 32) unix-code)) - ;; TO DO: UNIX-CODE was deprecated in sbcl-0.6.8, after having been + ;; FIXME: UNIX-CODE was deprecated in sbcl-0.6.8, after having been ;; around for less than a year. It should be safe to remove it after ;; a year. (when unix-code-p diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index ab24bdb..7827b7e 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -83,12 +83,12 @@ (t (error "can't handle TYPE-OF ~S in cross-compilation")))))) -;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE when -;;; instantiated on the target SBCL. Since this is hard to decide in some -;;; cases, and since in other cases we just haven't bothered to try, it -;;; needs to return two values, just like SUBTYPEP: the first value for -;;; its conservative opinion (never T unless it's certain) and the second -;;; value to tell whether it's certain. +;;; Like TYPEP, but asks whether HOST-OBJECT would be of TARGET-TYPE +;;; when instantiated on the target SBCL. Since this is hard to decide +;;; in some cases, and since in other cases we just haven't bothered +;;; to try, it needs to return two values, just like SUBTYPEP: the +;;; first value for its conservative opinion (never T unless it's +;;; certain) and the second value to tell whether it's certain. (defun cross-typep (host-object target-type) (flet ((warn-and-give-up () ;; We don't have to keep track of this as long as system performance @@ -328,7 +328,9 @@ (structure!object (sb!xc:find-class (uncross (class-name (class-of x))))) (t - ;; There might be more cases which we could handle with sufficient effort; - ;; since all we *need* to handle are enough cases for bootstrapping, we - ;; don't try to be complete here. -- WHN 19990512 + ;; There might be more cases which we could handle with + ;; sufficient effort; since all we *need* to handle are enough + ;; cases for bootstrapping, we don't try to be complete here,. If + ;; future maintainers make the bootstrap code more complicated, + ;; they can also add new cases here to handle it. -- WHN 2000-11-11 (error "can't handle ~S in cross CTYPE-OF" x)))) diff --git a/src/code/debug-info.lisp b/src/code/debug-info.lisp index fac06dd..e89294d 100644 --- a/src/code/debug-info.lisp +++ b/src/code/debug-info.lisp @@ -262,24 +262,24 @@ function (which would be useful info anyway). (def!struct (debug-source #-sb-xc-host (:pure t)) ;; This slot indicates where the definition came from: - ;; :File - from a file (Compile-File) - ;; :Lisp - from Lisp (Compile) + ;; :FILE - from a file (COMPILE-FILE) + ;; :LISP - from Lisp (COMPILE) (from (required-argument) :type (member :file :lisp)) - ;; If :File, the file name, if :Lisp or :Stream, then a vector of the - ;; top-level forms. When from COMPILE, form 0 is #'(LAMBDA ...). + ;; If :FILE, the file name, if :LISP or :STREAM, then a vector of + ;; the top-level forms. When from COMPILE, form 0 is #'(LAMBDA ...). (name nil) - ;; File comment for this file, if any. - (comment nil :type (or simple-string null)) - ;; The universal time that the source was written, or NIL if unavailable. + ;; the universal time that the source was written, or NIL if + ;; unavailable (created nil :type (or unsigned-byte null)) - ;; The universal time that the source was compiled. + ;; the universal time that the source was compiled (compiled (required-argument) :type unsigned-byte) - ;; The source path root number of the first form read from this source (i.e. - ;; the total number of forms converted previously in this compilation.) + ;; the source path root number of the first form read from this + ;; source (i.e. the total number of forms converted previously in + ;; this compilation) (source-root 0 :type index) - ;; The file-positions of each truly top-level form read from this file (if - ;; applicable). The vector element type will be chosen to hold the largest - ;; element. May be null to save space. + ;; The FILE-POSITIONs of the truly top-level forms read from this + ;; file (if applicable). The vector element type will be chosen to + ;; hold the largest element. May be null to save space. (start-positions nil :type (or (simple-array * (*)) null)) ;; If from :LISP, this is the function whose source is form 0. (info nil)) @@ -292,21 +292,25 @@ function (which would be useful info anyway). ;; A list of DEBUG-SOURCE structures describing where the code for this ;; component came from, in the order that they were read. ;; - ;; *** NOTE: the offset of this slot is wired into the fasl dumper so that it - ;; *** can backpatch the source info when compilation is complete. + ;; KLUDGE: comment from CMU CL: + ;; *** NOTE: the offset of this slot is wired into the fasl dumper + ;; *** so that it can backpatch the source info when compilation + ;; *** is complete. (source nil :type list)) (def!struct (compiled-debug-info (:include debug-info) #-sb-xc-host (:pure t)) - ;; a simple-vector of alternating DEBUG-FUNCTION objects and fixnum PCs, - ;; used to map PCs to functions, so that we can figure out what function we - ;; were running in. Each function is valid between the PC before it - ;; (inclusive) and the PC after it (exclusive). The PCs are in sorted order, - ;; to allow binary search. We omit the first and last PC, since their values - ;; are 0 and the length of the code vector. + ;; a simple-vector of alternating DEBUG-FUNCTION objects and fixnum + ;; PCs, used to map PCs to functions, so that we can figure out what + ;; function we were running in. Each function is valid between the + ;; PC before it (inclusive) and the PC after it (exclusive). The PCs + ;; are in sorted order, to allow binary search. We omit the first + ;; and last PC, since their values are 0 and the length of the code + ;; vector. ;; - ;; KLUDGE: PC's can't always be represented by FIXNUMs, unless we're always - ;; careful to put our code in low memory. Is that how it works? Would this - ;; break if we used a more general memory map? -- WHN 20000120 + ;; KLUDGE: PC's can't always be represented by FIXNUMs, unless we're + ;; always careful to put our code in low memory. Is that how it + ;; works? Would this break if we used a more general memory map? -- + ;; WHN 20000120 (function-map (required-argument) :type simple-vector :read-only t)) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 80ae5ca..e89d012 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -787,9 +787,7 @@ reset to ~S." (unless (boundp '*) (setq * nil) (fresh-line) - ;; FIXME: Perhaps this shouldn't be WARN (for fear of complicating - ;; the debugging situation?) but at least it should go to *ERROR-OUTPUT*. - ;; (And probably it should just be WARN.) + ;; FIXME: The way INTERACTIVE-EVAL does this seems better. (princ "Setting * to NIL (was unbound marker).")))) ;;;; debug loop functions @@ -1212,8 +1210,9 @@ reset to ~S." ;;;; source location printing -;;; We cache a stream to the last valid file debug source so that we won't have -;;; to repeatedly open the file. +;;; We cache a stream to the last valid file debug source so that we +;;; won't have to repeatedly open the file. +;;; ;;; KLUDGE: This sounds like a bug, not a feature. Opening files is fast ;;; in the 1990s, so the benefit is negligible, less important than the ;;; potential of extra confusion if someone changes the source during @@ -1236,16 +1235,17 @@ reset to ~S." *cached-readtable* nil)) sb!int:*before-save-initializations*) -;;; We also cache the last top-level form that we printed a source for so that -;;; we don't have to do repeated reads and calls to FORM-NUMBER-TRANSLATIONS. +;;; We also cache the last top-level form that we printed a source for +;;; so that we don't have to do repeated reads and calls to +;;; FORM-NUMBER-TRANSLATIONS. (defvar *cached-top-level-form-offset* nil) (declaim (type (or index null) *cached-top-level-form-offset*)) (defvar *cached-top-level-form*) (defvar *cached-form-number-translations*) -;;; Given a code location, return the associated form-number translations and -;;; the actual top-level form. We check our cache --- if there is a miss, we -;;; dispatch on the kind of the debug source. +;;; Given a code location, return the associated form-number +;;; translations and the actual top-level form. We check our cache --- +;;; if there is a miss, we dispatch on the kind of the debug source. (defun get-top-level-form (location) (let ((d-source (sb!di:code-location-debug-source location))) (if (and (eq d-source *cached-debug-source*) @@ -1262,9 +1262,9 @@ reset to ~S." (sb!di:form-number-translations res offset)) (setq *cached-top-level-form* res)))))) -;;; Locates the source file (if it still exists) and grabs the top-level form. -;;; If the file is modified, we use the top-level-form offset instead of the -;;; recorded character offset. +;;; Locate the source file (if it still exists) and grab the top-level +;;; form. If the file is modified, we use the top-level-form offset +;;; instead of the recorded character offset. (defun get-file-top-level-form (location) (let* ((d-source (sb!di:code-location-debug-source location)) (tlf-offset (sb!di:code-location-top-level-form-offset location)) diff --git a/src/code/describe.lisp b/src/code/describe.lisp index 56f3349..eb87312 100644 --- a/src/code/describe.lisp +++ b/src/code/describe.lisp @@ -158,25 +158,23 @@ (let ((info (sb-kernel:%code-debug-info code-obj))) (when info (let ((sources (sb-c::debug-info-source info))) - (format s "~@:_On ~A it was compiled from:" - ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system - ;; should become more consistent, probably not using - ;; any nondefault options. - (format-universal-time nil - (sb-c::debug-source-compiled - (first sources)) - :style :abbreviated)) - (dolist (source sources) - (let ((name (sb-c::debug-source-name source))) - (ecase (sb-c::debug-source-from source) - (:file - (format s "~@:_~A~@:_ Created: " (namestring name)) - (sb-int:format-universal-time t (sb-c::debug-source-created - source)) - (let ((comment (sb-c::debug-source-comment source))) - (when comment - (format s "~@:_ Comment: ~A" comment)))) - (:lisp (format s "~@:_~S" name))))))))) + (when sources + (format s "~@:_On ~A it was compiled from:" + ;; FIXME: The FORMAT-UNIVERSAL-TIME calls in the system + ;; should become more consistent, probably not using + ;; any nondefault options. + (format-universal-time nil + (sb-c::debug-source-compiled + (first sources)) + :style :abbreviated)) + (dolist (source sources) + (let ((name (sb-c::debug-source-name source))) + (ecase (sb-c::debug-source-from source) + (:file + (format s "~@:_~A~@:_ Created: " (namestring name)) + (sb-int:format-universal-time t (sb-c::debug-source-created + source))) + (:lisp (format s "~@:_~S" name)))))))))) ;;; Describe a compiled function. The closure case calls us to print ;;; the guts. diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 8aee3f6..c4fe88a 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -93,7 +93,7 @@ ;; the Common Lisp type-specifier (specifier nil :type t)) -(define-type-class hairy) +(!define-type-class hairy) ;;; An UNKNOWN-TYPE is a type not known to the type system (not yet ;;; defined). We make this distinction since we don't want to complain @@ -120,7 +120,7 @@ (:include args-type (class-info (type-class-or-lose 'values))))) -(define-type-class values) +(!define-type-class values) (defstruct (function-type (:include args-type diff --git a/src/code/gc.lisp b/src/code/gc.lisp index 07cfe9c..973799d 100644 --- a/src/code/gc.lisp +++ b/src/code/gc.lisp @@ -352,11 +352,11 @@ (set-auto-gc-trigger *gc-trigger*) (dolist (hook *after-gc-hooks*) (/show0 "doing a hook from *AFTER-GC--HOOKS*") - ;; FIXME: This hook should be called with the - ;; same kind of information as *GC-NOTIFY-AFTER*. - ;; In particular, it would be nice for the - ;; hook function to be able to adjust *GC-TRIGGER* - ;; intelligently to e.g. 108% of total memory usage. + ;; FIXME: This hook should be called with the same + ;; kind of information as *GC-NOTIFY-AFTER*. In + ;; particular, it would be nice for the hook function + ;; to be able to adjust *GC-TRIGGER* intelligently to + ;; e.g. 108% of total memory usage. (carefully-funcall hook)) (when *gc-notify-stream* (/show0 "doing the *GC-NOTIFY-AFTER* thing") diff --git a/src/code/globals.lisp b/src/code/globals.lisp index 70885e9..86b3d9d 100644 --- a/src/code/globals.lisp +++ b/src/code/globals.lisp @@ -15,17 +15,8 @@ (in-package "SB!IMPL") -;;; FIXME: The COMMON-LISP specials here are already handled in -;;; cl-specials.lisp. -(declaim (special *keyword-package* *cl-package* *package* *query-io* - *terminal-io* *error-output* *trace-output* *debug-io* - *standard-input* *standard-output* - *evalhook* *applyhook* +(declaim (special *keyword-package* *cl-package* original-lisp-environment - *read-default-float-format* - *read-suppress* *readtable* *print-base* *print-radix* - *print-length* *print-level* *print-pretty* *print-escape* - *print-case* *print-circle* *print-gensym* *print-array* *standard-readtable* sb!debug:*in-the-debugger* sb!debug:*stack-top-hint* @@ -35,8 +26,7 @@ *software-interrupt-vector* *load-verbose* *load-print-stuff* *in-compilation-unit* *aborted-compilation-unit-count* *char-name-alist* - *default-pathname-defaults* *beep-function* - *gc-notify-before* *gc-notify-after* + *beep-function* *gc-notify-before* *gc-notify-after* *posix-argv*)) (declaim (ftype (function * *) diff --git a/src/code/hash-table.lisp b/src/code/hash-table.lisp index 76a2978..f4cc5b8 100644 --- a/src/code/hash-table.lisp +++ b/src/code/hash-table.lisp @@ -43,23 +43,25 @@ ;;; HASH-TABLE is implemented as a STRUCTURE-OBJECT. (sb!xc:defstruct (hash-table (:constructor %make-hash-table)) - ;; The type of hash table this is. Only used for printing and as part of - ;; the exported interface. + ;; The type of hash table this is. Only used for printing and as + ;; part of the exported interface. (test (required-argument) :type symbol :read-only t) - ;; The function used to compare two keys. Returns T if they are the same - ;; and NIL if not. + ;; The function used to compare two keys. Returns T if they are the + ;; same and NIL if not. (test-fun (required-argument) :type function :read-only t) - ;; The function used to compute the hashing of a key. Returns two values: - ;; the index hashing and T if that might change with the next GC. + ;; The function used to compute the hashing of a key. Returns two + ;; values: the index hashing and T if that might change with the + ;; next GC. (hash-fun (required-argument) :type function :read-only t) - ;; How much to grow the hash table by when it fills up. If an index, then - ;; add that amount. If a floating point number, then multiple it by that. + ;; how much to grow the hash table by when it fills up. If an index, + ;; then add that amount. If a floating point number, then multiply + ;; it by that. (rehash-size (required-argument) :type (or index (single-float (1.0))) :read-only t) - ;; How full the hash table has to get before we rehash. + ;; how full the hash table has to get before we rehash (rehash-threshold (required-argument) :type (single-float (0.0) 1.0) :read-only t) - ;; The number of entries before a rehash, just the one less than the + ;; The number of entries before a rehash, just one less than the ;; size of the next-vector, hash-vector, and half the size of the ;; kv-vector. (rehash-trigger (required-argument) :type index) @@ -67,9 +69,10 @@ (number-entries 0 :type index) ;; The Key-Value pair vector. (table (required-argument) :type simple-vector) - ;; True if this is a weak hash table, meaning that key->value mappings will - ;; disappear if there are no other references to the key. Note: this only - ;; matters if the hash function indicates that the hashing is EQ based. + ;; True if this is a weak hash table, meaning that key->value + ;; mappings will disappear if there are no other references to the + ;; key. Note: this only matters if the hash function indicates that + ;; the hashing is EQ based. (weak-p nil :type (member t nil)) ;; Index into the next-vector, chaining together buckets that need ;; to be rehashed because their hashing is EQ based and the key has diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp index 7058209..adb9eff 100644 --- a/src/code/host-alieneval.lisp +++ b/src/code/host-alieneval.lisp @@ -611,8 +611,8 @@ kind ; Kind of from mapping, :vector or :alist. offset) ; Offset to add to value for :vector from mapping. -(def-alien-type-translator enum (&whole type - name +(def-alien-type-translator enum (&whole + type name &rest mappings &environment env) (cond (mappings @@ -769,7 +769,8 @@ `(sap-ref-double ,sap (/ ,offset sb!vm:byte-bits))) #!+long-float -(def-alien-type-class (long-float :include (float (:bits #!+x86 96 #!+sparc 128)) +(def-alien-type-class (long-float :include (float (:bits #!+x86 96 + #!+sparc 128)) :include-args (type))) #!+long-float diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 8271e4c..0a97449 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -271,9 +271,6 @@ :operands (list this that))) (deferr object-not-type-error (object type) - (/show0 "entering body of DEFERR OBJECT-NOT-TYPE-ERROR, OBJECT,TYPE=..") - #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr object)) - #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr type)) (error (if (and (typep object 'instance) (layout-invalid (%instance-layout object))) 'layout-invalid diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index dcd15c1..45aa0fb 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -17,27 +17,20 @@ (defconstant pi 3.14159265358979323846264338327950288419716939937511L0) ;(defconstant e 2.71828182845904523536028747135266249775724709369996L0) -;;; Make these INLINE, since the call to C is at least as compact as a Lisp -;;; call, and saves number consing to boot. -;;; -;;; FIXME: This should be (EVAL-WHEN (COMPILE-EVAL) (SB!XC:DEFMACRO ..)), -;;; I think. -(defmacro def-math-rtn (name num-args) - (let ((function (intern (concatenate 'simple-string - "%" - (string-upcase name))))) +;;; Make these INLINE, since the call to C is at least as compact as a +;;; Lisp call, and saves number consing to boot. +(eval-when (:compile-toplevel :execute) + +(sb!xc:defmacro def-math-rtn (name num-args) + (let ((function (symbolicate "%" (string-upcase name)))) `(progn (proclaim '(inline ,function)) - (let ((sb!int::*rogue-export* "DEF-MATH-RTN")) - (export ',function)) (sb!alien:def-alien-routine (,name ,function) double-float - ,@(let ((results nil)) - (dotimes (i num-args (nreverse results)) - (push (list (intern (format nil "ARG-~D" i)) - 'double-float) - results))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(let ((results nil)) + (dotimes (i num-args (nreverse results)) + (push (list (intern (format nil "ARG-~D" i)) + 'double-float) + results))))))) (defun handle-reals (function var) `((((foreach fixnum single-float bignum ratio)) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 4184077..68ba00d 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -61,14 +61,12 @@ (funcall method type2 type1) (vanilla-intersection type1 type2)))) -;;; This is used by DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 -;;; method. INFO is a list of conses (SUPERCLASS-CLASS . -;;; {GUARD-TYPE-SPECIFIER | NIL}). This will never be called with a -;;; hairy type as TYPE2, since the hairy type TYPE2 method gets first -;;; crack. -;;; -;;; FIXME: Declare this as INLINE, since it's only used in one place. -(defun has-superclasses-complex-subtypep-arg1 (type1 type2 info) +;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1 +;;; method. INFO is a list of conses +;;; (SUPERCLASS-CLASS . {GUARD-TYPE-SPECIFIER | NIL}). +;;; This will never be called with a hairy type as TYPE2, since the +;;; hairy type TYPE2 method gets first crack. +(defun !has-superclasses-complex-subtypep-arg1 (type1 type2 info) (values (and (sb!xc:typep type2 'sb!xc:class) (dolist (x info nil) @@ -94,7 +92,7 @@ ;;; G0,(and G1 (not G0)), (and G2 (not (or G0 G1))). ;;; ;;; WHEN controls when the forms are executed. -(defmacro define-superclasses (type-class-name specs when) +(defmacro !define-superclasses (type-class-name specs when) (let ((type-class (gensym "TYPE-CLASS-")) (info (gensym "INFO"))) `(,when @@ -107,7 +105,7 @@ ',specs))) (setf (type-class-complex-subtypep-arg1 ,type-class) (lambda (type1 type2) - (has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) + (!has-superclasses-complex-subtypep-arg1 type1 type2 ,info))) (setf (type-class-complex-subtypep-arg2 ,type-class) #'delegate-complex-subtypep-arg2) (setf (type-class-complex-intersection ,type-class) @@ -136,17 +134,17 @@ ;; the type of the argument value (type (required-argument) :type ctype)) -(define-type-method (values :simple-subtypep :complex-subtypep-arg1) +(!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) (declare (ignore type2)) (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1))) -(define-type-method (values :complex-subtypep-arg2) +(!define-type-method (values :complex-subtypep-arg2) (type1 type2) (declare (ignore type1)) (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2))) -(define-type-method (values :unparse) (type) +(!define-type-method (values :unparse) (type) (cons 'values (unparse-args-types type))) ;;; Return true if LIST1 and LIST2 have the same elements in the same @@ -167,7 +165,7 @@ (unless val (return (values nil t)))))) -(define-type-method (values :simple-=) (type1 type2) +(!define-type-method (values :simple-=) (type1 type2) (let ((rest1 (args-type-rest type1)) (rest2 (args-type-rest type2))) (cond ((or (args-type-keyp type1) (args-type-keyp type2) @@ -186,7 +184,7 @@ (values-type-optional type2)) (values (and req-val opt-val) (and req-win opt-win)))))))) -(define-type-class function) +(!define-type-class function) ;;; a flag that we can bind to cause complex function types to be ;;; unparsed as FUNCTION. This is useful when we want a type that we @@ -194,7 +192,7 @@ (defvar *unparse-function-type-simplify*) (!cold-init-forms (setq *unparse-function-type-simplify* nil)) -(define-type-method (function :unparse) (type) +(!define-type-method (function :unparse) (type) (if *unparse-function-type-simplify* 'function (list 'function @@ -206,34 +204,34 @@ ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. -(define-type-method (function :simple-subtypep) (type1 type2) +(!define-type-method (function :simple-subtypep) (type1 type2) (declare (ignore type1 type2)) (values t t)) -(define-superclasses function ((function)) !cold-init-forms) +(!define-superclasses function ((function)) !cold-init-forms) ;;; The union or intersection of two FUNCTION types is FUNCTION. -(define-type-method (function :simple-union) (type1 type2) +(!define-type-method (function :simple-union) (type1 type2) (declare (ignore type1 type2)) (specifier-type 'function)) -(define-type-method (function :simple-intersection) (type1 type2) +(!define-type-method (function :simple-intersection) (type1 type2) (declare (ignore type1 type2)) (values (specifier-type 'function) t)) ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: -(define-type-method (function :simple-=) (type1 type2) +(!define-type-method (function :simple-=) (type1 type2) (values (equalp type1 type2) t)) -(define-type-class constant :inherits values) +(!define-type-class constant :inherits values) -(define-type-method (constant :unparse) (type) +(!define-type-method (constant :unparse) (type) `(constant-argument ,(type-specifier (constant-type-type type)))) -(define-type-method (constant :simple-=) (type1 type2) +(!define-type-method (constant :simple-=) (type1 type2) (type= (constant-type-type type1) (constant-type-type type2))) -(def-type-translator constant-argument (type) +(!def-type-translator constant-argument (type) (make-constant-type :type (specifier-type type))) ;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE @@ -291,7 +289,7 @@ (result))) -(def-type-translator function (&optional (args '*) (result '*)) +(!def-type-translator function (&optional (args '*) (result '*)) (let ((res (make-function-type :returns (values-specifier-type result)))) (if (eq args '*) @@ -299,7 +297,7 @@ (parse-args-types args res)) res)) -(def-type-translator values (&rest values) +(!def-type-translator values (&rest values) (let ((res (make-values-type))) (parse-args-types values res) res)) @@ -573,9 +571,9 @@ (eq type2 *empty-type*)) (values nil t)) (t - (invoke-type-method :simple-subtypep :complex-subtypep-arg2 - type1 type2 - :complex-arg1 :complex-subtypep-arg1)))) + (!invoke-type-method :simple-subtypep :complex-subtypep-arg2 + type1 type2 + :complex-arg1 :complex-subtypep-arg1)))) ;;; Just parse the type specifiers and call CSUBTYPE. (defun sb!xc:subtypep (type1 type2) @@ -598,7 +596,7 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) (values t t) - (invoke-type-method :simple-= :complex-= type1 type2))) + (!invoke-type-method :simple-= :complex-= type1 type2))) ;;; Not exactly the negation of TYPE=, since when the relationship is ;;; uncertain, we still return NIL, NIL. This is useful in cases where @@ -622,9 +620,9 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) type1 - (let ((res (invoke-type-method :simple-union :complex-union - type1 type2 - :default :vanilla))) + (let ((res (!invoke-type-method :simple-union :complex-union + type1 type2 + :default :vanilla))) (cond ((eq res :vanilla) (or (vanilla-union type1 type2) (make-union-type (list type1 type2)))) @@ -646,9 +644,9 @@ (declare (type ctype type1 type2)) (if (eq type1 type2) (values type1 t) - (invoke-type-method :simple-intersection :complex-intersection - type1 type2 - :default (values *empty-type* t)))) + (!invoke-type-method :simple-intersection :complex-intersection + type1 type2 + :default (values *empty-type* t)))) ;;; The first value is true unless the types don't intersect. The ;;; second value is true if the first value is definitely correct. NIL @@ -677,8 +675,8 @@ ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to ;;; early-type.lisp by WHN ca. 19990201.) -;;; Take a list of type specifiers, compute the translation and define -;;; it as a builtin type. +;;; Take a list of type specifiers, computing the translation of each +;;; specifier and defining it as a builtin type. (declaim (ftype (function (list) (values)) precompute-types)) (defun precompute-types (specs) (dolist (spec specs) @@ -690,7 +688,7 @@ ;;;; built-in types -(define-type-class named) +(!define-type-class named) (defvar *wild-type*) (defvar *empty-type*) @@ -712,32 +710,32 @@ (frob nil *empty-type*) (frob t *universal-type*))) -(define-type-method (named :simple-=) (type1 type2) +(!define-type-method (named :simple-=) (type1 type2) (values (eq type1 type2) t)) -(define-type-method (named :simple-subtypep) (type1 type2) +(!define-type-method (named :simple-subtypep) (type1 type2) (values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t)) -(define-type-method (named :complex-subtypep-arg1) (type1 type2) +(!define-type-method (named :complex-subtypep-arg1) (type1 type2) (assert (not (hairy-type-p type2))) (values (eq type1 *empty-type*) t)) -(define-type-method (named :complex-subtypep-arg2) (type1 type2) +(!define-type-method (named :complex-subtypep-arg2) (type1 type2) (if (hairy-type-p type1) (values nil nil) (values (not (eq type2 *empty-type*)) t))) -(define-type-method (named :complex-intersection) (type1 type2) +(!define-type-method (named :complex-intersection) (type1 type2) (vanilla-intersection type1 type2)) -(define-type-method (named :unparse) (x) +(!define-type-method (named :unparse) (x) (named-type-name x)) ;;;; hairy and unknown types -(define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) +(!define-type-method (hairy :unparse) (x) (hairy-type-specifier x)) -(define-type-method (hairy :simple-subtypep) (type1 type2) +(!define-type-method (hairy :simple-subtypep) (type1 type2) (let ((hairy-spec1 (hairy-type-specifier type1)) (hairy-spec2 (hairy-type-specifier type2))) (cond ((and (consp hairy-spec1) (eq (car hairy-spec1) 'not) @@ -749,7 +747,7 @@ (t (values nil nil))))) -(define-type-method (hairy :complex-subtypep-arg2) (type1 type2) +(!define-type-method (hairy :complex-subtypep-arg2) (type1 type2) (let ((hairy-spec (hairy-type-specifier type2))) (cond ((and (consp hairy-spec) (eq (car hairy-spec) 'not)) (multiple-value-bind (val win) @@ -760,29 +758,29 @@ (t (values nil nil))))) -(define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) +(!define-type-method (hairy :complex-subtypep-arg1 :complex-=) (type1 type2) (declare (ignore type1 type2)) (values nil nil)) -(define-type-method (hairy :simple-intersection :complex-intersection) +(!define-type-method (hairy :simple-intersection :complex-intersection) (type1 type2) (declare (ignore type2)) (values type1 nil)) -(define-type-method (hairy :complex-union) (type1 type2) +(!define-type-method (hairy :complex-union) (type1 type2) (make-union-type (list type1 type2))) -(define-type-method (hairy :simple-=) (type1 type2) +(!define-type-method (hairy :simple-=) (type1 type2) (if (equal (hairy-type-specifier type1) (hairy-type-specifier type2)) (values t t) (values nil nil))) -(def-type-translator not (&whole whole type) +(!def-type-translator not (&whole whole type) (declare (ignore type)) (make-hairy-type :specifier whole)) -(def-type-translator satisfies (&whole whole fun) +(!def-type-translator satisfies (&whole whole fun) (declare (ignore fun)) (make-hairy-type :specifier whole)) @@ -818,9 +816,9 @@ :high (canonicalise-high-bound high) :enumerable enumerable))) -(define-type-class number) +(!define-type-class number) -(define-type-method (number :simple-=) (type1 type2) +(!define-type-method (number :simple-=) (type1 type2) (values (and (eq (numeric-type-class type1) (numeric-type-class type2)) (eq (numeric-type-format type1) (numeric-type-format type2)) @@ -829,7 +827,7 @@ (equal (numeric-type-high type1) (numeric-type-high type2))) t)) -(define-type-method (number :unparse) (type) +(!define-type-method (number :unparse) (type) (let* ((complexp (numeric-type-complexp type)) (low (numeric-type-low type)) (high (numeric-type-high type)) @@ -969,7 +967,7 @@ (if (,open (car ,n-y) ,n-x) ,n-y ,n-x) (if (,closed ,n-y ,n-x) ,n-y ,n-x)))))) -(define-type-method (number :simple-subtypep) (type1 type2) +(!define-type-method (number :simple-subtypep) (type1 type2) (let ((class1 (numeric-type-class type1)) (class2 (numeric-type-class type2)) (complexp2 (numeric-type-complexp type2)) @@ -1001,7 +999,7 @@ (t (values nil t))))) -(define-superclasses number ((generic-number)) !cold-init-forms) +(!define-superclasses number ((generic-number)) !cold-init-forms) ;;; If the high bound of LOW is adjacent to the low bound of HIGH, ;;; then return true, otherwise NIL. @@ -1041,9 +1039,9 @@ ;;; Return a numeric type that is a supertype for both TYPE1 and TYPE2. ;;; -;;; ### Note: we give up early, so keep from dropping lots of information on +;;; ### Note: we give up early to keep from dropping lots of information on ;;; the floor by returning overly general types. -(define-type-method (number :simple-union) (type1 type2) +(!define-type-method (number :simple-union) (type1 type2) (declare (type numeric-type type1 type2)) (cond ((csubtypep type1 type2) type2) ((csubtypep type2 type1) type1) @@ -1076,7 +1074,7 @@ (setf (info :type :builtin 'number) (make-numeric-type :complexp nil))) -(def-type-translator complex (&optional (spec '*)) +(!def-type-translator complex (&optional (spec '*)) (if (eq spec '*) (make-numeric-type :complexp :complex) (let ((type (specifier-type spec))) @@ -1105,7 +1103,7 @@ type bound)))) -(def-type-translator integer (&optional (low '*) (high '*)) +(!def-type-translator integer (&optional (low '*) (high '*)) (let* ((l (canonicalized-bound low 'integer)) (lb (if (consp l) (1+ (car l)) l)) (h (canonicalized-bound high 'integer)) @@ -1119,7 +1117,7 @@ :high hb))) (defmacro def-bounded-type (type class format) - `(def-type-translator ,type (&optional (low '*) (high '*)) + `(!def-type-translator ,type (&optional (low '*) (high '*)) (let ((lb (canonicalized-bound low ',type)) (hb (canonicalized-bound high ',type))) (unless (numeric-bound-test* lb hb <= <) @@ -1229,7 +1227,7 @@ ;;; appropriate numeric type before maximizing. This avoids possible ;;; confusion due to mixed-type comparisons (but I think the result is ;;; the same). -(define-type-method (number :simple-intersection) (type1 type2) +(!define-type-method (number :simple-intersection) (type1 type2) (declare (type numeric-type type1 type2)) (if (numeric-types-intersect type1 type2) (let* ((class1 (numeric-type-class type1)) @@ -1325,7 +1323,7 @@ ;;;; array types -(define-type-class array) +(!define-type-class array) ;;; What this does depends on the setting of the ;;; *USE-IMPLEMENTATION-TYPES* switch. If true, return the specialized @@ -1336,7 +1334,7 @@ (array-type-specialized-element-type type) (array-type-element-type type))) -(define-type-method (array :simple-=) (type1 type2) +(!define-type-method (array :simple-=) (type1 type2) (values (and (equal (array-type-dimensions type1) (array-type-dimensions type2)) (eq (array-type-complexp type1) @@ -1345,7 +1343,7 @@ (specialized-element-type-maybe type2))) t)) -(define-type-method (array :unparse) (type) +(!define-type-method (array :unparse) (type) (let ((dims (array-type-dimensions type)) (eltype (type-specifier (array-type-element-type type))) (complexp (array-type-complexp type))) @@ -1385,7 +1383,7 @@ `(array ,eltype ,dims) `(simple-array ,eltype ,dims)))))) -(define-type-method (array :simple-subtypep) (type1 type2) +(!define-type-method (array :simple-subtypep) (type1 type2) (let ((dims1 (array-type-dimensions type1)) (dims2 (array-type-dimensions type2)) (complexp2 (array-type-complexp type2))) @@ -1416,7 +1414,7 @@ (t (values nil t))))) -(define-superclasses array +(!define-superclasses array ((string string) (vector vector) (array)) @@ -1451,7 +1449,7 @@ (t (values nil t))))) -(define-type-method (array :simple-intersection) (type1 type2) +(!define-type-method (array :simple-intersection) (type1 type2) (declare (type array-type type1 type2)) (if (array-types-intersect type1 type2) (let ((dims1 (array-type-dimensions type1)) @@ -1499,19 +1497,19 @@ ;;;; MEMBER types -(define-type-class member) +(!define-type-class member) -(define-type-method (member :unparse) (type) +(!define-type-method (member :unparse) (type) (let ((members (member-type-members type))) (if (equal members '(nil)) 'null `(member ,@members)))) -(define-type-method (member :simple-subtypep) (type1 type2) +(!define-type-method (member :simple-subtypep) (type1 type2) (values (subsetp (member-type-members type1) (member-type-members type2)) t)) -(define-type-method (member :complex-subtypep-arg1) (type1 type2) +(!define-type-method (member :complex-subtypep-arg1) (type1 type2) (block PUNT (values (every-type-op ctypep type2 (member-type-members type1) :list-first t) @@ -1520,13 +1518,13 @@ ;;; We punt if the odd type is enumerable and intersects with the ;;; MEMBER type. If not enumerable, then it is definitely not a ;;; subtype of the MEMBER type. -(define-type-method (member :complex-subtypep-arg2) (type1 type2) +(!define-type-method (member :complex-subtypep-arg2) (type1 type2) (cond ((not (type-enumerable type1)) (values nil t)) ((types-intersect type1 type2) (values nil nil)) (t (values nil t)))) -(define-type-method (member :simple-intersection) (type1 type2) +(!define-type-method (member :simple-intersection) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (values (cond ((subsetp mem1 mem2) type1) @@ -1538,7 +1536,7 @@ *empty-type*)))) t))) -(define-type-method (member :complex-intersection) (type1 type2) +(!define-type-method (member :complex-intersection) (type1 type2) (block PUNT (collect ((members)) (let ((mem2 (member-type-members type2))) @@ -1557,7 +1555,7 @@ ;;; We don't need a :COMPLEX-UNION, since the only interesting case is a union ;;; type, and the member/union interaction is handled by the union type ;;; method. -(define-type-method (member :simple-union) (type1 type2) +(!define-type-method (member :simple-union) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (cond ((subsetp mem1 mem2) type2) @@ -1565,13 +1563,13 @@ (t (make-member-type :members (union mem1 mem2)))))) -(define-type-method (member :simple-=) (type1 type2) +(!define-type-method (member :simple-=) (type1 type2) (let ((mem1 (member-type-members type1)) (mem2 (member-type-members type2))) (values (and (subsetp mem1 mem2) (subsetp mem2 mem1)) t))) -(define-type-method (member :complex-=) (type1 type2) +(!define-type-method (member :complex-=) (type1 type2) (if (type-enumerable type1) (multiple-value-bind (val win) (csubtypep type2 type1) (if (or val (not win)) @@ -1579,7 +1577,7 @@ (values nil t))) (values nil t))) -(def-type-translator member (&rest members) +(!def-type-translator member (&rest members) (if members (make-member-type :members (remove-duplicates members)) *empty-type*)) @@ -1592,10 +1590,10 @@ (declare (list types)) (%make-union-type (every #'type-enumerable types) types)) -(define-type-class union) +(!define-type-class union) ;;; If LIST, then return that, otherwise the OR of the component types. -(define-type-method (union :unparse) (type) +(!define-type-method (union :unparse) (type) (declare (type ctype type)) (if (type= type (specifier-type 'list)) 'list @@ -1603,7 +1601,7 @@ ;;; Two union types are equal if every type in one is equal to some ;;; type in the other. -(define-type-method (union :simple-=) (type1 type2) +(!define-type-method (union :simple-=) (type1 type2) (block PUNT (let ((types1 (union-type-types type1)) (types2 (union-type-types type2))) @@ -1617,7 +1615,7 @@ ;;; Similarly, a union type is a subtype of another if every element ;;; of TYPE1 is a subtype of some element of TYPE2. -(define-type-method (union :simple-subtypep) (type1 type2) +(!define-type-method (union :simple-subtypep) (type1 type2) (block PUNT (let ((types2 (union-type-types type2))) (values (dolist (type1 (union-type-types type1) t) @@ -1625,17 +1623,17 @@ (return nil))) t)))) -(define-type-method (union :complex-subtypep-arg1) (type1 type2) +(!define-type-method (union :complex-subtypep-arg1) (type1 type2) (block PUNT (values (every-type-op csubtypep type2 (union-type-types type1) :list-first t) t))) -(define-type-method (union :complex-subtypep-arg2) (type1 type2) +(!define-type-method (union :complex-subtypep-arg2) (type1 type2) (block PUNT (values (any-type-op csubtypep type1 (union-type-types type2)) t))) -(define-type-method (union :complex-union) (type1 type2) +(!define-type-method (union :complex-union) (type1 type2) (let* ((class1 (type-class-info type1))) (collect ((res)) (let ((this-type type1)) @@ -1656,12 +1654,12 @@ ;;; For the union of union types, we let the :COMPLEX-UNION method do ;;; the work. -(define-type-method (union :simple-union) (type1 type2) +(!define-type-method (union :simple-union) (type1 type2) (let ((res type1)) (dolist (t2 (union-type-types type2) res) (setq res (type-union res t2))))) -(define-type-method (union :simple-intersection :complex-intersection) +(!define-type-method (union :simple-intersection :complex-intersection) (type1 type2) (let ((res *empty-type*) (win t)) @@ -1670,7 +1668,7 @@ (setq res (type-union res int)) (unless w (setq win nil)))))) -(def-type-translator or (&rest types) +(!def-type-translator or (&rest types) (reduce #'type-union (mapcar #'specifier-type types) :initial-value *empty-type*)) @@ -1679,7 +1677,7 @@ ;;; reasonable type intersections is always describable as a union of ;;; simple types. If something is too hairy to fit this mold, then we ;;; make a hairy type. -(def-type-translator and (&whole spec &rest types) +(!def-type-translator and (&whole spec &rest types) (let ((res *wild-type*)) (dolist (type types res) (let ((ctype (specifier-type type))) @@ -1690,13 +1688,13 @@ ;;;; CONS types -(define-type-class cons) +(!define-type-class cons) -(def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) +(!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) (make-cons-type (specifier-type car-type-spec) (specifier-type cdr-type-spec))) -(define-type-method (cons :unparse) (type) +(!define-type-method (cons :unparse) (type) (let ((car-eltype (type-specifier (cons-type-car-type type))) (cdr-eltype (type-specifier (cons-type-cdr-type type)))) (if (and (member car-eltype '(t *)) @@ -1704,12 +1702,12 @@ 'cons `(cons ,car-eltype ,cdr-eltype)))) -(define-type-method (cons :simple-=) (type1 type2) +(!define-type-method (cons :simple-=) (type1 type2) (declare (type cons-type type1 type2)) (and (type= (cons-type-car-type type1) (cons-type-car-type type2)) (type= (cons-type-cdr-type type1) (cons-type-cdr-type type2)))) -(define-type-method (cons :simple-subtypep) (type1 type2) +(!define-type-method (cons :simple-subtypep) (type1 type2) (declare (type cons-type type1 type2)) (multiple-value-bind (val-car win-car) (csubtypep (cons-type-car-type type1) (cons-type-car-type type2)) @@ -1721,7 +1719,7 @@ ;;; Give up if a precise type is not possible, to avoid returning ;;; overly general types. -(define-type-method (cons :simple-union) (type1 type2) +(!define-type-method (cons :simple-union) (type1 type2) (declare (type cons-type type1 type2)) (let ((car-type1 (cons-type-car-type type1)) (car-type2 (cons-type-car-type type2)) @@ -1734,7 +1732,7 @@ (make-cons-type (type-union cdr-type1 cdr-type2) cdr-type1))))) -(define-type-method (cons :simple-intersection) (type1 type2) +(!define-type-method (cons :simple-intersection) (type1 type2) (declare (type cons-type type1 type2)) (multiple-value-bind (int-car win-car) (type-intersection (cons-type-car-type type1) @@ -1798,13 +1796,13 @@ (t (make-union-type (res))))))) -(def-type-translator array (&optional (element-type '*) +(!def-type-translator array (&optional (element-type '*) (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :element-type (specifier-type element-type)))) -(def-type-translator simple-array (&optional (element-type '*) +(!def-type-translator simple-array (&optional (element-type '*) (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) diff --git a/src/code/show.lisp b/src/code/show.lisp index 56a128d..c786dea 100644 --- a/src/code/show.lisp +++ b/src/code/show.lisp @@ -11,39 +11,6 @@ ;;;; files for more information. (in-package "SB!INT") - -;;; FIXME: Look for any other calls to %PRIMITIVE PRINT and check whether -;;; any of them need removing too. - -;;;; FIXME: Remove this after all in-the-flow-of-control EXPORTs -;;;; have been cleaned up. - -(defvar *rogue-export*) - -;;;; FILE-COMMENT - -;;;; FILE-COMMENT arguably doesn't belong in this file, even though -;;;; it's sort of for displaying information about the system. -;;;; However, it's convenient to put it in this file, since we'd like -;;;; this file to be the first file in the system, and we'd like to be -;;;; able to use FILE-COMMENT in this file. - -;;; The real implementation of SB!INT:FILE-COMMENT is a special form, -;;; but this macro expansion for it is still useful for -;;; (1) documentation, -;;; (2) code walkers, and -;;; (3) compiling the cross-compiler itself under the cross-compilation -;;; host ANSI Common Lisp. -(defmacro file-comment (string) - #!+sb-doc - "FILE-COMMENT String - When COMPILE-FILE sees this form at top-level, it places the constant string - in the run-time source location information. DESCRIBE will print the file - comment for the file that a function was defined in. The string is also - textually present in the FASL, so the RCS \"ident\" command can find it, - etc." - (declare (ignore string)) - '(values)) ;;;; various SB-SHOW-dependent forms diff --git a/src/code/signal.lisp b/src/code/signal.lisp index 46679aa..2ededa6 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -125,9 +125,7 @@ ;; old code which expects the symbol with the same print name as ;; our keywords to be a constant with a value equal to the signal ;; number. - (defconstant ,symbol ,number ,description) - (let ((sb!int::*rogue-export* "DEF-MATH-RTN")) - (export ',symbol))))) + (defconstant ,symbol ,number ,description)))) (defun unix-signal-or-lose (arg) (let ((signal (find arg *unix-signals* diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 284f73e..3c210e5 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -394,11 +394,6 @@ possible-init-file-names) (/show0 "leaving PROBE-INIT-FILES")))) (let* ((sbcl-home (posix-getenv "SBCL_HOME")) - #!+sb-show(ignore1 (progn - (/show0 "SBCL-HOME=..") - (if sbcl-home - (%primitive print sbcl-home) - (%primitive print "NIL")))) (sysinit-truename (if sbcl-home (probe-init-files sysinit (concatenate @@ -411,9 +406,6 @@ (user-home (or (posix-getenv "HOME") (error "The HOME environment variable is unbound, ~ so user init file can't be found."))) - #!+sb-show(ignore2 (progn - (/show0 "USER-HOME=..") - (%primitive print user-home))) (userinit-truename (probe-init-files userinit (concatenate 'string @@ -421,15 +413,11 @@ "/.sbclrc")))) (/show0 "assigned SYSINIT-TRUENAME and USERINIT-TRUENAME") (when sysinit-truename - (/show0 "SYSINIT-TRUENAME=..") - #!+sb-show (%primitive print sysinit-truename) (unless (load sysinit-truename) (error "~S was not successfully loaded." sysinit-truename)) (flush-standard-output-streams)) (/show0 "loaded SYSINIT-TRUENAME") (when userinit-truename - (/show0 "USERINIT-TRUENAME=..") - #!+sb-show (%primitive print userinit-truename) (unless (load userinit-truename) (error "~S was not successfully loaded." userinit-truename)) (flush-standard-output-streams)) diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp index df1512c..6567e42 100644 --- a/src/code/type-class.lisp +++ b/src/code/type-class.lisp @@ -142,7 +142,7 @@ ) ; EVAL-WHEN -(defmacro define-type-method ((class method &rest more-methods) +(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*" @@ -157,7 +157,7 @@ (cons method more-methods))) ',name))) -(defmacro define-type-class (name &key inherits) +(defmacro !define-type-class (name &key inherits) `(!cold-init-forms ,(once-only ((n-class (if inherits `(copy-type-class-coldly (type-class-or-lose @@ -168,13 +168,14 @@ (setf (gethash ',name *type-classes*) ,n-class) ',name)))) -;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same -;;; class, invoke the simple method. Otherwise, invoke any complex method. If -;;; there isn't a distinct COMPLEX-ARG1 method, then swap the arguments when -;;; calling TYPE1's method. If no applicable method, return DEFAULT. -(defmacro invoke-type-method (simple complex-arg2 type1 type2 &key - (default '(values nil t)) - (complex-arg1 :foo complex-arg1-p)) +;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the +;;; same class, invoke the simple method. Otherwise, invoke any +;;; complex method. If there isn't a distinct COMPLEX-ARG1 method, +;;; then swap the arguments when calling TYPE1's method. If no +;;; applicable method, return DEFAULT. +(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key + (default '(values nil t)) + (complex-arg1 :foo complex-arg1-p)) (declare (type keyword simple complex-arg1 complex-arg2)) `(multiple-value-bind (result-a result-b valid-p) (%invoke-type-method ',(class-function-slot-or-lose simple) @@ -190,16 +191,17 @@ (values result-a result-b) ,default))) -;;; most of the implementation of INVOKE-TYPE-METHOD +;;; most of the implementation of !INVOKE-TYPE-METHOD ;;; -;;; KLUDGE: This function must be INLINE in order for cold init to work, -;;; because the first three arguments are TYPE-CLASS structure accessor -;;; functions whose calls have to be compiled inline in order to work in calls -;;; to this function early in cold init. So don't conditionalize this INLINE -;;; declaration with #!+SB-FLUID or anything, unless you also rearrange things -;;; to cause the full function definitions of the relevant structure accessors -;;; to be available sufficiently early in cold init. -- WHN 19991015 -#!-sb-fluid (declaim (inline %invoke-type-method)) +;;; KLUDGE: This function must be INLINE in order for cold init to +;;; work, because the first three arguments are TYPE-CLASS structure +;;; accessor functions whose calls have to be compiled inline in order +;;; to work in calls to this function early in cold init. So don't +;;; conditionalize this INLINE declaration with #!-SB-FLUID or +;;; anything, unless you also rearrange things to cause the full +;;; function definitions of the relevant structure accessors to be +;;; available sufficiently early in cold init. -- WHN 19991015 +(declaim (inline %invoke-type-method)) (defun %invoke-type-method (simple cslot1 cslot2 complex-arg1-p type1 type2) (declare (type symbol simple cslot1 cslot2)) (multiple-value-bind (result-a result-b) @@ -215,11 +217,11 @@ (if complex-arg1-p (funcall complex1 type1 type2) (funcall complex1 type2 type1)) - ;; No meaningful result was found: the caller should use the - ;; default value instead. + ;; No meaningful result was found: the caller should + ;; use the default value instead. (return-from %invoke-type-method (values nil nil nil)))))))) - ;; If we get to here (without breaking out by calling RETURN-FROM) then - ;; a meaningful result was found, and we return it. + ;; If we get to here (without breaking out by calling RETURN-FROM) + ;; then a meaningful result was found, and we return it. (values result-a result-b t))) (!defun-from-collected-cold-init-forms !type-class-cold-init) diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index e6bce47..b160271 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -26,7 +26,7 @@ ;;; Define the translation from a type-specifier to a type structure for ;;; some particular type. Syntax is identical to DEFTYPE. -(defmacro def-type-translator (name arglist &body body) +(defmacro !def-type-translator (name arglist &body body) (check-type name symbol) ;; FIXME: Now that the T%CL hack is ancient history and we just use CL ;; instead, we can probably return to using PARSE-DEFMACRO here. diff --git a/src/compiler/backend.lisp b/src/compiler/backend.lisp index 9a58ec8..ef13dc7 100644 --- a/src/compiler/backend.lisp +++ b/src/compiler/backend.lisp @@ -225,7 +225,7 @@ (defprinter (vm-support-routines)) -(defmacro def-vm-support-routine (name ll &body body) +(defmacro !def-vm-support-routine (name ll &body body) (unless (member (intern (string name) (find-package "SB!C")) *vm-support-routines*) (warn "unknown VM support routine: ~A" name)) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index e727624..2a91eda 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -37,10 +37,10 @@ (t call-cost)))) call-cost))) -;;; Return some sort of guess for the cost of doing a test against TYPE. -;;; The result need not be precise as long as it isn't way out in space. The -;;; units are based on the costs specified for various templates in the VM -;;; definition. +;;; Return some sort of guess for the cost of doing a test against +;;; TYPE. The result need not be precise as long as it isn't way out +;;; in space. The units are based on the costs specified for various +;;; templates in the VM definition. (defun type-test-cost (type) (declare (type ctype type)) (or (let ((check (type-check-template type))) @@ -67,19 +67,26 @@ (+ 1 (if (numeric-type-low type) 1 0) (if (numeric-type-high type) 1 0)))) + (cons-type + (+ (type-test-cost (specifier-type 'cons)) + (function-cost 'car) + (type-test-cost (cons-type-car-type type)) + (function-cost 'cdr) + (type-test-cost (cons-type-cdr-type type)))) (t (function-cost 'typep))))) ;;;; checking strategy determination -;;; Return the type we should test for when we really want to check for -;;; Type. If speed, space or compilation speed is more important than safety, -;;; then we return a weaker type if it is easier to check. First we try the -;;; defined type weakenings, then look for any predicate that is cheaper. +;;; Return the type we should test for when we really want to check +;;; for TYPE. If speed, space or compilation speed is more important +;;; than safety, then we return a weaker type if it is easier to +;;; check. First we try the defined type weakenings, then look for any +;;; predicate that is cheaper. ;;; -;;; If the supertype is equal in cost to the type, we prefer the supertype. -;;; This produces a closer approximation of the right thing in the presence of -;;; poor cost info. +;;; If the supertype is equal in cost to the type, we prefer the +;;; supertype. This produces a closer approximation of the right thing +;;; in the presence of poor cost info. (defun maybe-weaken-check (type cont) (declare (type ctype type) (type continuation cont)) (cond ((policy (continuation-dest cont) @@ -96,8 +103,9 @@ (let ((stype-cost (type-test-cost stype))) (when (or (< stype-cost min-cost) (type= stype type)) - (setq found-super t) - (setq min-type stype min-cost stype-cost)))))) + (setq found-super t + min-type stype + min-cost stype-cost)))))) (if found-super min-type *universal-type*))))) @@ -116,20 +124,25 @@ ;;; Switch to disable check complementing, for evaluation. (defvar *complement-type-checks* t) -;;; Cont is a continuation we are doing a type check on and Types is a list -;;; of types that we are checking its values against. If we have proven -;;; that Cont generates a fixed number of values, then for each value, we check -;;; whether it is cheaper to then difference between the proven type and -;;; the corresponding type in Types. If so, we opt for a :HAIRY check with -;;; that test negated. Otherwise, we try to do a simple test, and if that is -;;; impossible, we do a hairy test with non-negated types. If true, -;;; Force-Hairy forces a hairy type check. +;;; CONT is a continuation we are doing a type check on and TYPES is a +;;; list of types that we are checking its values against. If we have +;;; proven that CONT generates a fixed number of values, then for each +;;; value, we check whether it is cheaper to then difference between +;;; the proven type and the corresponding type in TYPES. If so, we opt +;;; for a :HAIRY check with that test negated. Otherwise, we try to do +;;; a simple test, and if that is impossible, we do a hairy test with +;;; non-negated types. If true, Force-Hairy forces a hairy type check. ;;; -;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to weaken the -;;; test to a convenient supertype (conditional on policy.) If debug-info is -;;; not particularly important (debug <= 1) or speed is 3, then we allow -;;; weakened checks to be simple, resulting in less informative error messages, -;;; but saving space and possibly time. +;;; When doing a non-negated check, we call MAYBE-WEAKEN-CHECK to +;;; weaken the test to a convenient supertype (conditional on policy.) +;;; If SPEED is 3, or DEBUG-INFO is not particularly important (DEBUG +;;; <= 1), then we allow weakened checks to be simple, resulting in +;;; less informative error messages, but saving space and possibly +;;; time. +;;; +;;; FIXME: I don't quite understand this, but it looks as though +;;; that means type checks are weakened when SPEED=3 regardless of +;;; the SAFETY level, which is not the right thing to do. (defun maybe-negate-check (cont types force-hairy) (declare (type continuation cont) (list types)) (multiple-value-bind (ptypes count) @@ -164,37 +177,40 @@ (t (values :hairy res))))))) -;;; Determines whether Cont's assertion is: -;;; -- Checkable by the back end (:SIMPLE), or -;;; -- Not checkable by the back end, but checkable via an explicit test in -;;; type check conversion (:HAIRY), or +;;; Determines whether CONT's assertion is: +;;; -- checkable by the back end (:SIMPLE), or +;;; -- not checkable by the back end, but checkable via an explicit +;;; test in type check conversion (:HAIRY), or ;;; -- not reasonably checkable at all (:TOO-HAIRY). ;;; -;;; A type is checkable if it either represents a fixed number of values (as -;;; determined by VALUES-TYPES), or it is the assertion for an MV-Bind. A type -;;; is simply checkable if all the type assertions have a TYPE-CHECK-TEMPLATE. -;;; In this :SIMPLE case, the second value is a list of the type restrictions -;;; specified for the leading positional values. +;;; A type is checkable if it either represents a fixed number of +;;; values (as determined by VALUES-TYPES), or it is the assertion for +;;; an MV-Bind. A type is simply checkable if all the type assertions +;;; have a TYPE-CHECK-TEMPLATE. In this :SIMPLE case, the second value +;;; is a list of the type restrictions specified for the leading +;;; positional values. ;;; -;;; We force a check to be hairy even when there are fixed values if we are in -;;; a context where we may be forced to use the unknown values convention -;;; anyway. This is because IR2tran can't generate type checks for unknown -;;; values continuations but people could still be depending on the check being -;;; done. We only care about EXIT and RETURN (not MV-COMBINATION) since these -;;; are the only contexts where the ultimate values receiver +;;; We force a check to be hairy even when there are fixed values if +;;; we are in a context where we may be forced to use the unknown +;;; values convention anyway. This is because IR2tran can't generate +;;; type checks for unknown values continuations but people could +;;; still be depending on the check being done. We only care about +;;; EXIT and RETURN (not MV-COMBINATION) since these are the only +;;; contexts where the ultimate values receiver ;;; -;;; In the :HAIRY case, the second value is a list of triples of the form: -;;; (Not-P Type Original-Type) +;;; In the :HAIRY case, the second value is a list of triples of +;;; the form: +;;; (NOT-P TYPE ORIGINAL-TYPE) ;;; -;;; If true, the Not-P flag indicates a test that the corresponding value is -;;; *not* of the specified Type. Original-Type is the type asserted on this -;;; value in the continuation, for use in error messages. When Not-P is true, -;;; this will be different from Type. +;;; If true, the NOT-P flag indicates a test that the corresponding +;;; value is *not* of the specified TYPE. ORIGINAL-TYPE is the type +;;; asserted on this value in the continuation, for use in error +;;; messages. When NOT-P is true, this will be different from TYPE. ;;; -;;; This allows us to take what has been proven about Cont's type into -;;; consideration. If it is cheaper to test for the difference between the -;;; derived type and the asserted type, then we check for the negation of this -;;; type instead. +;;; This allows us to take what has been proven about CONT's type into +;;; consideration. If it is cheaper to test for the difference between +;;; the derived type and the asserted type, then we check for the +;;; negation of this type instead. (defun continuation-check-types (cont) (declare (type continuation cont)) (let ((type (continuation-asserted-type cont)) @@ -217,29 +233,31 @@ (t (values :too-hairy nil)))))) -;;; Return true if Cont is a continuation whose type the back end is likely -;;; to want to check. Since we don't know what template the back end is going -;;; to choose to implement the continuation's DEST, we use a heuristic. We -;;; always return T unless: -;;; -- Nobody uses the value, or -;;; -- Safety is totally unimportant, or +;;; Return true if CONT is a continuation whose type the back end is +;;; likely to want to check. Since we don't know what template the +;;; back end is going to choose to implement the continuation's DEST, +;;; we use a heuristic. We always return T unless: +;;; -- nobody uses the value, or +;;; -- safety is totally unimportant, or ;;; -- the continuation is an argument to an unknown function, or -;;; -- the continuation is an argument to a known function that has no -;;; IR2-Convert method or :fast-safe templates that are compatible with the -;;; call's type. +;;; -- the continuation is an argument to a known function that has +;;; no IR2-Convert method or :FAST-SAFE templates that are +;;; compatible with the call's type. ;;; -;;; We must only return nil when it is *certain* that a check will not be done, -;;; since if we pass up this chance to do the check, it will be too late. The -;;; penalty for being too conservative is duplicated type checks. +;;; We must only return NIL when it is *certain* that a check will not +;;; be done, since if we pass up this chance to do the check, it will +;;; be too late. The penalty for being too conservative is duplicated +;;; type checks. ;;; -;;; If there is a compile-time type error, then we always return true unless -;;; the DEST is a full call. With a full call, the theory is that the type -;;; error is probably from a declaration in (or on) the callee, so the callee -;;; should be able to do the check. We want to let the callee do the check, -;;; because it is possible that the error is really in the callee, not the -;;; caller. We don't want to make people recompile all calls to a function -;;; when they were originally compiled with a bad declaration (or an old type -;;; assertion derived from a definition appearing after the call.) +;;; If there is a compile-time type error, then we always return true +;;; unless the DEST is a full call. With a full call, the theory is +;;; that the type error is probably from a declaration in (or on) the +;;; callee, so the callee should be able to do the check. We want to +;;; let the callee do the check, because it is possible that the error +;;; is really in the callee, not the caller. We don't want to make +;;; people recompile all calls to a function when they were originally +;;; compiled with a bad declaration (or an old type assertion derived +;;; from a definition appearing after the call.) (defun probable-type-check-p (cont) (declare (type continuation cont)) (let ((dest (continuation-dest cont))) @@ -265,17 +283,18 @@ (t t)))) ;;; Return a form that we can convert to do a hairy type check of the -;;; specified Types. Types is a list of the format returned by -;;; Continuation-Check-Types in the :HAIRY case. In place of the actual -;;; value(s) we are to check, we use 'DUMMY. This constant reference is later -;;; replaced with the actual values continuation. +;;; specified TYPES. TYPES is a list of the format returned by +;;; CONTINUATION-CHECK-TYPES in the :HAIRY case. In place of the +;;; actual value(s) we are to check, we use 'DUMMY. This constant +;;; reference is later replaced with the actual values continuation. ;;; -;;; Note that we don't attempt to check for required values being unsupplied. -;;; Such checking is impossible to efficiently do at the source level because -;;; our fixed-values conventions are optimized for the common MV-Bind case. +;;; Note that we don't attempt to check for required values being +;;; unsupplied. Such checking is impossible to efficiently do at the +;;; source level because our fixed-values conventions are optimized +;;; for the common MV-BIND case. ;;; -;;; We can always use Multiple-Value-Bind, since the macro is clever about -;;; binding a single variable. +;;; We can always use MULTIPLE-VALUE-BIND, since the macro is clever +;;; about binding a single variable. (defun make-type-check-form (types) (let ((temps (make-gensym-list (length types)))) `(multiple-value-bind ,temps 'dummy @@ -292,9 +311,10 @@ types) (values ,@temps)))) -;;; Splice in explicit type check code immediately before the node which is -;;; Cont's Dest. This code receives the value(s) that were being passed to -;;; Cont, checks the type(s) of the value(s), then passes them on to Cont. +;;; Splice in explicit type check code immediately before the node +;;; which is CONT's DEST. This code receives the value(s) that were +;;; being passed to CONT, checks the type(s) of the value(s), then +;;; passes them on to CONT. (defun convert-type-check (cont types) (declare (type continuation cont) (type list types)) (with-ir1-environment (continuation-dest cont) @@ -309,12 +329,12 @@ (continuation-starts-block new-start) (substitute-continuation-uses new-start cont) - ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the check has - ;; been done. + ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the + ;; check has been done. (setf (continuation-%type-check cont) :deleted) - ;; Make the DEST node start its block so that we can splice in the - ;; type check code. + ;; Make the DEST node start its block so that we can splice in + ;; the type check code. (when (continuation-use prev) (node-ends-block (continuation-use prev))) @@ -322,20 +342,20 @@ (new-block (continuation-block new-start)) (dummy (make-continuation))) - ;; Splice in the new block before DEST, giving the new block all of - ;; DEST's predecessors. + ;; Splice in the new block before DEST, giving the new block + ;; all of DEST's predecessors. (dolist (block (block-pred prev-block)) (change-block-successor block prev-block new-block)) - ;; Convert the check form, using the new block start as START and a - ;; dummy continuation as CONT. + ;; Convert the check form, using the new block start as START + ;; and a dummy continuation as CONT. (ir1-convert new-start dummy (make-type-check-form types)) ;; TO DO: Why should this be true? -- WHN 19990601 (assert (eq (continuation-block dummy) new-block)) - ;; KLUDGE: Comments at the head of this function in CMU CL said that - ;; somewhere in here we + ;; KLUDGE: Comments at the head of this function in CMU CL + ;; said that somewhere in here we ;; Set the new block's start and end cleanups to the *start* ;; cleanup of PREV's block. This overrides the incorrect ;; default from WITH-IR1-ENVIRONMENT. @@ -345,21 +365,22 @@ (let ((node (continuation-use dummy))) (setf (block-last new-block) node) - ;; Change the use to a use of CONT. (We need to use the dummy - ;; continuation to get the control transfer right, because we want to - ;; go to PREV's block, not CONT's.) + ;; Change the use to a use of CONT. (We need to use the + ;; dummy continuation to get the control transfer right, + ;; because we want to go to PREV's block, not CONT's.) (delete-continuation-use node) (add-continuation-use node cont)) ;; Link the new block to PREV's block. (link-blocks new-block prev-block)) - ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type of - ;; 'DUMMY, not a real form. At this point we convert to the real form by - ;; finding 'DUMMY and overwriting it with the new continuation. (We can - ;; find 'DUMMY because no LET conversion has been done yet.) The - ;; [mv-]combination code from the mv-bind in the check form will be the - ;; use of the new check continuation. We substitute for the first - ;; argument of this node. + ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type + ;; of 'DUMMY, not a real form. At this point we convert to the + ;; real form by finding 'DUMMY and overwriting it with the new + ;; continuation. (We can find 'DUMMY because no LET conversion + ;; has been done yet.) The [mv-]combination code from the + ;; mv-bind in the check form will be the use of the new check + ;; continuation. We substitute for the first argument of this + ;; node. (let* ((node (continuation-use cont)) (args (basic-combination-args node)) (victim (first args))) @@ -375,10 +396,11 @@ (values)) -;;; Emit a type warning for Node. If the value of node is being used for a -;;; variable binding, we figure out which one for source context. If the value -;;; is a constant, we print it specially. We ignore nodes whose type is NIL, -;;; since they are supposed to never return. +;;; Emit a type warning for NODE. If the value of NODE is being used +;;; for a variable binding, we figure out which one for source +;;; context. If the value is a constant, we print it specially. We +;;; ignore nodes whose type is NIL, since they are supposed to never +;;; return. (defun do-type-warning (node) (declare (type node node)) (let* ((*compiler-error-context* node) @@ -404,12 +426,13 @@ what (type-specifier dtype) atype-spec)))) (values)) -;;; Mark Cont as being a continuation with a manifest type error. We set -;;; the kind to :ERROR, and clear any FUNCTION-INFO if the continuation is an -;;; argument to a known call. The last is done so that the back end doesn't -;;; have to worry about type errors in arguments to known functions. This -;;; clearing is inhibited for things with IR2-CONVERT methods, since we can't -;;; do a full call to funny functions. +;;; Mark CONT as being a continuation with a manifest type error. We +;;; set the kind to :ERROR, and clear any FUNCTION-INFO if the +;;; continuation is an argument to a known call. The last is done so +;;; that the back end doesn't have to worry about type errors in +;;; arguments to known functions. This clearing is inhibited for +;;; things with IR2-CONVERT methods, since we can't do a full call to +;;; funny functions. (defun mark-error-continuation (cont) (declare (type continuation cont)) (setf (continuation-%type-check cont) :error) @@ -422,27 +445,29 @@ (setf (basic-combination-kind dest) :error))) (values)) -;;; Loop over all blocks in Component that have TYPE-CHECK set, looking for -;;; continuations with TYPE-CHECK T. We do two mostly unrelated things: detect -;;; compile-time type errors and determine if and how to do run-time type -;;; checks. +;;; Loop over all blocks in Component that have TYPE-CHECK set, +;;; looking for continuations with TYPE-CHECK T. We do two mostly +;;; unrelated things: detect compile-time type errors and determine if +;;; and how to do run-time type checks. ;;; -;;; If there is a compile-time type error, then we mark the continuation and -;;; emit a warning if appropriate. This part loops over all the uses of the -;;; continuation, since after we convert the check, the :DELETED kind will -;;; inhibit warnings about the types of other uses. +;;; If there is a compile-time type error, then we mark the +;;; continuation and emit a warning if appropriate. This part loops +;;; over all the uses of the continuation, since after we convert the +;;; check, the :DELETED kind will inhibit warnings about the types of +;;; other uses. ;;; -;;; If a continuation is too complex to be checked by the back end, or is -;;; better checked with explicit code, then convert to an explicit test. -;;; Assertions that can checked by the back end are passed through. Assertions -;;; that can't be tested are flamed about and marked as not needing to be -;;; checked. +;;; If a continuation is too complex to be checked by the back end, or +;;; is better checked with explicit code, then convert to an explicit +;;; test. Assertions that can checked by the back end are passed +;;; through. Assertions that can't be tested are flamed about and +;;; marked as not needing to be checked. ;;; -;;; If we determine that a type check won't be done, then we set TYPE-CHECK -;;; to :NO-CHECK. In the non-hairy cases, this is just to prevent us from -;;; wasting time coming to the same conclusion again on a later iteration. In -;;; the hairy case, we must indicate to LTN that it must choose a safe -;;; implementation, since IR2 conversion will choke on the check. +;;; If we determine that a type check won't be done, then we set +;;; TYPE-CHECK to :NO-CHECK. In the non-hairy cases, this is just to +;;; prevent us from wasting time coming to the same conclusion again +;;; on a later iteration. In the hairy case, we must indicate to LTN +;;; that it must choose a safe implementation, since IR2 conversion +;;; will choke on the check. ;;; ;;; The generation of the type checks is delayed until all the type ;;; check decisions have been made because the generation of the type diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp index 0fce8dd..949219c 100644 --- a/src/compiler/debug-dump.lisp +++ b/src/compiler/debug-dump.lisp @@ -247,7 +247,6 @@ (mapcar #'(lambda (x) (let ((res (make-debug-source :from :file - :comment (file-info-comment x) :created (file-info-write-date x) :compiled (source-info-start-time info) :source-root (file-info-source-root x) diff --git a/src/compiler/early-c.lisp b/src/compiler/early-c.lisp index ce2701d..54fe4cf 100644 --- a/src/compiler/early-c.lisp +++ b/src/compiler/early-c.lisp @@ -15,7 +15,7 @@ (in-package "SB!C") -;;; FIXME: Shouldn't SB-C::&MORE be in this list? +;;; 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 diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 355f417..259c781 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -44,7 +44,8 @@ ;;; ;;; 0: inherited from CMU CL ;;; 1: rearranged static symbols for sbcl-0.6.8 -;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support +;;; 2: eliminated non-ANSI %DEFCONSTANT/%%DEFCONSTANT support, +;;; deleted a slot from DEBUG-SOURCE structure (defconstant sbcl-core-version-integer 2) (defun round-up (number size) diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp index 6e6c322..dcbc77b 100644 --- a/src/compiler/generic/primtype.lisp +++ b/src/compiler/generic/primtype.lisp @@ -133,7 +133,7 @@ ;;;; PRIMITIVE-TYPE-OF and friends ;;; Return the most restrictive primitive type that contains Object. -(def-vm-support-routine primitive-type-of (object) +(!def-vm-support-routine primitive-type-of (object) (let ((type (ctype-of object))) (cond ((not (member-type-p type)) (primitive-type type)) ((equal (member-type-members type) '(nil)) @@ -172,9 +172,9 @@ ;;; In a bootstrapping situation, we should be careful to use the ;;; correct values for the system parameters. ;;; -;;; We need an aux function because we need to use both def-vm-support-routine -;;; and defun-cached. -(def-vm-support-routine primitive-type (type) +;;; We need an aux function because we need to use both +;;; !DEF-VM-SUPPORT-ROUTINE and defun-cached. +(!def-vm-support-routine primitive-type (type) (primitive-type-aux type)) (defun-cached (primitive-type-aux :hash-function (lambda (x) @@ -352,11 +352,7 @@ (part-of function)) (base-char (exactly base-char)) - ;; MNA: cons compound-type patch - ;; FIXIT: all commented out -; (cons-type -; (part-of list)) - (cons + (cons-type (part-of list)) (t (any)))) diff --git a/src/compiler/generic/vm-macs.lisp b/src/compiler/generic/vm-macs.lisp index 0d50cf4..072ae89 100644 --- a/src/compiler/generic/vm-macs.lisp +++ b/src/compiler/generic/vm-macs.lisp @@ -117,8 +117,6 @@ (forms `(def-alloc ,alloc-trans ,offset ,variable-length ,header ,lowtag ',(inits)))) `(progn - (let ((sb!int::*rogue-export* "DEFINE-PRIMITIVE-OBJECT")) - (export ',(exports))) (eval-when (:compile-toplevel :load-toplevel :execute) (%define-primitive-object ',(make-primitive-object :name name diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp index fcb8570..a24de41 100644 --- a/src/compiler/generic/vm-type.lisp +++ b/src/compiler/generic/vm-type.lisp @@ -154,26 +154,19 @@ (when (csubtypep subtype (specifier-type type)) (return type)))) -;;; If Type has a CHECK-xxx template, but doesn't have a corresponding -;;; primitive-type, then return the template's name. Otherwise, return NIL. +;;; If TYPE has a CHECK-xxx template, but doesn't have a corresponding +;;; PRIMITIVE-TYPE, then return the template's name. Otherwise, return NIL. (defun hairy-type-check-template-name (type) (declare (type ctype type)) (typecase type - ;; MNA: cons compound-type - ;; FIXIT: all commented out -; (cons-type -; (if (type= type (specifier-type 'cons)) -; 'sb!c:check-cons -; nil)) -; (built-in-class -; (if (type= type (specifier-type 'symbol)) -; 'sb!c:check-symbol -; nil)) - (named-type - (case (named-type-name type) - (cons 'sb!c:check-cons) - (symbol 'sb!c:check-symbol) - (t nil))) + (cons-type + (if (type= type (specifier-type 'cons)) + 'sb!c:check-cons + nil)) + (built-in-class + (if (type= type (specifier-type 'symbol)) + 'sb!c:check-symbol + nil)) (numeric-type (cond ((type= type (specifier-type 'fixnum)) 'sb!c:check-fixnum) diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 4717b0f..55dde29 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -662,8 +662,6 @@ (untruename nil :type (or pathname null)) ;; The file's write date (if relevant.) (write-date nil :type (or unsigned-byte null)) - ;; This file's FILE-COMMENT, or NIL if none. - (comment nil :type (or simple-string null)) ;; The source path root number of the first form in this file (i.e. the ;; total number of forms converted previously in this compilation.) (source-root 0 :type unsigned-byte) @@ -934,26 +932,10 @@ (*default-interface-cookie* (lexenv-interface-cookie *lexenv*))) (process-top-level-progn forms path)))) -;;; Stash file comment in the FILE-INFO structure. -(defun process-file-comment (form) - (unless (and (proper-list-of-length-p form 2) - (stringp (second form))) - (compiler-error "bad FILE-COMMENT form: ~S" form)) - (let ((file (first (source-info-current-file *source-info*)))) - (cond ((file-info-comment file) - ;; MNA: compiler message patch - (pprint-logical-block (*error-output* nil :per-line-prefix "; ") - (compiler-warning "Ignoring extra file comment:~% ~S." form))) - (t - (let ((comment (coerce (second form) 'simple-string))) - (setf (file-info-comment file) comment) - (when sb!xc:*compile-verbose* - ;; MNA: compiler message patch - (compiler-mumble "~&; FILE-COMMENT: ~A~2&" comment))))))) - -;;; Force any pending top-level forms to be compiled and dumped so that they -;;; will be evaluated in the correct package environment. Dump the form to be -;;; evaled at (cold) load time, and if EVAL is true, eval the form immediately. +;;; Force any pending top-level forms to be compiled and dumped so +;;; that they will be evaluated in the correct package environment. +;;; Dump the form to be evaled at (cold) load time, and if EVAL is +;;; true, eval the form immediately. (defun process-cold-load-form (form path eval) (let ((object *compile-object*)) (etypecase object @@ -1020,7 +1002,6 @@ (process-top-level-progn (cddr form) path)))) (locally (process-top-level-locally form path)) (progn (process-top-level-progn (cdr form) path)) - (file-comment (process-file-comment form)) (t (let* ((uform (uncross form)) (exp (preprocessor-macroexpand uform))) diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 3bd162c..aa6fc0d 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -704,3 +704,21 @@ (declare (type index start ,@(all-lengths))) ,@(forms) res)))) + +;;;; CONS accessor DERIVE-TYPE optimizers + +(defoptimizer (car derive-type) ((cons)) + (let ((type (continuation-type cons)) + (null-type (specifier-type 'null))) + (cond ((eq type null-type) + null-type) + ((cons-type-p type) + (cons-type-car-type type))))) + +(defoptimizer (cdr derive-type) ((cons)) + (let ((type (continuation-type cons)) + (null-type (specifier-type 'null))) + (cond ((eq type null-type) + null-type) + ((cons-type-p type) + (cons-type-cdr-type type))))) diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index b0160e4..4efe8e2 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -298,6 +298,25 @@ `(typep ,n-obj ',(type-specifier x))) types))))))) +;;; If necessary recurse to check the cons type. +(defun source-transform-cons-typep (object type) + (let* ((car-type (cons-type-car-type type)) + (cdr-type (cons-type-cdr-type type))) + (let ((car-test-p (not (or (type= car-type *wild-type*) + (type= car-type (specifier-type t))))) + (cdr-test-p (not (or (type= cdr-type *wild-type*) + (type= cdr-type (specifier-type t)))))) + (if (and (not car-test-p) (not cdr-test-p)) + `(consp ,object) + (once-only ((n-obj object)) + `(and (consp ,n-obj) + ,@(if car-test-p + `((typep (car ,n-obj) + ',(type-specifier car-type)))) + ,@(if cdr-test-p + `((typep (cdr ,n-obj) + ',(type-specifier cdr-type)))))))))) + ;;; Return the predicate and type from the most specific entry in ;;; *TYPE-PREDICATES* that is a supertype of TYPE. (defun find-supertype-predicate (type) @@ -495,6 +514,8 @@ `(%instance-typep ,object ,spec)) (array-type (source-transform-array-typep object type)) + (cons-type + (source-transform-cons-typep object type)) (t nil))) `(%typep ,object ,spec))) (values nil t))) @@ -520,6 +541,7 @@ (give-up-ir1-transform))))))) ;;; KLUDGE: new broken version -- 20000504 +;;; FIXME: should be fixed or deleted #+nil (deftransform coerce ((x type) (* *) * :when :both) (unless (constant-continuation-p type) diff --git a/src/compiler/x86/backend-parms.lisp b/src/compiler/x86/backend-parms.lisp index b891618..ba1fda3 100644 --- a/src/compiler/x86/backend-parms.lisp +++ b/src/compiler/x86/backend-parms.lisp @@ -29,7 +29,8 @@ ;;; fasl files would fail, because there are no DEFUNs for these ;;; operations any more.) ;;; 5 = sbcl-0.6.8 has rearranged static symbols. -;;; 6 = sbcl-0.6.9 got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff. +;;; 6 = sbcl-0.6.9, got rid of non-ANSI %DEFCONSTANT/%%DEFCONSTANT stuff +;;; and deleted a slot from DEBUG-SOURCE structure. (setf *backend-register-save-penalty* 3) diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp index a30c30c..aff5e1d 100644 --- a/src/compiler/x86/c-call.lisp +++ b/src/compiler/x86/c-call.lisp @@ -118,7 +118,7 @@ (when values (invoke-alien-type-method :result-tn (car values) state)))) -(def-vm-support-routine make-call-out-tns (type) +(!def-vm-support-routine make-call-out-tns (type) (let ((arg-state (make-arg-state))) (collect ((arg-tns)) (dolist #+nil ;; this reversed list seems to cause the alien botches!! diff --git a/src/compiler/x86/call.lisp b/src/compiler/x86/call.lisp index 37a582c..56442c3 100644 --- a/src/compiler/x86/call.lisp +++ b/src/compiler/x86/call.lisp @@ -15,7 +15,7 @@ ;;; Return a wired TN describing the N'th full call argument passing ;;; location. -(def-vm-support-routine standard-argument-location (n) +(!def-vm-support-routine standard-argument-location (n) (declare (type unsigned-byte n)) (if (< n register-arg-count) (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number @@ -29,7 +29,7 @@ ;;; ;;; No problems. ;#+nil -(def-vm-support-routine make-return-pc-passing-location (standard) +(!def-vm-support-routine make-return-pc-passing-location (standard) (declare (ignore standard)) (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset)) @@ -38,7 +38,7 @@ ;;; ;;; No problems. #+nil -(def-vm-support-routine make-return-pc-passing-location (standard) +(!def-vm-support-routine make-return-pc-passing-location (standard) (let ((ptype (primitive-type-or-lose 'system-area-pointer))) (if standard (make-wired-tn ptype sap-stack-sc-number return-pc-save-offset) @@ -54,7 +54,7 @@ ;;; ;;; No problems ;#+nil -(def-vm-support-routine make-old-fp-passing-location (standard) +(!def-vm-support-routine make-old-fp-passing-location (standard) (declare (ignore standard)) (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset)) @@ -63,7 +63,7 @@ ;;; ;;; No problems. #+nil -(def-vm-support-routine make-old-fp-passing-location (standard) +(!def-vm-support-routine make-old-fp-passing-location (standard) (if standard (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset) @@ -75,14 +75,14 @@ ;;; ;;; Without using a save-tn - which does not make much sense if it is ;;; wire to the stack? No problems. -(def-vm-support-routine make-old-fp-save-location (env) +(!def-vm-support-routine make-old-fp-save-location (env) (environment-debug-live-tn (make-wired-tn *fixnum-primitive-type* control-stack-sc-number ocfp-save-offset) env)) ;;; Using a save-tn. No problems. #+nil -(def-vm-support-routine make-old-fp-save-location (env) +(!def-vm-support-routine make-old-fp-save-location (env) (specify-save-tn (environment-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env) (make-wired-tn *fixnum-primitive-type* control-stack-sc-number @@ -90,14 +90,14 @@ ;;; Without using a save-tn - which does not make much sense if it is ;;; wire to the stack? No problems. -(def-vm-support-routine make-return-pc-save-location (env) +(!def-vm-support-routine make-return-pc-save-location (env) (environment-debug-live-tn (make-wired-tn (primitive-type-or-lose 'system-area-pointer) sap-stack-sc-number return-pc-save-offset) env)) ;;; Using a save-tn. No problems. #+nil -(def-vm-support-routine make-return-pc-save-location (env) +(!def-vm-support-routine make-return-pc-save-location (env) (let ((ptype (primitive-type-or-lose 'system-area-pointer))) (specify-save-tn (environment-debug-live-tn (make-normal-tn ptype) env) @@ -106,24 +106,24 @@ ;;; Make a TN for the standard argument count passing location. We only ;;; need to make the standard location, since a count is never passed when we ;;; are using non-standard conventions. -(def-vm-support-routine make-argument-count-location () +(!def-vm-support-routine make-argument-count-location () (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ecx-offset)) ;;; Make a TN to hold the number-stack frame pointer. This is allocated ;;; once per component, and is component-live. -(def-vm-support-routine make-nfp-tn () +(!def-vm-support-routine make-nfp-tn () (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) -(def-vm-support-routine make-stack-pointer-tn () +(!def-vm-support-routine make-stack-pointer-tn () (make-normal-tn *fixnum-primitive-type*)) -(def-vm-support-routine make-number-stack-pointer-tn () +(!def-vm-support-routine make-number-stack-pointer-tn () (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number)) ;;; Return a list of TNs that can be used to represent an unknown-values ;;; continuation within a function. -(def-vm-support-routine make-unknown-values-locations () +(!def-vm-support-routine make-unknown-values-locations () (list (make-stack-pointer-tn) (make-normal-tn *fixnum-primitive-type*))) @@ -135,7 +135,7 @@ ;;; ;;; For the x86 the first constant is a pointer to a list of fixups, ;;; or nil if the code object has none. -(def-vm-support-routine select-component-format (component) +(!def-vm-support-routine select-component-format (component) (declare (type component component)) (dotimes (i (1+ code-constants-offset)) (vector-push-extend nil diff --git a/src/compiler/x86/nlx.lisp b/src/compiler/x86/nlx.lisp index e7eea3a..c15ba61 100644 --- a/src/compiler/x86/nlx.lisp +++ b/src/compiler/x86/nlx.lisp @@ -12,13 +12,13 @@ (in-package "SB!VM") ;;; Make an environment-live stack TN for saving the SP for NLX entry. -(def-vm-support-routine make-nlx-sp-tn (env) +(!def-vm-support-routine make-nlx-sp-tn (env) (environment-live-tn (make-representation-tn *fixnum-primitive-type* any-reg-sc-number) env)) ;;; Make a TN for the argument count passing location for a non-local entry. -(def-vm-support-routine make-nlx-entry-argument-start-location () +(!def-vm-support-routine make-nlx-entry-argument-start-location () (make-wired-tn *fixnum-primitive-type* any-reg-sc-number ebx-offset)) (defun catch-block-ea (tn) @@ -41,7 +41,7 @@ ;;; Return a list of TNs that can be used to snapshot the dynamic state for ;;; use with the Save/Restore-Dynamic-Environment VOPs. -(def-vm-support-routine make-dynamic-state-tns () +(!def-vm-support-routine make-dynamic-state-tns () (make-n-tns 3 *backend-t-primitive-type*)) (define-vop (save-dynamic-state) diff --git a/src/compiler/x86/vm.lisp b/src/compiler/x86/vm.lisp index 8f09651..94c5c8b 100644 --- a/src/compiler/x86/vm.lisp +++ b/src/compiler/x86/vm.lisp @@ -137,8 +137,6 @@ (forms `(define-storage-class ,sc-name ,index ,@(cdr class))) (forms `(defconstant ,constant-name ,index)) - (forms `(let ((sb!int::*rogue-export* "DEFINE-STORAGE-CLASSES")) - (export ',constant-name))) (incf index)))) `(progn ,@(forms)))) @@ -378,7 +376,7 @@ ;;; ;;; If value can be represented as an immediate constant, then return ;;; the appropriate SC number, otherwise return NIL. -(def-vm-support-routine immediate-constant-sc (value) +(!def-vm-support-routine immediate-constant-sc (value) (typecase value ((or fixnum #-sb-xc-host system-area-pointer character) (sc-number-or-lose 'immediate)) @@ -425,7 +423,7 @@ ;;; This function is called by debug output routines that want a pretty name ;;; for a TN's location. It returns a thing that can be printed with PRINC. -(def-vm-support-routine location-print-name (tn) +(!def-vm-support-routine location-print-name (tn) (declare (type tn tn)) (let* ((sc (tn-sc tn)) (sb (sb-name (sc-sb sc))) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 13d4b69..ab7aef8 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -1,7 +1,8 @@ ;;;; a simple code walker for PCL ;;;; -;;;; The code which implements the macroexpansion environment manipulation -;;;; mechanisms is in the first part of the file, the real walker follows it. +;;;; The code which implements the macroexpansion environment +;;;; manipulation mechanisms is in the first part of the file, the +;;;; real walker follows it. ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -31,40 +32,46 @@ ;;;; environment frobbing stuff ;;; Here in the original PCL were implementations of the -;;; implementation-specific environment hacking functions for each of the -;;; implementations this walker had been ported to. This functionality was -;;; originally factored out in order to make PCL portable from one Common Lisp -;;; to another. As of 19981107, that portability was fairly stale and (because -;;; of the scarcity of CLTL1 implementations and the strong interdependence of -;;; the rest of ANSI Common Lisp on the CLOS system) fairly irrelevant. It was -;;; fairly thoroughly put out of its misery by WHN in his quest to clean up the -;;; system enough that it can be built from scratch using any ANSI Common Lisp. +;;; implementation-specific environment hacking functions for each of +;;; the implementations this walker had been ported to. This +;;; functionality was originally factored out in order to make PCL +;;; portable from one Common Lisp to another. As of 19981107, that +;;; portability was fairly stale and (because of the scarcity of CLTL1 +;;; implementations and the strong interdependence of the rest of ANSI +;;; Common Lisp on the CLOS system) fairly irrelevant. It was fairly +;;; thoroughly put out of its misery by WHN in his quest to clean up +;;; the system enough that it can be built from scratch using any ANSI +;;; Common Lisp. ;;; -;;; This code just hacks 'macroexpansion environments'. That is, it is only -;;; concerned with the function binding of symbols in the environment. The -;;; walker needs to be able to tell if the symbol names a lexical macro or -;;; function, and it needs to be able to build environments which contain -;;; lexical macro or function bindings. It must be able, when walking a -;;; MACROLET, FLET or LABELS form to construct an environment which reflects -;;; the bindings created by that form. Note that the environment created -;;; does NOT have to be sufficient to evaluate the body, merely to walk its -;;; body. This means that definitions do not have to be supplied for lexical -;;; functions, only the fact that that function is bound is important. For -;;; macros, the macroexpansion function must be supplied. +;;; This code just hacks 'macroexpansion environments'. That is, it is +;;; only concerned with the function binding of symbols in the +;;; environment. The walker needs to be able to tell if the symbol +;;; names a lexical macro or function, and it needs to be able to +;;; build environments which contain lexical macro or function +;;; bindings. It must be able, when walking a MACROLET, FLET or LABELS +;;; form to construct an environment which reflects the bindings +;;; created by that form. Note that the environment created does NOT +;;; have to be sufficient to evaluate the body, merely to walk its +;;; body. This means that definitions do not have to be supplied for +;;; lexical functions, only the fact that that function is bound is +;;; important. For macros, the macroexpansion function must be +;;; supplied. ;;; -;;; This code is organized in a way that lets it work in implementations that -;;; stack cons their environments. That is reflected in the fact that the -;;; only operation that lets a user build a new environment is a WITH-BODY -;;; macro which executes its body with the specified symbol bound to the new -;;; environment. No code in this walker or in PCL will hold a pointer to -;;; these environments after the body returns. Other user code is free to do -;;; so in implementations where it works, but that code is not considered -;;; portable. +;;; This code is organized in a way that lets it work in +;;; implementations that stack cons their environments. That is +;;; reflected in the fact that the only operation that lets a user +;;; build a new environment is a WITH-BODY macro which executes its +;;; body with the specified symbol bound to the new environment. No +;;; code in this walker or in PCL will hold a pointer to these +;;; environments after the body returns. Other user code is free to do +;;; so in implementations where it works, but that code is not +;;; considered portable. ;;; ;;; There are 3 environment hacking tools. One macro, -;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new environments, and -;;; two functions, ENVIRONMENT-FUNCTION and ENVIRONMENT-MACRO, which are used -;;; to access the bindings of existing environments +;;; WITH-AUGMENTED-ENVIRONMENT, which is used to create new +;;; environments, and two functions, ENVIRONMENT-FUNCTION and +;;; ENVIRONMENT-MACRO, which are used to access the bindings of +;;; existing environments ;;; In SBCL, as in CMU CL before it, the environment is represented ;;; with a structure that holds alists for the functional things, @@ -81,16 +88,16 @@ ,macros))) ,@body)) -;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which did -;;; not name a function or describe a lambda expression, (EVAL -;;; `(FUNCTION ,X)) would still return a FUNCTION object, and no error -;;; would be signalled until/unless you tried to FUNCALL the resulting -;;; FUNCTION object. (This behavior was also present in (COERCE X -;;; 'FUNCTION), which was defined in terms of (EVAL `(FUNCTION ,X)).) -;;; This function provides roughly the same behavior as the old CMU CL -;;; (COERCE X 'FUNCTION), for the benefit of PCL code which relied -;;; on being able to coerce bogus things without raising errors -;;; as long as it never tried to actually call them. +;;; KLUDGE: In CMU CL, when X was an arbitrary list, even one which +;;; did not name a function or describe a lambda expression, calling +;;; (EVAL `(FUNCTION ,X)) would still return a FUNCTION object, and no +;;; error would be signalled until/unless you tried to FUNCALL the +;;; resulting FUNCTION object. (This behavior was also present in +;;; (COERCE X 'FUNCTION), which was defined in terms of (EVAL +;;; `(FUNCTION ,X)).) This function provides roughly the same behavior +;;; as the old CMU CL (COERCE X 'FUNCTION), for the benefit of PCL +;;; code which relied on being able to coerce bogus things without +;;; raising errors as long as it never tried to actually call them. (defun bogo-coerce-to-function (x) (or (ignore-errors (coerce x 'function)) (lambda (&rest rest) @@ -160,12 +167,13 @@ ;;; Now comes the real walker. ;;; -;;; As the walker walks over the code, it communicates information to itself -;;; about the walk. This information includes the walk function, variable -;;; bindings, declarations in effect etc. This information is inherently -;;; lexical, so the walker passes it around in the actual environment the -;;; walker passes to macroexpansion functions. This is what makes the -;;; nested-walk-form facility work properly. +;;; As the walker walks over the code, it communicates information to +;;; itself about the walk. This information includes the walk +;;; function, variable bindings, declarations in effect etc. This +;;; information is inherently lexical, so the walker passes it around +;;; in the actual environment the walker passes to macroexpansion +;;; functions. This is what makes the NESTED-WALK-FORM facility work +;;; properly. (defmacro walker-environment-bind ((var env &rest key-args) &body body) `(with-augmented-environment @@ -237,11 +245,11 @@ ;;;; handling of special forms -;;; Here are some comments from the original PCL on the difficulty of doing -;;; this portably across different CLTL1 implementations. This is no longer -;;; directly relevant because this code now only runs on SBCL, but the comments -;;; are retained for culture: they might help explain some of the design -;;; decisions which were made in the code. +;;; Here are some comments from the original PCL on the difficulty of +;;; doing this portably across different CLTL1 implementations. This +;;; is no longer directly relevant because this code now only runs on +;;; SBCL, but the comments are retained for culture: they might help +;;; explain some of the design decisions which were made in the code. ;;; ;;; and I quote... ;;; @@ -251,36 +259,39 @@ ;;; program needs no special knowledge about macros... ;;; ;;; So all we have to do here is a define a way to store and retrieve -;;; templates which describe how to walk the 24 special forms and we are all -;;; set... +;;; templates which describe how to walk the 24 special forms and we +;;; are all set... ;;; -;;; Well, its a nice concept, and I have to admit to being naive enough that -;;; I believed it for a while, but not everyone takes having only 24 special -;;; forms as seriously as might be nice. There are (at least) 3 ways to -;;; lose: +;;; Well, its a nice concept, and I have to admit to being naive +;;; enough that I believed it for a while, but not everyone takes +;;; having only 24 special forms as seriously as might be nice. There +;;; are (at least) 3 ways to lose: ;; -;;; 1 - Implementation x implements a Common Lisp special form as a macro -;;; which expands into a special form which: +;;; 1 - Implementation x implements a Common Lisp special form as +;;; a macro which expands into a special form which: ;;; - Is a common lisp special form (not likely) ;;; - Is not a common lisp special form (on the 3600 IF --> COND). ;;; -;;; * We can safe ourselves from this case (second subcase really) by -;;; checking to see whether there is a template defined for something -;;; before we check to see whether we can macroexpand it. +;;; * We can safe ourselves from this case (second subcase really) +;;; by checking to see whether there is a template defined for +;;; something before we check to see whether we can macroexpand it. ;;; ;;; 2 - Implementation x implements a Common Lisp macro as a special form. ;;; ;;; * This is a screw, but not so bad, we save ourselves from it by ;;; defining extra templates for the macros which are *likely* to -;;; be implemented as special forms. (DO, DO* ...) +;;; be implemented as special forms. [Note: As of sbcl-0.6.9, these +;;; extra templates have been deleted, since this is not a problem +;;; in SBCL and we no longer try to make this walker portable +;;; across other possibly-broken CL implementations.] ;;; ;;; 3 - Implementation x has a special form which is not on the list of ;;; Common Lisp special forms. ;;; -;;; * This is a bad sort of a screw and happens more than I would like -;;; to think, especially in the implementations which provide more -;;; than just Common Lisp (3600, Xerox etc.). -;;; The fix is not terribly staisfactory, but will have to do for +;;; * This is a bad sort of a screw and happens more than I would +;;; like to think, especially in the implementations which provide +;;; more than just Common Lisp (3600, Xerox etc.). +;;; The fix is not terribly satisfactory, but will have to do for ;;; now. There is a hook in get walker-template which can get a ;;; template from the implementation's own walker. That template ;;; has to be converted, and so it may be that the right way to do @@ -288,21 +299,14 @@ ;;; interface to its walker which looks like the interface to this ;;; walker. -;;; FIXME: In SBCL, we probably don't need to put DEFMACROs inside EVAL-WHEN. -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defmacro get-walker-template-internal (x) ;Has to be inside eval-when because - `(get ,x 'walker-template)) ;Golden Common Lisp doesn't hack - ;compile time definition of macros - ;right for setf. +(defmacro get-walker-template-internal (x) + `(get ,x 'walker-template)) (defmacro define-walker-template (name &optional (template '(nil repeat (eval)))) `(eval-when (:load-toplevel :execute) (setf (get-walker-template-internal ',name) ',template))) -) ; EVAL-WHEN - (defun get-walker-template (x) (cond ((symbolp x) (or (get-walker-template-internal x) @@ -320,51 +324,40 @@ ;;;; the actual templates ;;; ANSI special forms -(define-walker-template block (nil nil repeat (eval))) -(define-walker-template catch (nil eval repeat (eval))) -(define-walker-template declare walk-unexpected-declare) -(define-walker-template eval-when (nil quote repeat (eval))) -(define-walker-template flet walk-flet) -(define-walker-template function (nil call)) -(define-walker-template go (nil quote)) -(define-walker-template if walk-if) -(define-walker-template labels walk-labels) -(define-walker-template lambda walk-lambda) -(define-walker-template let walk-let) -(define-walker-template let* walk-let*) -(define-walker-template locally walk-locally) -(define-walker-template macrolet walk-macrolet) +(define-walker-template block (nil nil repeat (eval))) +(define-walker-template catch (nil eval repeat (eval))) +(define-walker-template declare walk-unexpected-declare) +(define-walker-template eval-when (nil quote repeat (eval))) +(define-walker-template flet walk-flet) +(define-walker-template function (nil call)) +(define-walker-template go (nil quote)) +(define-walker-template if walk-if) +(define-walker-template labels walk-labels) +(define-walker-template lambda walk-lambda) +(define-walker-template let walk-let) +(define-walker-template let* walk-let*) +(define-walker-template locally walk-locally) +(define-walker-template macrolet walk-macrolet) (define-walker-template multiple-value-call (nil eval repeat (eval))) (define-walker-template multiple-value-prog1 (nil return repeat (eval))) (define-walker-template multiple-value-setq walk-multiple-value-setq) (define-walker-template multiple-value-bind walk-multiple-value-bind) -(define-walker-template progn (nil repeat (eval))) -(define-walker-template progv (nil eval eval repeat (eval))) -(define-walker-template quote (nil quote)) -(define-walker-template return-from (nil quote repeat (return))) -(define-walker-template setq walk-setq) +(define-walker-template progn (nil repeat (eval))) +(define-walker-template progv (nil eval eval repeat (eval))) +(define-walker-template quote (nil quote)) +(define-walker-template return-from (nil quote repeat (return))) +(define-walker-template setq walk-setq) (define-walker-template symbol-macrolet walk-symbol-macrolet) -(define-walker-template tagbody walk-tagbody) -(define-walker-template the (nil quote eval)) -(define-walker-template throw (nil eval eval)) +(define-walker-template tagbody walk-tagbody) +(define-walker-template the (nil quote eval)) +(define-walker-template throw (nil eval eval)) (define-walker-template unwind-protect (nil return repeat (eval))) ;;; SBCL-only special forms -(define-walker-template sb-ext:truly-the (nil quote eval)) - -;;; extra templates -(define-walker-template do walk-do) -(define-walker-template do* walk-do*) -(define-walker-template prog walk-prog) -(define-walker-template prog* walk-prog*) -(define-walker-template cond (nil repeat ((test repeat (eval))))) +(define-walker-template sb-ext:truly-the (nil quote eval)) (defvar *walk-form-expand-macros-p* nil) -(defun macroexpand-all (form &optional environment) - (let ((*walk-form-expand-macros-p* t)) - (walk-form form environment))) - (defun walk-form (form &optional environment (walk-function @@ -374,82 +367,18 @@ (walker-environment-bind (new-env environment :walk-function walk-function) (walk-form-internal form :eval new-env))) -;;; NESTED-WALK-FORM provides an interface that allows nested macros, each -;;; of which must walk their body, to just do one walk of the body of the -;;; inner macro. That inner walk is done with a walk function which is the -;;; composition of the two walk functions. -;;; -;;; This facility works by having the walker annotate the environment that -;;; it passes to MACROEXPAND-1 to know which form is being macroexpanded. -;;; If then the &WHOLE argument to the macroexpansion function is eq to -;;; the ENV-WALK-FORM of the environment, NESTED-WALK-FORM can be certain -;;; that there are no intervening layers and that a nested walk is OK. -;;; -;;; KLUDGE: There are some semantic problems with this facility. In particular, -;;; if the outer walk function returns T as its WALK-NO-MORE-P value, this will -;;; prevent the inner walk function from getting a chance to walk the subforms -;;; of the form. This is almost never what you want, since it destroys the -;;; equivalence between this NESTED-WALK-FORM function and two separate -;;; WALK-FORMs. -(defun nested-walk-form (whole form - &optional environment - (walk-function - #'(lambda (subform context env) - (declare (ignore context env)) - subform))) - (if (eq whole (env-walk-form environment)) - (let ((outer-walk-function (env-walk-function environment))) - (throw whole - (walk-form - form - environment - #'(lambda (f c e) - ;; First loop to make sure the inner walk function - ;; has done all it wants to do with this form. - ;; Basically, what we are doing here is providing - ;; the same contract walk-form-internal normally - ;; provides to the inner walk function. - (let ((inner-result nil) - (inner-no-more-p nil) - (outer-result nil) - (outer-no-more-p nil)) - (loop - (multiple-value-setq (inner-result inner-no-more-p) - (funcall walk-function f c e)) - (cond (inner-no-more-p (return)) - ((not (eq inner-result f))) - ((not (consp inner-result)) (return)) - ((get-walker-template (car inner-result)) (return)) - (t - (multiple-value-bind (expansion macrop) - (walker-environment-bind - (new-env e :walk-form inner-result) - (macroexpand-1 inner-result new-env)) - (if macrop - (setq inner-result expansion) - (return))))) - (setq f inner-result)) - (multiple-value-setq (outer-result outer-no-more-p) - (funcall outer-walk-function - inner-result - c - e)) - (values outer-result - (and inner-no-more-p outer-no-more-p))))))) - (walk-form form environment walk-function))) - -;;; WALK-FORM-INTERNAL is the main driving function for the code walker. It -;;; takes a form and the current context and walks the form calling itself or -;;; the appropriate template recursively. +;;; WALK-FORM-INTERNAL is the main driving function for the code +;;; walker. It takes a form and the current context and walks the form +;;; calling itself or the appropriate template recursively. ;;; ;;; "It is recommended that a program-analyzing-program process a form ;;; that is a list whose car is a symbol as follows: ;;; ;;; 1. If the program has particular knowledge about the symbol, -;;; process the form using special-purpose code. All of the -;;; standard special forms should fall into this category. -;;; 2. Otherwise, if macro-function is true of the symbol apply -;;; either macroexpand or macroexpand-1 and start over. +;;; process the form using special-purpose code. All of the +;;; standard special forms should fall into this category. +;;; 2. Otherwise, if MACRO-FUNCTION is true of the symbol apply +;;; either MACROEXPAND or MACROEXPAND-1 and start over. ;;; 3. Otherwise, assume it is a function call. " (defun walk-form-internal (form context env) ;; First apply the walk-function to perform whatever translation @@ -496,13 +425,14 @@ (not (fboundp fn)) (special-operator-p fn)) ;; This shouldn't happen, since this walker is now - ;; maintained as part of SBCL, so it should know about all - ;; the special forms that SBCL knows about. + ;; maintained as part of SBCL, so it should know + ;; about all the special forms that SBCL knows + ;; about. (error "unexpected special form ~S" fn)) (t - ;; Otherwise, walk the form as if it's just a standard - ;; function call using a template for standard function - ;; call. + ;; Otherwise, walk the form as if it's just a + ;; standard function call using a template for + ;; standard function call. (walk-template newnewform '(call repeat (eval)) context env)))))))))))) @@ -525,9 +455,10 @@ (repeat (walk-template-handle-repeat form (cdr template) - ;; For the case where nothing happens - ;; after the repeat optimize out the - ;; call to length. + ;; For the case where nothing + ;; happens after the repeat + ;; optimize away the call to + ;; LENGTH. (if (null (cddr template)) () (nthcdr (- (length form) @@ -628,7 +559,8 @@ form (walk-declarations (cdr body) fn env t))) ((and (listp form) (eq (car form) 'declare)) - ;; We got ourselves a real live declaration. Record it, look for more. + ;; We got ourselves a real live declaration. Record it, look + ;; for more. (dolist (declaration (cdr form)) (let ((type (car declaration)) (name (cadr declaration)) @@ -860,10 +792,10 @@ (if sequentialp new-env old-env)) - (cddr binding)) ; Save cddr for DO/DO*; - ; it is the next value - ; form. Don't walk it - ; now though. + ;; Save cddr for DO/DO*; it is + ;; the next value form. Don't + ;; walk it now, though. + (cddr binding)) (note-lexical-binding (car binding) new-env))) (walk-bindings-1 (cdr bindings) old-env @@ -1054,23 +986,25 @@ ;;;; tests tests tests #| -;;; Here are some examples of the kinds of things you should be able to do -;;; with your implementation of the macroexpansion environment hacking -;;; mechanism. +;;; Here are some examples of the kinds of things you should be able +;;; to do with your implementation of the macroexpansion environment +;;; hacking mechanism. ;;; -;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes names -;;; of the macros and actual macroexpansion functions to use to macroexpand -;;; them. The win about that is that for macros which want to wrap several -;;; MACROLETs around their body, they can do this but have the macroexpansion -;;; functions be compiled. See the WITH-RPUSH example. +;;; WITH-LEXICAL-MACROS is kind of like MACROLET, but it only takes +;;; names of the macros and actual macroexpansion functions to use to +;;; macroexpand them. The win about that is that for macros which want +;;; to wrap several MACROLETs around their body, they can do this but +;;; have the macroexpansion functions be compiled. See the WITH-RPUSH +;;; example. ;;; -;;; If the implementation had a special way of communicating the augmented -;;; environment back to the evaluator that would be totally great. It would -;;; mean that we could just augment the environment then pass control back -;;; to the implementations own compiler or interpreter. We wouldn't have -;;; to call the actual walker. That would make this much faster. Since the -;;; principal client of this is defmethod it would make compiling defmethods -;;; faster and that would certainly be a win. +;;; If the implementation had a special way of communicating the +;;; augmented environment back to the evaluator that would be totally +;;; great. It would mean that we could just augment the environment +;;; then pass control back to the implementations own compiler or +;;; interpreter. We wouldn't have to call the actual walker. That +;;; would make this much faster. Since the principal client of this is +;;; defmethod it would make compiling defmethods faster and that would +;;; certainly be a win. (defmacro with-lexical-macros (macros &body body &environment old-env) (with-augmented-environment (new-env old-env :macros macros) diff --git a/tests/compound-cons.impure.lisp b/tests/compound-cons.impure.lisp index cce5ac0..ef08021 100644 --- a/tests/compound-cons.impure.lisp +++ b/tests/compound-cons.impure.lisp @@ -5,10 +5,17 @@ (cl:in-package :cl-user) -(declaim (optimize (debug 3) (speed 2) (space 1))) +;;; This block of eight assertions is taken directly from +;;; 'Issue CONS-TYPE-SPECIFIER Writeup' in the ANSI spec. +(assert (typep '(a b c) '(cons t))) +(assert (typep '(a b c) '(cons symbol))) +(assert (not (typep '(a b c) '(cons integer)))) +(assert (typep '(a b c) '(cons t t))) +(assert (not (typep '(a b c) '(cons symbol symbol)))) +(assert (typep '(a b c) '(cons symbol (cons symbol (cons symbol))))) +(assert (not (typep '(a b c) '(cons symbol (cons symbol (cons symbol nil)))))) +(assert (typep '(a b c) '(cons symbol (cons symbol (cons symbol null))))) -;;; None of this is going to work until SBCL is patched. -#| (assert (not (typep 11 'cons))) (assert (not (typep 11 '(cons *)))) (assert (not (typep 11 '(cons t t)))) @@ -22,29 +29,28 @@ (assert (typep '(100) '(cons number null))) (assert (not (typep '(100) '(cons number string)))) -(assert (typep '("yes" no) '(cons string symbol))) -(assert (not (typep '(yes no) '(cons string symbol)))) -(assert (not (typep '(yes "no") '(cons string symbol)))) -(assert (typep '(yes "no") '(cons symbol))) -(assert (typep '(yes "no") '(cons symbol t))) -(assert (typep '(yes "no") '(cons t string))) -(assert (not (typep '(yes "no") '(cons t null)))) +(assert (typep '("yes" . no) '(cons string symbol))) +(assert (not (typep '(yes . no) '(cons string symbol)))) +(assert (not (typep '(yes . "no") '(cons string symbol)))) +(assert (typep '(yes . "no") '(cons symbol))) +(assert (typep '(yes . "no") '(cons symbol t))) +(assert (typep '(yes . "no") '(cons t string))) +(assert (not (typep '(yes . "no") '(cons t null)))) (assert (subtypep '(cons t) 'cons)) -(assert (subtypep 'cons '(cons t) )) +(assert (subtypep 'cons '(cons t))) (assert (subtypep '(cons t *) 'cons)) -(assert (subtypep 'cons '(cons t *) )) +(assert (subtypep 'cons '(cons t *))) (assert (subtypep '(cons * *) 'cons)) -(assert (subtypep 'cons '(cons * *) )) +(assert (subtypep 'cons '(cons * *))) -(assert (subtypep '(cons number *) 'cons )) +(assert (subtypep '(cons number *) 'cons)) (assert (not (subtypep 'cons '(cons number *)))) -(assert (subtypep '(cons * number) 'cons )) +(assert (subtypep '(cons * number) 'cons)) (assert (not (subtypep 'cons '(cons * number)))) -(assert (subtypep '(cons structure-object number) 'cons )) +(assert (subtypep '(cons structure-object number) 'cons)) (assert (not (subtypep 'cons '(cons structure-object number)))) (assert (subtypep '(cons null fixnum) (type-of '(nil 44)))) -|# (sb-ext:quit :unix-status 104) ; success diff --git a/version.lisp-expr b/version.lisp-expr index 12cda12..dcfc879 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.8.16" +"0.6.8.17" -- 1.7.10.4