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)
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
"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.]
: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"
+ )))
(: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.
;;; 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))
\f
;;;; 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))
;;; 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)))
(t
(values class1 nil))))
-(define-type-method (sb!xc:class :unparse) (type)
+(!define-type-method (sb!xc:class :unparse) (type)
(class-proper-name type))
\f
;;;; PCL stuff
;;; 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,
(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
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
(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
(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))))
(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))
;; 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))
(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)."))))
\f
;;;; debug loop functions
\f
;;;; 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
*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*)
(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))
(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.
;; 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
(:include args-type
(class-info (type-class-or-lose 'values)))))
-(define-type-class values)
+(!define-type-class values)
(defstruct (function-type
(:include args-type
(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")
(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*
*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 * *)
;;; 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)
(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
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
`(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
: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
(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))
(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)
;;; 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
',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)
;; 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
(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)
(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
(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
;;; 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
(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 '*)
(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))
(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)
(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
(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))))
(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
;;; (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)
\f
;;;; built-in types
-(define-type-class named)
+(!define-type-class named)
(defvar *wild-type*)
(defvar *empty-type*)
(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))
\f
;;;; 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)
(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)
(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))
\f
: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))
(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))
(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))
(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.
;;; 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)
(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)))
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))
: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 <= <)
;;; 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))
\f
;;;; 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
(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)
(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)))
`(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)))
(t
(values nil t)))))
-(define-superclasses array
+(!define-superclasses array
((string string)
(vector vector)
(array))
(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))
\f
;;;; 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)
;;; 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)
*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)))
;;; 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)
(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))
(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*))
(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
;;; 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)))
;;; 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)
(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))
;;; 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))
(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*))
;;; 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)))
\f
;;;; 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 *))
'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))
;;; 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))
(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)
(t
(make-union-type (res)))))))
\f
-(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)
;;;; 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.
-\f
-;;;; FIXME: Remove this after all in-the-flow-of-control EXPORTs
-;;;; have been cleaned up.
-
-(defvar *rogue-export*)
-\f
-;;;; 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))
\f
;;;; various SB-SHOW-dependent forms
;; 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*
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
(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
"/.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))
) ; 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*"
(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
(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)
(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)
(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)
;;; 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.
(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))
(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)))
(+ 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)))))
\f
;;;; 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)
(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*)))))
;;; 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)
(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))
(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)))
(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
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)
(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)))
(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.
(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)))
(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)
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)
(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
(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)
(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
;;;
;;; 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)
;;;; 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))
;;; 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)
(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))))
(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
(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)
(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)
(*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
(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)))
(declare (type index start ,@(all-lengths)))
,@(forms)
res))))
+\f
+;;;; 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)))))
`(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)
`(%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)))
(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)
;;; 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)
(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!!
;;; 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
;;;
;;; 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))
;;;
;;; 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)
;;;
;;; 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))
;;;
;;; 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)
;;;
;;; 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
;;; 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)
;;; 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*)))
;;;
;;; 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
(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)
;;; 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)
(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))))
;;;
;;; 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))
\f
;;; 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)))
;;;; 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.
;;;; 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,
,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)
\f
;;; 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
\f
;;;; 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...
;;;
;;; 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
;;; 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)
;;;; 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))
\f
(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
(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
(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))))))))))))
(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)
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))
(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
;;;; 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)
(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))))
(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
;;; 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"
projects / sbcl.git / commitdiff