(during macroexpansion of IN-PACKAGE,
during macroexpansion of DEFFOO)
-12:
- The type system doesn't understand the KEYWORD type very well:
- (SUBTYPEP 'KEYWORD 'SYMBOL) => NIL, NIL
- It might be possible to fix this by changing the definition of
- KEYWORD to (AND SYMBOL (SATISFIES KEYWORDP)), but the type system
- would need to be a bit smarter about AND types, too:
- (SUBTYPEP '(AND SYMBOL KEYWORD) 'SYMBOL) => NIL, NIL
- (The type system does know something about AND types already,
- (SUBTYPEP '(AND INTEGER FLOAT) 'NUMBER) => T, T
- (SUBTYPEP '(AND INTEGER FIXNUM) 'NUMBER) =>T, T
- so likely this is a small patch.)
-
13:
Floating point infinities are screwed up. [When I was converting CMU CL
to SBCL, I was looking for complexity to delete, and I thought it was safe
it would decrease efficiency more than is probably necessary. Perhaps
using some sort of accept/reject method would be better.
+84:
+ (SUBTYPEP '(SATISFIES SOME-UNDEFINED-FUN) NIL)=>NIL,T (should be NIL,NIL)
+
+85:
+ Internally the compiler sometimes evaluates
+ (sb-kernel:type/= (specifier-type '*) (specifier-type t))
+ (I stumbled across this when I added an
+ (assert (not (eq type1 *wild-type*)))
+ in the NAMED :SIMPLE-= type method.) '* isn't really a type, and
+ in a type context should probably be translated to T, and so it's
+ probably to ask whether it's equal to the T type and then (using the
+ EQ type comparison in the NAMED :SIMPLE-= type method) return NIL.
+ (I haven't tried to investigate this bug enough to guess whether
+ there might be any user-level symptoms.)
+
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
(Note: At some point, the pure interpreter (actually a semi-pure
* many patches ported from CMU CL by Martin Atzmueller, with
half a dozen bug fixes in pretty-printing and the debugger, and
half a dozen others elsewhere
-?? improved support for intersection types, fixing bug 12 (E.g., now
+* improved support for intersection types, fixing bug 12 (E.g., now
(SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T.)
?? The :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE features
are now supported, and enabled by default. Thus, the compiler can
without consing!)
?? unscrewed floating point infinities (bug 13) in order to support
:PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE features
-?? some minor ANSIfication of type specifications: bare 'AND and 'OR
- are no longer valid type specifiers, so e.g. (TYPEP 11 'AND) now
- signals an error; and SATISFIES requires its predicate to be a
- symbol, not a function object
* various fixes to make the cross-compiler more portable to
ANSI-conforming-but-different cross-compilation hosts (notably
Lispworks for Windows, following bug reports from Arthur Lemmens)
(load "src/cold/set-up-cold-packages.lisp")
(load "src/cold/defun-load-or-cload-xcompiler.lisp")
(load-or-cload-xcompiler #'host-cload-stem)
+ ;; Let's check that the type system is reasonably sane. (It's
+ ;; easy to spend a long time wandering around confused trying
+ ;; to debug cross-compilation if it isn't.)
+ (load "tests/type.before-xc.lisp")
(host-cload-stem "compiler/generic/genesis")
(sb!vm:genesis :c-header-file-name "src/runtime/sbcl.h")
EOF
(ensure-directories-exist filename :verbose t)
(with-open-file (s filename :direction :output)
(write *target-object-file-names* :stream s :readably t)))
+ ;; Let's check that the type system was reasonably sane. (It's
+ ;; easy to spend a long time wandering around confused trying
+ ;; to debug cold init if it wasn't.)
+ (load "tests/type.after-xc.lisp")
;; If you're experimenting with the system under a
;; cross-compilation host which supports CMU-CL-style SAVE-LISP,
;; this can be a good time to run it. The resulting core isn't
# "When we build software, it's a good idea to have a reliable method
# for getting an executable from it. We want any two reconstructions
+
# starting from the same source to end up in the same result. That's
# just a basic intellectual premise."
# -- Christian Queinnec, in _Lisp In Small Pieces_, p. 313
"CURRENT-STACK-POINTER" "DEALLOC-ALIEN-STACK-SPACE"
"DEALLOC-NUMBER-STACK-SPACE" "DEF-BOOLEAN-ATTRIBUTE"
"DEF-IR1-TRANSLATOR" "DEF-PRIMITIVE-TRANSLATOR"
- "DEF-PRIMITIVE-TYPE" "DEF-PRIMITIVE-TYPE-ALIAS"
+ "!DEF-PRIMITIVE-TYPE" "!DEF-PRIMITIVE-TYPE-ALIAS"
"DEF-SOURCE-TRANSFORM" "!DEF-VM-SUPPORT-ROUTINE"
"DEFINE-ASSEMBLY-ROUTINE" "DEFINE-MOVE-FUNCTION"
"DEFINE-MOVE-VOP" "DEFINE-STORAGE-BASE"
;; FIXME: Why not just put this stuff into SB-ALIEN? Or maybe
;; just glom this and SB-ALIEN together into SB-FFI?
:doc "public: some types used with ALIENs"
- :use ("CL" "SB!SYS" "SB!ALIEN-INTERNALS" "SB!ALIEN")
+ :use ("CL" "SB!SYS" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!INT" "SB!EXT")
:reexport ("FLOAT" "CHAR")
:export ("C-STRING" "DOUBLE" "INT" "LONG"
"SHORT" "UNSIGNED-CHAR" "UNSIGNED-INT"
;; rid of FDEFINITIONs entirely later.
"*SETF-FDEFINITION-HOOK*"
- ;; non-standard but widely useful user-level functions..
+ ;; error-reporting facilities
+ "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR"
+ "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING"
+ "STYLE-WARN"
+
+ ;; miscellaneous non-standard but widely useful user-level
+ ;; functions..
"ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
"%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
;; debuggers' little helpers
#!+sb-show "*/SHOW*"
+ #!+sb-show "HEXSTR"
"/SHOW" "/NOSHOW"
"/XHOW" "/NOXHOW"
"/SHOW0" "/NOSHOW0"
+ "/HEXSTR" "/NOHEXSTR"
+ "/PRIMITIVE-PRINT" "/NO-PRIMITIVE-PRINT"
;; cross-compilation bootstrap hacks which turn into
;; placeholders in a target system
"PROPER-LIST-OF-LENGTH-P"
"LIST-OF-LENGTH-AT-LEAST-P"
"READ-SEQUENCE-OR-DIE"
- "RENAME-KEYWORD-ARGS"
+ "RENAME-KEY-ARGS"
"REQUIRED-ARGUMENT"
"UNIX-NAMESTRING" ; FIXME: perhaps belongs in package %UNIX
"FEATUREP"
"MAKE-NULL-LEXENV" "MAKE-NUMERIC-TYPE"
"MAKE-SINGLE-FLOAT" "MAKE-SPECIALIZABLE-ARRAY"
"%MAKE-INSTANCE"
- "MAKE-INTERSECTION-TYPE-OR-SOMETHING"
"MAKE-UNION-TYPE-OR-SOMETHING"
"MAKE-VALUES-TYPE"
"MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
"OBJECT-NOT-TYPE-ERROR"
"OBJECT-NOT-UNSIGNED-BYTE-32-ERROR"
"OBJECT-NOT-VECTOR-ERROR" "OBJECT-NOT-WEAK-POINTER-ERROR"
- "ODD-KEYWORD-ARGUMENTS-ERROR"
+ "ODD-KEY-ARGUMENTS-ERROR"
"OUTPUT-OBJECT" "OUTPUT-UGLY-OBJECT"
"PACKAGE-DOC-STRING"
"PACKAGE-HASHTABLE-SIZE" "PACKAGE-HASHTABLE-FREE"
"TWO-ARG-GCD" "TWO-ARG-IOR"
"TWO-ARG-LCM" "TWO-ARG-XOR"
"TYPE-DIFFERENCE" "TYPE-EXPAND"
- "TYPE-INTERSECT"
- "TYPE-INTERSECTION" "TYPE-SPECIFIER"
+ "TYPE-INTERSECTION" "TYPE-INTERSECTION2"
+ "TYPE-APPROX-INTERSECTION2"
+ "TYPE-SPECIFIER"
"TYPE-UNION" "TYPE/=" "TYPE="
"TYPES-INTERSECT" "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY"
"UNDEFINED-SYMBOL-ERROR" "UNION-TYPE" "UNION-TYPE-P"
"UNION-TYPE-TYPES" "UNKNOWN-ERROR"
- "UNKNOWN-KEYWORD-ARGUMENT-ERROR"
+ "UNKNOWN-KEY-ARGUMENT-ERROR"
"UNKNOWN-TYPE" "UNKNOWN-TYPE-P"
"UNKNOWN-TYPE-SPECIFIER" "UNSEEN-THROW-TAG-ERROR"
"UNSIGNED-BYTE-32-P" "VALUES-SPECIFIER-TYPE"
"VALUES-SPECIFIER-TYPE-CACHE-CLEAR" "VALUES-SUBTYPEP"
- "VALUES-TYPE" "VALUES-TYPE-ALLOWP" "VALUES-TYPE-INTERSECT"
+ "VALUES-TYPE"
"VALUES-TYPE-INTERSECTION" "VALUES-TYPE-KEYP"
"VALUES-TYPE-KEYWORDS" "VALUES-TYPE-OPTIONAL"
"VALUES-TYPE-P" "VALUES-TYPE-REQUIRED"
"REDEFINE-LAYOUT-WARNING" "SLOT-CLASS"
"INSURED-FIND-CLASS" "CONDITION-FUNCTION-NAME"
- ;; FIXME: These error-handling things probably belong
- ;; the SB-INT package, not here.
- "SIMPLE-CONTROL-ERROR" "SIMPLE-FILE-ERROR"
- "SIMPLE-PROGRAM-ERROR" "SIMPLE-STYLE-WARNING" "STYLE-WARN"
-
;; symbols from former SB!CONDITIONS
"*HANDLER-CLUSTERS*" "*RESTART-CLUSTERS*"
"SHOW-CONDITION" "CASE-FAILURE"
"F-GETFD" "F-GETFL" "F-GETOWN" "F-SETFD" "F-SETFL" "F-SETOWN"
"FAPPEND" "FASYNC" "FCREAT" "FEXCL" "FIONREAD" "FNDELAY" "FTRUNC"
"F_OK" "GET-UNIX-ERROR-MSG" "GET-ERRNO" "GID-T"
- "INO-T" "IT-INTERVAL" "IT-VALUE"
- "ITIMERVAL" "UNIX-SETITIMER" "UNIX-GETITIMER"
+ "INO-T" "UNIX-SETITIMER" "UNIX-GETITIMER"
"KBDCGET" "KBDCRESET" "KBDCRST" "KBDCSET"
"KBDCSSTD" "KBDGCLICK" "KBDSCLICK" "KBDSGET" "L_INCR" "L_SET"
"L_XTND" "OFF-T" "O_APPEND" "O_CREAT" "O_EXCL" "O_RDONLY" "O_RDWR"
"O_TRUNC" "O_WRONLY" "READGRP" "READOTH" "READOWN" "RLIM-CUR"
- "RLIM-MAX" "RLIMIT" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS"
+ "RLIM-MAX" "RU-IDRSS" "RU-INBLOCK" "RU-ISRSS" "RU-IXRSS"
"RU-MAJFLT" "RU-MAXRSS" "RU-MINFLT" "RU-MSGRCV" "RU-MSGSND"
"RU-NIVCSW" "RU-NSIGNALS" "RU-NSWAP" "RU-NVCSW" "RU-OUBLOCK"
"RU-STIME" "RU-UTIME" "RUSAGE_CHILDREN" "RUSAGE_SELF" "RUSEAGE"
"SETUIDEXEC" "SG-ERASE" "SG-FLAGS" "SG-ISPEED" "SG-KILL"
"SG-OSPEED" "SGTTYB" "SIZE-T" "ST-ATIME" "ST-BLKSIZE"
"ST-BLOCKS" "ST-CTIME" "ST-DEV" "ST-GID" "ST-MODE" "ST-MTIME"
- "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "SWBLK-T" "T-BRKC"
- "T-DSUSPC" "T-EOFC" "T-FLUSHC" "T-INTRC" "T-LNEXTC" "T-QUITC"
- "T-RPRNTC" "T-STARTC" "T-STOPC" "T-SUSPC" "T-WERASC" "TCHARS"
+ "ST-NLINK" "ST-RDEV" "ST-SIZE" "ST-UID" "STAT" "SWBLK-T"
"TERMINAL-SPEEDS" "TIME-T" "TIMEVAL" "TIMEZONE" "TIOCFLUSH"
"TIOCGETC" "TIOCGETP" "TIOCGLTC" "TIOCGPGRP" "TIOCGWINSZ"
"TIOCNOTTY" "TIOCSETC" "TIOCSETP" "TIOCSLTC" "TIOCSPGRP"
- "TIOCSWINSZ" "TTY-CBREAK" "TTY-CRMOD" "TTY-LCASE"
- "TTY-RAW" "TTY-TANDEM" "TV-SEC" "TV-USEC" "TZ-DSTTIME"
+ "TIOCSWINSZ" "TV-SEC" "TV-USEC" "TZ-DSTTIME"
"TZ-MINUTESWEST" "UID-T" "UNIX-ACCEPT" "UNIX-ACCESS" "UNIX-BIND"
"UNIX-CHDIR" "UNIX-CHMOD" "UNIX-CHOWN" "UNIX-CLOSE" "UNIX-CONNECT"
"UNIX-CREAT" "UNIX-CURRENT-DIRECTORY" "UNIX-DUP" "UNIX-DUP2"
(in-package "SB!KERNEL")
+(/show0 "code/alien-type.lisp 16")
+
(!begin-collecting-cold-init-forms)
(defstruct (alien-type-type
*universal-type*))
(!defun-from-collected-cold-init-forms !alien-type-cold-init)
+
+(/show0 "code/alien-type.lisp end of file")
;;; the compiler to never return, it will avoid any compile-time type
;;; warnings that would result from a default value inconsistent with
;;; the declared type. When this function is called, it signals an
-;;; error indicating that a required keyword argument was not
-;;; supplied. This function is also useful for DEFSTRUCT slot defaults
+;;; error indicating that a required &KEY argument was not supplied.
+;;; This function is also useful for DEFSTRUCT slot defaults
;;; corresponding to required arguments.
(declaim (ftype (function () nil) required-argument))
(defun required-argument ()
#!+sb-doc
(/show0 "entering REQUIRED-ARGUMENT")
- (error "A required keyword argument was not supplied."))
+ (error "A required &KEY argument was not supplied."))
\f
;;; "the ultimate iteration macro"
;;;
(t
(unless (evenp more-args-supplied)
(with-debugger-info (old-component ret-pc old-fp)
- (error "odd number of keyword arguments")))
- ;; If there are keyword args, then we need to leave the
- ;; defaulted and supplied-p values where the more args
- ;; currently are. There might be more or fewer. And also,
- ;; we need to flatten the parsed args with the defaults
- ;; before we scan the keywords. So we copy all the more
- ;; args to a temporary area at the end of the stack.
+ (error "odd number of &KEY arguments")))
+ ;; If there are &KEY args, then we need to leave
+ ;; the defaulted and supplied-p values where the
+ ;; more args currently are. There might be more or
+ ;; fewer. And also, we need to flatten the parsed
+ ;; args with the defaults before we scan the
+ ;; keywords. So we copy all the more args to a
+ ;; temporary area at the end of the stack.
(let* ((num-more-args
(hairy-byte-function-num-more-args xep))
(new-sp (+ more-args-start num-more-args))
(rest-arg-p nil :type (member t nil))
;; True if there are keywords. Note: keywords might still be NIL
;; because having &KEY with no keywords is valid and should result
- ;; in allow-other-keys processing. If :allow-others, then allow
+ ;; in &ALLOW-OTHER-KEYS processing. If :ALLOW-OTHERS, then allow
;; other keys.
(keywords-p nil :type (member t nil :allow-others))
- ;; List of keyword arguments. Each element is a list of:
- ;; key, default, supplied-p.
+ ;; list of &KEY arguments. Each element is a list of:
+ ;; key, default, supplied-p.
(keywords nil :type list))
#!-sb-fluid (declaim (freeze-type byte-function-or-closure))
(declaim (ftype (function (symbol index simple-vector layout-depthoid) layout)
find-and-init-or-check-layout))
(defun find-and-init-or-check-layout (name length inherits depthoid)
+ (/show0 "entering FIND-AND-INIT-OR-CHECK-LAYOUT")
(let ((layout (find-layout name)))
(init-or-check-layout layout
(or (sb!xc:find-class name nil)
(translation nil :type (or ctype (member nil :initializing))))
(defun make-built-in-class (&rest rest)
(apply #'bare-make-built-in-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
;;; FIXME: In CMU CL, this was a class with a print function, but not
;;; necessarily a structure class (e.g. CONDITIONs). In SBCL,
(constructor nil :type (or function null)))
(defun make-structure-class (&rest rest)
(apply #'bare-make-structure-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
;;; FUNCALLABLE-STRUCTURE-CLASS is used to represent funcallable
;;; structures, which are used to implement generic functions.
(:constructor bare-make-funcallable-structure-class)))
(defun make-funcallable-structure-class (&rest rest)
(apply #'bare-make-funcallable-structure-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
\f
;;;; class namespace
;;; When finding the intersection of a sealed class and some other
;;; class (not hierarchically related) the intersection is the union
;;; of the currently shared subclasses.
-(defun sealed-class-intersection (sealed other)
+(defun sealed-class-intersection2 (sealed other)
(declare (type sb!xc:class sealed other))
(let ((s-sub (class-subclasses sealed))
(o-sub (class-subclasses other)))
(declare (ignore layout))
(when (gethash subclass o-sub)
(res (specifier-type subclass))))
- (values (res) t))
- (values *empty-type* t))))
+ (res))
+ *empty-type*)))
-;;; If one is a subclass of the other, then that is the intersection,
-;;; but we can only be sure the intersection is otherwise empty if
-;;; 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-intersection2) (class1 class2)
(declare (type sb!xc:class class1 class2))
- (cond ((eq class1 class2) class1)
+ (cond ((eq class1 class2)
+ class1)
+ ;; If one is a subclass of the other, then that is the
+ ;; intersection.
((let ((subclasses (class-subclasses class2)))
(and subclasses (gethash class1 subclasses)))
- (values class1 t))
+ class1)
((let ((subclasses (class-subclasses class1)))
(and subclasses (gethash class2 subclasses)))
- (values class2 t))
+ class2)
+ ;; Otherwise, we can't in general be sure that the
+ ;; intersection is empty, since a subclass of both might be
+ ;; defined. But we can eliminate it for some special cases.
((or (basic-structure-class-p class1)
(basic-structure-class-p class2))
- (values *empty-type* t))
+ ;; No subclass of both can be defined.
+ *empty-type*)
((eq (class-state class1) :sealed)
- (sealed-class-intersection class1 class2))
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class1 class2))
((eq (class-state class2) :sealed)
- (sealed-class-intersection class2 class1))
+ ;; checking whether a subclass of both can be defined:
+ (sealed-class-intersection2 class2 class1))
(t
- (values class1 nil))))
+ ;; uncertain, since a subclass of both might be defined
+ nil)))
(!define-type-method (sb!xc:class :unparse) (type)
(class-proper-name type))
(:constructor bare-make-random-pcl-class)))
(defun make-standard-class (&rest rest)
(apply #'bare-make-standard-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
(defun make-random-pcl-class (&rest rest)
(apply #'bare-make-random-pcl-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
\f
;;;; built-in classes
(rational
:translation rational
:inherits (real number generic-number))
+
+ ;; FIXME: moved LIST, CONS, and NULL here to help with translation
+ ;; of RATIO now that sbcl-0.6.11.13 has real INTERSECTION-TYPE;
+ ;; but it would be tidier to move them further back, if possible,
+ ;; so that all the numeric types are in an uninterrupted sequence
+ (list
+ :translation (or cons (member nil))
+ :inherits (sequence mutable-sequence mutable-collection
+ generic-sequence collection))
+ (cons
+ :codes (#.sb!vm:list-pointer-type)
+ :translation cons
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection))
+ (null
+ :translation (member nil)
+ :inherits (list sequence
+ mutable-sequence mutable-collection
+ generic-sequence collection symbol)
+ :direct-superclasses (list symbol))
+
(ratio
:translation (and rational (not integer))
:inherits (rational real number generic-number)
:inherits (integer rational real number
generic-number)
:codes (#.sb!vm:bignum-type))
-
- (list
- :translation (or cons (member nil))
- :inherits (sequence mutable-sequence mutable-collection
- generic-sequence collection))
- (cons
- :codes (#.sb!vm:list-pointer-type)
- :translation cons
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection))
- (null
- :translation (member nil)
- :inherits (list sequence
- mutable-sequence mutable-collection
- generic-sequence collection symbol)
- :direct-superclasses (list symbol))
(stream
:hierarchical-p nil
:state :read-only
;;; See also type-init.lisp where we finish setting up the
;;; translations for built-in types.
(!cold-init-forms
- #-sb-xc-host (/show0 "about to loop over *BUILT-IN-CLASSES*")
(dolist (x *built-in-classes*)
#-sb-xc-host (/show0 "at head of loop over *BUILT-IN-CLASSES*")
(destructuring-bind
inherits-vector
depthoid)
:invalidate nil)))))
- #-sb-xc-host (/show0 "done with loop over *BUILT-IN-CLASSES*"))
+ (/show0 "done with loop over *BUILT-IN-CLASSES*"))
;;; Define temporary PCL STANDARD-CLASSes. These will be set up
-;;; correctly and the lisp layout replaced by a PCL wrapper after PCL
+;;; correctly and the Lisp layout replaced by a PCL wrapper after PCL
;;; is loaded and the class defined.
(!cold-init-forms
+ (/show0 "about to define temporary STANDARD-CLASSes")
(dolist (x '((fundamental-stream (t instance stream))))
+ (/show0 "defining temporary STANDARD-CLASS")
(let* ((name (first x))
(inherits-list (second x))
(class (make-standard-class :name name))
(lambda (x)
(class-layout (sb!xc:find-class x)))
inherits-list)))
+ #-sb-xc-host (/show0 "INHERITS=..") #-sb-xc-host (/hexstr inherits)
(register-layout (find-and-init-or-check-layout name 0 inherits -1)
- :invalidate nil)))))
+ :invalidate nil))))
+ (/show0 "done defining temporary STANDARD-CLASSes"))
;;; Now that we have set up the class heterarchy, seal the sealed
;;; classes. This must be done after the subclasses have been set up.
#!+sb-doc
"Invoke the signal facility on a condition formed from datum and arguments.
If the condition is not handled, the debugger is invoked."
- (/show0 "entering ERROR, arguments=..")
+ (/show0 "entering ERROR, argument list=..")
+ (/hexstr arguments)
+ (/show0 "printing ERROR arguments one by one..")
#!+sb-show (dolist (argument arguments)
(sb!impl::cold-print argument))
(sb!kernel:infinite-error-protect
(and (>= (length name) 2)
(string= name "*!" :end1 2 :end2 2)))
(/show0 "uninterning cold-init-only symbol..")
- #!+sb-show (%primitive print name)
+ (/primitive-print name)
(unintern symbol package)
(setf any-changes? t)))))
(unless any-changes?
(%halt))
#!+gengc
-(defun do-load-time-value-fixup (object offset index)
+(defun !do-load-time-value-fixup (object offset index)
(declare (type index offset))
(let ((value (svref *!load-time-values* index)))
(typecase object
;; not to use it for the COLD-INIT-OR-REINIT functions.)
(sb!xc:defmacro show-and-call (name)
`(progn
- #!+sb-show (%primitive print ,(symbol-name name))
+ (/primitive-print ,(symbol-name name))
(,name))))
;;; called when a cold system starts up
;; -- WHN 19991204
(/show0 "doing cold toplevel forms and fixups")
(/show0 "(LISTP *!REVERSED-COLD-TOPLEVELS*)=..")
- #!+sb-show (%primitive print
- (if (listp *!reversed-cold-toplevels*) "true" "NIL"))
+ (/hexstr (if (listp *!reversed-cold-toplevels*) "true" "NIL"))
(/show0 "about to calculate (LENGTH *!REVERSED-COLD-TOPLEVELS*)")
(/show0 "(LENGTH *!REVERSED-COLD-TOPLEVELS*)=..")
#!+sb-show (let ((r-c-tl-length (length *!reversed-cold-toplevels*)))
(/show0 "(length calculated..)")
- (let ((hexstr (sb!impl::hexstr r-c-tl-length)))
+ (let ((hexstr (hexstr r-c-tl-length)))
(/show0 "(hexstr calculated..)")
- (%primitive print hexstr)))
+ (/primitive-print hexstr)))
(let (#!+sb-show (index-in-cold-toplevels 0))
#!+sb-show (declare (type fixnum index-in-cold-toplevels))
(dolist (toplevel-thing (prog1
#!+sb-show
(when (zerop (mod index-in-cold-toplevels 1024))
(/show0 "INDEX-IN-COLD-TOPLEVELS=..")
- (%primitive print (sb!impl::hexstr index-in-cold-toplevels)))
+ (/hexstr index-in-cold-toplevels))
#!+sb-show
(setf index-in-cold-toplevels
(the fixnum (1+ index-in-cold-toplevels)))
(get-lisp-obj-address
(svref *!load-time-values* (third toplevel-thing))))
#!+gengc
- (do-load-time-value-fixup (second toplevel-thing)
- (third toplevel-thing)
- (fourth toplevel-thing)))
+ (!do-load-time-value-fixup (second toplevel-thing)
+ (third toplevel-thing)
+ (fourth toplevel-thing)))
#!+(and x86 gencgc)
(:load-time-code-fixup
- (sb!vm::do-load-time-code-fixup (second toplevel-thing)
- (third toplevel-thing)
- (fourth toplevel-thing)
- (fifth toplevel-thing)))
+ (sb!vm::!do-load-time-code-fixup (second toplevel-thing)
+ (third toplevel-thing)
+ (fourth toplevel-thing)
+ (fifth toplevel-thing)))
(t
(!cold-lose "bogus fixup code in *!REVERSED-COLD-TOPLEVELS*"))))
(t (!cold-lose "bogus function in *!REVERSED-COLD-TOPLEVELS*")))))
funcallable-instance
sb!alien-internals:alien-value)))
(values nil t))
- ((typep target-type 'sb!xc::structure-class)
+ (;; special case when TARGET-TYPE isn't a type spec, but instead
+ ;; a CLASS object
+ (typep target-type 'sb!xc::structure-class)
;; SBCL-specific types which have an analogue specially created
;; on the host system
(if (sb!xc:subtypep (sb!xc:class-name target-type)
'sb!kernel::structure!object)
- (values (typep host-object (sb!xc:class-name target-type)) t)
- (values nil t)))
+ (values (typep host-object (sb!xc:class-name target-type)) t)
+ (values nil t)))
((and (symbolp target-type)
(find-class target-type nil)
(subtypep target-type 'sb!kernel::structure!object))
(sb!xc:subtypep target-type 'cl:structure-object)
(typep host-object '(or symbol number list character)))
(values nil t))
- ((and (not (unknown-type-p (values-specifier-type target-type)))
+ (;; easy cases of arrays and vectors
+ (member target-type
+ '(array simple-string simple-vector string vector))
+ (values (typep host-object target-type) t))
+ (;; general cases of vectors
+ (and (not (unknown-type-p (values-specifier-type target-type)))
+ (sb!xc:subtypep target-type 'cl:vector))
+ (if (vectorp host-object)
+ (warn-and-give-up) ; general case of vectors being way too hard
+ (values nil t))) ; but "obviously not a vector" being easy
+ (;; general cases of arrays
+ (and (not (unknown-type-p (values-specifier-type target-type)))
(sb!xc:subtypep target-type 'cl:array))
(if (arrayp host-object)
- (warn-and-give-up) ; general case of arrays being way too hard
- (values nil t))) ; but "obviously not an array" being easy
+ (warn-and-give-up) ; general case of arrays being way too hard
+ (values nil t))) ; but "obviously not an array" being easy
((consp target-type)
(let ((first (first target-type))
(rest (rest target-type)))
(return))
((not sub-certain-p) (setf certain-p nil))))
(if certain-p
- (values opinion t)
- (warn-and-give-up)))))
+ (values opinion t)
+ (warn-and-give-up)))))
;; Some complex types are too hard to handle in the positive
;; case, but at least we can be confident in a large fraction of
;; the negative cases..
((base-string simple-base-string simple-string)
(if (stringp host-object)
- (warn-and-give-up)
- (values nil t)))
- ((array simple-array simple-vector vector)
+ (warn-and-give-up)
+ (values nil t)))
+ ((vector simple-vector)
+ (if (vectorp host-object)
+ (warn-and-give-up)
+ (values nil t)))
+ ((array simple-array)
(if (arrayp host-object)
- (warn-and-give-up)
- (values nil t)))
+ (warn-and-give-up)
+ (values nil t)))
(function
(if (functionp host-object)
- (warn-and-give-up)
- (values nil t)))
+ (warn-and-give-up)
+ (values nil t)))
;; And the Common Lisp type system is complicated, and we don't
;; try to implement everything.
(otherwise (warn-and-give-up)))))
;; assertion:
(assert (typep (specifier-type '*) 'named-type))
(values t t))
- ;; Many simple types are guaranteed to correspond exactly between
- ;; any host ANSI Common Lisp and the target Common Lisp.
- ((array bit character complex cons float function integer list
- nil null number rational real signed-byte string symbol t
- unsigned-byte vector)
+ ;; Many simple types are guaranteed to correspond exactly
+ ;; between any host ANSI Common Lisp and the target
+ ;; Common Lisp. (Some array types are too, but they
+ ;; were picked off earlier.)
+ ((bit character complex cons float function integer list nil
+ null number rational real signed-byte symbol t unsigned-byte)
(values (typep host-object target-type) t))
;; Floating point types are guaranteed to correspond, too, but
;; less exactly.
;; cases..
((base-string simple-base-string simple-string)
(if (stringp host-object)
- (warn-and-give-up)
- (values nil t)))
+ (warn-and-give-up)
+ (values nil t)))
((character base-char)
(cond ((typep host-object 'standard-char)
(values t t))
;; questions that the cross-compiler asks that it's well worth
;; special-casing it here.
(if (symbolp host-object)
- (values nil t)
- (warn-and-give-up)))
+ (values nil t)
+ (warn-and-give-up)))
;; And the Common Lisp type system is complicated, and we don't
;; try to implement everything.
(otherwise (warn-and-give-up)))))))
;; A program that calls TYPEP doesn't want uncertainty and probably
;; can't handle it.
(if certain-p
- opinion
- (error "uncertain in SB!XC:TYPEP ~S ~S"
- host-object
- target-type-spec))))
+ opinion
+ (error "uncertain in SB!XC:TYPEP ~S ~S"
+ host-object
+ target-type-spec))))
;;; This implementation is an incomplete, portable version for use at
;;; cross-compile time only.
(typecase x
(function
(if (typep x 'generic-function)
- ;; Since at cross-compile time we build a CLOS-free bootstrap version of
- ;; SBCL, it's unclear how to explain to it what a generic function is.
- (error "not implemented: cross CTYPE-OF generic function")
- ;; There's no ANSI way to find out what the function is declared to
- ;; be, so we just return the CTYPE for the most-general function.
- *universal-function-type*))
+ ;; Since at cross-compile time we build a CLOS-free bootstrap
+ ;; version of SBCL, it's unclear how to explain to it what a
+ ;; generic function is.
+ (error "not implemented: cross CTYPE-OF generic function")
+ ;; There's no ANSI way to find out what the function is
+ ;; declared to be, so we just return the CTYPE for the
+ ;; most-general function.
+ *universal-function-type*))
(symbol
(make-member-type :members (list x)))
(number
;; The following two locations are the more arg context and count.
;;
;; <any other symbol>
- ;; The following location is the value of the keyword argument with the
+ ;; The following location is the value of the &KEY argument with the
;; specified name.
;;
;; This may be NIL to save space. If no symbols are present, then this will
(push (frob final-arg debug-vars) res))
(:keyword
(push (list :keyword
- (sb!c::arg-info-keyword info)
+ (sb!c::arg-info-key info)
(frob final-arg debug-vars))
res))
(:rest
res))
(sb!c::more-arg
;; Just ignore the fact that the next two args are
- ;; the more arg context and count, and act like they
+ ;; the &MORE arg context and count, and act like they
;; are regular arguments.
nil)
(t
- ;; keyword arg
+ ;; &KEY arg
(push (list :keyword
ele
(compiled-debug-function-lambda-list-var
;;; those variables are invalid.)
(defun make-valid-lisp-obj (val)
(/show0 "entering MAKE-VALID-LISP-OBJ, VAL=..")
- #!+sb-show (%primitive print (sb!impl::hexstr val))
+ #!+sb-show (/hexstr val)
(if (or
;; fixnum
(zerop (logand val 3))
(defun sub-access-debug-var-slot (fp sc-offset &optional escaped)
(declare (type system-area-pointer fp))
(/show0 "entering SUB-ACCESS-DEBUG-VAR-SLOT, FP,SC-OFFSET,ESCAPED=..")
- #!+sb-show (%primitive print (sb!impl::hexstr fp))
- #!+sb-show (%primitive print (sb!impl::hexstr sc-offset))
- #!+sb-show (%primitive print (sb!impl::hexstr escaped))
+ (/hexstr fp) (/hexstr sc-offset) (/hexstr escaped)
(macrolet ((with-escaped-value ((var) &body forms)
`(if escaped
(let ((,var (sb!vm:context-register
escaped
(sb!c:sc-offset-offset sc-offset))))
(/show0 "in escaped case, ,VAR value=..")
- #!+sb-show (%primitive print (sb!impl::hexstr ,var))
+ (/hexstr ,var)
,@forms)
:invalid-value-for-unescaped-register-storage))
(escaped-float-value (format)
(without-gcing
(with-escaped-value (val)
(/show0 "VAL=..")
- #!+sb-show (%primitive print (sb!impl::hexstr val))
+ (/hexstr val)
(make-valid-lisp-obj val))))
(#.sb!vm:base-char-reg-sc-number
(/show0 "case of BASE-CHAR-REG-SC-NUMBER")
;;; EVAL-WHEN, which might be easier to understand than the current
;;; approach based on IR1 magic. -- WHN 19990811
(def!macro defmacro-mundanely (name lambda-list &body body)
- `(setf (sb!xc:macro-function ',name)
- ,(let ((whole (gensym "WHOLE-"))
- (environment (gensym "ENVIRONMENT-")))
- (multiple-value-bind (new-body local-decs doc)
- (parse-defmacro lambda-list whole body name 'defmacro
- :environment environment)
- (declare (ignore doc))
- `(lambda (,whole ,environment)
- ,@local-decs
- (block ,name
- ,new-body))))))
+ `(progn
+ (setf (sb!xc:macro-function ',name)
+ ,(let ((whole (gensym "WHOLE-"))
+ (environment (gensym "ENVIRONMENT-")))
+ (multiple-value-bind (new-body local-decs doc)
+ (parse-defmacro lambda-list whole body name 'defmacro
+ :environment environment)
+ (declare (ignore doc))
+ `(lambda (,whole ,environment)
+ ,@local-decs
+ (block ,name
+ ,new-body)))))
+ ',name))
;;;; files for more information.
(in-package "SB!KERNEL")
+
+(/show0 "code/defstruct.lisp 15")
\f
;;;; getting LAYOUTs
(sb!xc:defmacro defstruct (name-and-options &rest slot-descriptions)
#!+sb-doc
"DEFSTRUCT {Name | (Name Option*)} {Slot | (Slot [Default] {Key Value}*)}
- Define the structure type Name. Instances are created by MAKE-<name>, which
- takes keyword arguments allowing initial slot values to the specified.
+ Define the structure type Name. Instances are created by MAKE-<name>,
+ which takes &KEY arguments allowing initial slot values to the specified.
A SETF'able function <name>-<slot> is defined for each slot to read and
write slot values. <name>-p is a type predicate.
(rest args)))
(inherits (inherits-for-structure defstruct)))
(function-%compiler-only-defstruct defstruct inherits)))
+
+(/show0 "code/defstruct.lisp end of file")
;;;; files for more information.
(in-package "SB!KERNEL")
+
+(/show0 "deftypes-for-target.lisp 14")
\f
;;;; Now that DEFTYPE is set up, any pending requests for it can
;;;; be honored.
`(integer 0 (,(ash 1 sb!vm:single-float-digits))))
(sb!xc:deftype double-float-significand ()
`(integer 0 (,(ash 1 sb!vm:double-float-digits))))
+
+(/show0 "deftypes-for-target.lisp end of file")
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *profile-hash-cache* nil))
+;;; a flag for whether it's too early in cold init to use caches so
+;;; that we have a better chance of recovering so that we have a
+;;; better chance of getting the system running so that we have a
+;;; better chance of diagnosing the problem which caused us to use the
+;;; caches too early
+#!+sb-show
+(defvar *hash-caches-initialized-p*)
+
;;; :INIT-WRAPPER is set to COLD-INIT-FORMS in type system definitions
;;; so that caches will be created before top-level forms run.
(defmacro define-hash-cache (name args &key hash-function hash-bits default
(inits `(unless (boundp ',var-name)
(setq ,var-name (make-array ,total-size))))
+ #!+sb-show (inits `(setq *hash-caches-initialized-p* t))
`(progn
(defvar ,var-name)
(defun ,name ,arg-names
,@decls
,doc
- (multiple-value-bind ,(values-names)
- (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
- (if (and ,@(mapcar #'(lambda (val def)
- `(eq ,val ,def))
- (values-names) default-values))
- (multiple-value-bind ,(values-names)
- (progn ,@body)
- (,(symbolicate name "-CACHE-ENTER") ,@arg-names
- ,@(values-names))
- (values ,@(values-names)))
- (values ,@(values-names))))))))))
+ (cond #!+sb-show
+ ((not (boundp '*hash-caches-initialized-p*))
+ ;; This shouldn't happen, but it did happen to me
+ ;; when revising the type system, and it's a lot
+ ;; easier to figure out what what's going on with
+ ;; that kind of problem if the system can be kept
+ ;; alive until cold boot is complete. The recovery
+ ;; mechanism should definitely be conditional on
+ ;; some debugging feature (e.g. SB-SHOW) because
+ ;; it's big, duplicating all the BODY code. -- WHN
+ (/show0 ,name " too early in cold init, uncached")
+ (/show0 ,(first arg-names) "=..")
+ (/hexstr ,(first arg-names))
+ ,@body)
+ (t
+ (multiple-value-bind ,(values-names)
+ (,(symbolicate name "-CACHE-LOOKUP") ,@arg-names)
+ (if (and ,@(mapcar (lambda (val def)
+ `(eq ,val ,def))
+ (values-names) default-values))
+ (multiple-value-bind ,(values-names)
+ (progn ,@body)
+ (,(symbolicate name "-CACHE-ENTER") ,@arg-names
+ ,@(values-names))
+ (values ,@(values-names)))
+ (values ,@(values-names))))))))))))
\f
;;;; package idioms
(or (built-in-class-translation spec) spec)
spec))
(t
- (let* (;; FIXME: This
+ (let* (;; FIXME: This automatic promotion of FOO-style
+ ;; specs to (FOO)-style specs violates the ANSI
+ ;; standard. Unfortunately, we can't fix the
+ ;; problem just by removing it, since then things
+ ;; downstream should break. But at some point we
+ ;; should fix this and the things downstream too.
(lspec (if (atom spec) (list spec) spec))
(fun (info :type :translator (car lspec))))
- (cond (fun (funcall fun lspec))
+ (cond (fun
+ (funcall fun lspec))
((or (and (consp spec) (symbolp (car spec)))
(symbolp spec))
(when *type-system-initialized*
(optional nil :type list)
;; The type for the rest arg. NIL if there is no rest arg.
(rest nil :type (or ctype null))
- ;; True if keyword arguments are specified.
+ ;; true if &KEY arguments are specified
(keyp nil :type boolean)
- ;; List of key-info structures describing the keyword arguments.
+ ;; list of KEY-INFO structures describing the &KEY arguments
(keywords nil :type list)
- ;; True if other keywords are allowed.
+ ;; true if other &KEY arguments are allowed
(allowp nil :type boolean))
(defstruct (values-type
(:copier nil))
(name nil :type symbol))
+;;; a list of all the float "formats" (i.e. internal representations;
+;;; nothing to do with #'FORMAT), in order of decreasing precision
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *float-formats*
+ '(long-float double-float single-float short-float)))
+
+;;; The type of a float format.
+(deftype float-format () `(member ,@*float-formats*))
+
;;; A NUMERIC-TYPE represents any numeric type, including things
;;; such as FIXNUM.
(defstruct (numeric-type (:include ctype
'number)))
#!+negative-zero-is-not-zero
(:constructor %make-numeric-type))
- ;; The kind of numeric type we have. NIL if not specified (just NUMBER or
- ;; COMPLEX).
+ ;; the kind of numeric type we have, or NIL if not specified (just
+ ;; NUMBER or COMPLEX)
;;
;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
;; Especially when a CLASS value *is* stored in another slot (called
;; all numeric types" but this slot doesn't allow COMPLEX as an
;; option.. how does this fall into "not specified" NIL case above?
(class nil :type (member integer rational float nil))
- ;; Format for a float type. NIL if not specified or not a float. Formats
- ;; which don't exist in a given implementation don't appear here.
- (format nil :type (or float-format null))
- ;; Is this a complex numeric type? Null if unknown (only in NUMBER.)
+ ;; "format" for a float type (i.e. type specifier for a CPU
+ ;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
+ ;; to do with #'FORMAT), or NIL if not specified or not a float.
+ ;; Formats which don't exist in a given implementation don't appear
+ ;; here.
+ (format nil
+ ;; FIXME: suppressed because of cold init problems under
+ ;; hacked type system in sbcl-0.6.11.13, should be restored
+ #+nil :type #+nil (or float-format null))
+ ;; Is this a complex numeric type? Null if unknown (only in NUMBER).
;;
;; FIXME: I'm bewildered by FOO-P names for things not intended to
;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
(low nil :type (or number cons null))
(high nil :type (or number cons null)))
-;;; The Array-Type is used to represent all array types, including
+;;; An ARRAY-TYPE is used to represent any array type, including
;;; things such as SIMPLE-STRING.
(defstruct (array-type (:include ctype
(class-info (type-class-or-lose 'array)))
;; the things in the set, with no duplications
(members nil :type list))
-;;; A COMPOUND-TYPE is a type defined out of a set of types,
-;;; the common parent of UNION-TYPE and INTERSECTION-TYPE.
+;;; A COMPOUND-TYPE is a type defined out of a set of types, the
+;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
(defstruct (compound-type (:include ctype)
(:constructor nil)
(:copier nil))
- (types nil :type list :read-only t))
+ (types nil
+ ;; FIXME: This type declaration was suppresed as a temporary
+ ;; hack to work around sbcl-0.6.11.13 cold init problems.
+ ;; Restore it.
+ #+nil :type #+nil list
+ :read-only t))
-;;; A UNION-TYPE represents a use of the OR type specifier which can't
-;;; be canonicalized to something simpler. Canonical form:
-;;; 1. There is never more than one MEMBER-TYPE component.
+;;; A UNION-TYPE represents a use of the OR type specifier which we
+;;; couldn't canonicalize to something simpler. Canonical form:
+;;; 1. All possible pairwise simplifications (using the UNION2 type
+;;; methods) have been performed. Thus e.g. there is never more
+;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
+;;; this hadn't been fully implemented yet.
;;; 2. There are never any UNION-TYPE components.
(defstruct (union-type (:include compound-type
(class-info (type-class-or-lose 'union)))
(:copier nil)))
;;; An INTERSECTION-TYPE represents a use of the AND type specifier
-;;; which can't be canonicalized to something simpler. Canonical form:
-;;; 1. There is never more than one MEMBER-TYPE component.
-;;; 2. There are never any INTERSECTION-TYPE or UNION-TYPE components.
+;;; which we couldn't canonicalize to something simpler. Canonical form:
+;;; 1. All possible pairwise simplifications (using the INTERSECTION2
+;;; type methods) have been performed. Thus e.g. there is never more
+;;; than one MEMBER-TYPE component.
+;;; 2. There are never any INTERSECTION-TYPE components: we've
+;;; flattened everything into a single INTERSECTION-TYPE object.
+;;; 3. There are never any UNION-TYPE components. Either we should
+;;; use the distributive rule to rearrange things so that
+;;; unions contain intersections and not vice versa, or we
+;;; should just punt to using a HAIRY-TYPE.
(defstruct (intersection-type (:include compound-type
(class-info (type-class-or-lose
'intersection)))
type))
;;; A CONS-TYPE is used to represent a CONS type.
-(defstruct (cons-type (:include ctype
- (:class-info (type-class-or-lose 'cons)))
+(defstruct (cons-type (:include ctype (:class-info (type-class-or-lose 'cons)))
(:constructor
;; ANSI says that for CAR and CDR subtype
;; specifiers '* is equivalent to T. In order
(/show0 "default case")
(let ((file (concatenate 'string directory name)))
(/show0 "computed basic FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(unless (or (null type) (eq type :unspecific))
(/show0 "tweaking FILE for more-or-less-:UNSPECIFIC case")
(setf file (concatenate 'string file "." type)))
(setf file (concatenate 'string file "."
(quick-integer-to-string version))))
(/show0 "finished possibly tweaking FILE=..")
- #!+sb-show (%primitive print file)
+ (/primitive-print file)
(when (or (not verify-existence)
(sb!unix:unix-file-kind file t))
(/show0 "calling FUNCTION on FILE")
#!+sb-doc
"Tests whether the directories containing the specified file
actually exist, and attempts to create them if they do not.
- Portable programs should avoid using the :MODE keyword argument."
+ Portable programs should avoid using the :MODE argument."
(let* ((pathname (pathname pathspec))
(pathname (if (typep pathname 'logical-pathname)
(translate-logical-pathname pathname)
(defun get-floating-point-modes ()
#!+sb-doc
- "This function returns a list representing the state of the floating point
- modes. The list is in the same format as the keyword arguments to
+ "This function returns a list representing the state of the floating
+ point modes. The list is in the same format as the &KEY arguments to
SET-FLOATING-POINT-MODES, i.e.
(apply #'set-floating-point-modes (get-floating-point-modes))
The style keyword can be :SHORT (numeric date), :LONG (months and
weekdays expressed as words), :ABBREVIATED (like :LONG but words are
abbreviated), or :GOVERNMENT (of the form \"XX Month XXXX XX:XX:XX\")
- The keyword argument DATE-FIRST, if nil, will print the time first instead
- of the date (the default). The PRINT- keywords, if nil, inhibit
+ The &KEY argument :DATE-FIRST, if NIL, will print the time first instead
+ of the date (the default). The PRINT- keywords, if NIL, inhibit
the printing of the obvious part of the time/date."
(unless (valid-destination-p destination)
(error "~A: Not a valid format destination." destination))
#!+sb-doc
"The total CPU time spent doing garbage collection (as reported by
GET-INTERNAL-RUN-TIME.)")
-
(declaim (type index *gc-run-time*))
+;;; a limit to help catch programs which allocate too much memory,
+;;; since a hard heap overflow is so hard to recover from.
+(declaim (type (or unsigned-byte null) *soft-heap-limit*))
+(defvar *soft-heap-limit* nil)
+
;;; Internal trigger. When the dynamic usage increases beyond this
;;; amount, the system notes that a garbage collection needs to occur by
;;; setting *NEED-TO-COLLECT-GARBAGE* to T. It starts out as NIL meaning
(/show0 "not *ALREADY-MAYBE-GCING*")
(let* ((*already-maybe-gcing* t)
(start-time (get-internal-run-time))
- (pre-gc-dyn-usage (dynamic-usage)))
+ (pre-gc-dyn-usage (dynamic-usage))
+ ;; Currently we only check *SOFT-HEAP-LIMIT* at GC time,
+ ;; not for every allocation. That makes it cheap to do,
+ ;; even if it is a little ugly.
+ (soft-heap-limit-exceeded? (and *soft-heap-limit*
+ (> pre-gc-dyn-usage
+ *soft-heap-limit*)))
+ (*soft-heap-limit* (if soft-heap-limit-exceeded?
+ (+ pre-gc-dyn-usage
+ *bytes-consed-between-gcs*)
+ *soft-heap-limit*)))
+ (when soft-heap-limit-exceeded?
+ (cerror "Continue with GC."
+ "soft heap limit exceeded (temporary new limit=~D)"
+ *soft-heap-limit*))
(unless (integerp (symbol-value '*bytes-consed-between-gcs*))
;; The noise w/ symbol-value above is to keep the compiler
;; from optimizing the test away because of the type declaim
(/show0 "back from FUNCALL to *INTERNAL-GC*")
(let* ((post-gc-dyn-usage (dynamic-usage))
(bytes-freed (- pre-gc-dyn-usage post-gc-dyn-usage)))
+ (/show0 "got (DYNAMIC-USAGE) and BYTES-FREED")
(when *last-bytes-in-use*
+ (/show0 "doing *LAST-BYTES-IN-USE* thing")
(incf *total-bytes-consed*
(- pre-gc-dyn-usage *last-bytes-in-use*))
+ (/show0 "setting *LAST-BYTES-IN-USE*")
(setq *last-bytes-in-use* post-gc-dyn-usage))
+ (/show0 "clearing *NEED-TO-COLLECT-GARBAGE*")
(setf *need-to-collect-garbage* nil)
+ (/show0 "calculating NEW-GC-TRIGGER")
(let ((new-gc-trigger (+ post-gc-dyn-usage
*bytes-consed-between-gcs*)))
+ (/show0 "setting *GC-TRIGGER*")
(setf *gc-trigger* new-gc-trigger))
+ (/show0 "calling SET-AUTO-GC-TRIGGER")
(set-auto-gc-trigger *gc-trigger*)
(dolist (hook *after-gc-hooks*)
(/show0 "doing a hook from *AFTER-GC--HOOKS*")
;;;; files for more information.
(in-package "SB!ALIEN")
+
+(/show0 "host-alieneval.lisp 15")
\f
;;;; utility functions
(when (eq kind :alien)
`(%heap-alien-addr ',(info :variable :alien-info form))))))
(error "~S is not a valid L-value." form))))
+
+(/show0 "host-alieneval.lisp end of file")
(in-package "SB!C-CALL")
+(/show0 "host-c-call.lisp 12")
+
(def-alien-type-class (c-string :include pointer :include-args (to)))
(def-alien-type-translator c-string ()
(null (int-sap 0))
((alien (* char)) (alien-sap ,value))
(simple-base-string (vector-sap ,value))))
+
+(/show0 "host-c-call.lisp end of file")
:datum object
:expected-type (layout-class layout)))
-(deferr odd-keyword-arguments-error ()
+(deferr odd-key-arguments-error ()
(error 'simple-program-error
:function-name name
- :format-control "odd number of keyword arguments"))
+ :format-control "odd number of &KEY arguments"))
-(deferr unknown-keyword-argument-error (key)
+(deferr unknown-key-argument-error (key-name)
(error 'simple-program-error
:function-name name
- :format-control "unknown keyword: ~S"
- :format-arguments (list key)))
+ :format-control "unknown &KEY argument: ~S"
+ :format-arguments (list key-name)))
(deferr invalid-array-index-error (array bound index)
(error 'simple-error
(defun internal-error (context continuable)
(declare (type system-area-pointer context) (ignore continuable))
(/show0 "entering INTERNAL-ERROR, CONTEXT=..")
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
+ (/hexstr context)
(infinite-error-protect
(let ((context (locally
(declare (optimize (inhibit-warnings 3)))
(defun cis (theta)
#!+sb-doc
"Return cos(Theta) + i sin(Theta), AKA exp(i Theta)."
- (if (complexp theta)
- (error "Argument to CIS is complex: ~S" theta)
- (complex (cos theta) (sin theta))))
+ (declare (type real theta))
+ (complex (cos theta) (sin theta)))
(defun asin (number)
#!+sb-doc
#!+sb-infinities x)
;;; Given a list of keyword substitutions `(,OLD ,NEW), and a
-;;; keyword-argument-list-style list of alternating keywords and arbitrary
-;;; values, return a new keyword-argument-list-style list with all
-;;; substitutions applied to it.
+;;; &KEY-argument-list-style list of alternating keywords and
+;;; arbitrary values, return a new &KEY-argument-list-style list with
+;;; all substitutions applied to it.
;;;
-;;; Note: If efficiency mattered, we could do less consing. (But if efficiency
-;;; mattered, why would we be using keyword arguments at all, much less
-;;; renaming keyword arguments?)
+;;; Note: If efficiency mattered, we could do less consing. (But if
+;;; efficiency mattered, why would we be using &KEY arguments at
+;;; all, much less renaming &KEY arguments?)
;;;
;;; KLUDGE: It would probably be good to get rid of this. -- WHN 19991201
-(defun rename-keyword-args (rename-list keyword-args)
- (declare (type list rename-list keyword-args))
+(defun rename-key-args (rename-list key-args)
+ (declare (type list rename-list key-args))
;; Walk through RENAME-LIST modifying RESULT as per each element in
;; RENAME-LIST.
- (do ((result (copy-list keyword-args))) ; may be modified below
+ (do ((result (copy-list key-args))) ; may be modified below
((null rename-list) result)
(destructuring-bind (old new) (pop rename-list)
- (declare (type keyword old new))
- ;; Walk through RESULT renaming any OLD keyword argument to NEW.
+ ;; ANSI says &KEY arg names aren't necessarily KEYWORDs.
+ (declare (type symbol old new))
+ ;; Walk through RESULT renaming any OLD key argument to NEW.
(do ((in-result result (cddr in-result)))
((null in-result))
(declare (type list in-result))
\f
;;;; the CONDITION class
+(/show0 "late-target-error.lisp 20")
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(def!struct (condition-class (:include slot-class)
(defun make-condition-class (&rest rest)
(apply #'bare-make-condition-class
- (rename-keyword-args '((:name :%name)) rest)))
+ (rename-key-args '((:name :%name)) rest)))
) ; EVAL-WHEN
(define-nil-returning-restart use-value (value)
"Transfer control and VALUE to a restart named USE-VALUE, or return NIL if
none exists."))
+
+(/show0 "late-target-error.lisp end of file")
+
(in-package "SB!KERNEL")
+(/show0 "late-type.lisp 19")
+
(!begin-collecting-cold-init-forms)
;;; ### Remaining incorrectnesses:
(if subtypep-arg1
(funcall subtypep-arg1 type1 type2)
(values nil t))))
-(defun delegate-complex-intersection (type1 type2)
- (let ((method (type-class-complex-intersection (type-class-info type1))))
- (if (and method (not (eq method #'delegate-complex-intersection)))
+(defun delegate-complex-intersection2 (type1 type2)
+ (let ((method (type-class-complex-intersection2 (type-class-info type1))))
+ (if (and method (not (eq method #'delegate-complex-intersection2)))
(funcall method type2 type1)
- (vanilla-intersection type1 type2))))
+ (hierarchical-intersection2 type1 type2))))
;;; This is used by !DEFINE-SUPERCLASSES to define the SUBTYPE-ARG1
;;; method. INFO is a list of conses
(!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)
- #'delegate-complex-intersection)))))
+ (setf (type-class-complex-intersection2 ,type-class)
+ #'delegate-complex-intersection2)))))
\f
;;;; FUNCTION and VALUES types
;;;;
;;;; -- Many of the places that can be annotated with real types can
;;;; also be annotated with function or values types.
-;;; the description of a keyword argument
+;;; the description of a &KEY argument
(defstruct (key-info #-sb-xc-host (:pure t)
(:copier nil))
- ;; the keyword
- (name (required-argument) :type keyword)
+ ;; the key (not necessarily a keyword in ANSI)
+ (name (required-argument) :type symbol)
;; the type of the argument value
(type (required-argument) :type ctype))
(!define-type-method (values :simple-subtypep :complex-subtypep-arg1)
- (type1 type2)
+ (type1 type2)
(declare (ignore type2))
- (error "Subtypep is illegal on this type:~% ~S" (type-specifier type1)))
+ ;; FIXME: should be TYPE-ERROR, here and in next method
+ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type1)))
(!define-type-method (values :complex-subtypep-arg2)
- (type1 type2)
+ (type1 type2)
(declare (ignore type1))
- (error "Subtypep is illegal on this type:~% ~S" (type-specifier type2)))
+ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2)))
(!define-type-method (values :unparse) (type)
(cons 'values (unparse-args-types type)))
(!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-intersection2) (type1 type2)
(declare (ignore type1 type2))
- (values (specifier-type 'function) t))
+ (specifier-type 'function))
;;; ### Not very real, but good enough for redefining transforms
;;; according to type:
(t
(make-union-type-or-something (list type1 type2)))))))
-;;; Return as restrictive a type as we can discover that is no more
-;;; restrictive than the intersection of TYPE1 and TYPE2. The second
-;;; value is true if the result is exact. At worst, we randomly return
-;;; one of the arguments as the first value (trying not to return a
-;;; hairy type).
-(defun-cached (type-intersection :hash-function type-cache-hash
- :hash-bits 8
- :values 2
- :default (values nil :empty)
- :init-wrapper !cold-init-forms)
+;;; the type method dispatch case of TYPE-INTERSECTION2
+(defun %type-intersection2 (type1 type2)
+ ;; We want to give both argument orders a chance at
+ ;; COMPLEX-INTERSECTION2. Without that, the old CMU CL type
+ ;; methods could give noncommutative results, e.g.
+ ;; (TYPE-INTERSECTION2 *EMPTY-TYPE* SOME-HAIRY-TYPE)
+ ;; => NIL, NIL
+ ;; (TYPE-INTERSECTION2 SOME-HAIRY-TYPE *EMPTY-TYPE*)
+ ;; => #<NAMED-TYPE NIL>, T
+ ;; We also need to distinguish between the case where we found a
+ ;; type method, and it returned NIL, and the case where we fell
+ ;; through without finding any type method. An example of the first
+ ;; case is the intersection of a HAIRY-TYPE with some ordinary type.
+ ;; An example of the second case is the intersection of two
+ ;; completely-unrelated types, e.g. CONS and NUMBER, or SYMBOL and
+ ;; ARRAY.
+ ;;
+ ;; (Why yes, CLOS probably *would* be nicer..)
+ (flet ((1way (x y)
+ (!invoke-type-method :simple-intersection2 :complex-intersection2
+ x y
+ :default :no-type-method-found)))
+ (declare (inline 1way))
+ (let ((xy (1way type1 type2)))
+ (or (and (not (eql xy :no-type-method-found)) xy)
+ (let ((yx (1way type2 type1)))
+ (or (and (not (eql yx :no-type-method-found)) yx)
+ (cond ((and (eql xy :no-type-method-found)
+ (eql yx :no-type-method-found))
+ *empty-type*)
+ (t
+ (assert (and (not xy) (not yx))) ; else handled above
+ nil))))))))
+
+(defun-cached (type-intersection2 :hash-function type-cache-hash
+ :hash-bits 8
+ :values 1
+ :default nil
+ :init-wrapper !cold-init-forms)
((type1 eq) (type2 eq))
(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))))
+ (cond ((eq type1 type2)
+ type1)
+ ((or (intersection-type-p type1)
+ (intersection-type-p type2))
+ ;; Intersections of INTERSECTION-TYPE should have the
+ ;; INTERSECTION-TYPE-TYPES objects broken out and intersected
+ ;; separately. The full TYPE-INTERSECTION function knows how
+ ;; to do that, so let it handle it.
+ (type-intersection type1 type2))
+ (t
+ ;; the ordinary case: we dispatch to type methods
+ (%type-intersection2 type1 type2))))
+
+;;; Return as restrictive and simple a type as we can discover that is
+;;; no more restrictive than the intersection of TYPE1 and TYPE2. At
+;;; worst, we arbitrarily return one of the arguments as the first
+;;; value (trying not to return a hairy type).
+(defun type-approx-intersection2 (type1 type2)
+ (cond ((type-intersection2 type1 type2))
+ ((hairy-type-p type1) type2)
+ (t type1)))
;;; The first value is true unless the types don't intersect. The
;;; second value is true if the first value is definitely correct. NIL
;;; is considered to intersect with any type. If T is a subtype of
-;;; either type, then we also return T, T. This way we consider hairy
-;;; types to intersect with T.
+;;; either type, then we also return T, T. This way we recognize
+;;; that hairy types might intersect with T.
+;;;
+;;; FIXME: It would be more accurate to call this TYPES-MIGHT-INTERSECT,
+;;; and rename VALUES-TYPES-INTERSECT the same way.
(defun types-intersect (type1 type2)
(declare (type ctype type1 type2))
(if (or (eq type1 *empty-type*) (eq type2 *empty-type*))
(values t t)
- (multiple-value-bind (val winp) (type-intersection type1 type2)
- (cond ((not winp)
+ (let ((intersection2 (type-intersection2 type1 type2)))
+ (cond ((not intersection2)
(if (or (csubtypep *universal-type* type1)
(csubtypep *universal-type* type2))
(values t t)
(values t nil)))
- ((eq val *empty-type*) (values nil t))
+ ((eq intersection2 *empty-type*) (values nil t))
(t (values t t))))))
;;; Return a Common Lisp type specifier corresponding to the TYPE
(setf (info :type :kind spec) :primitive))))
(values))
\f
+;;;; general TYPE-UNION and TYPE-INTERSECTION operations
+;;;;
+;;;; These are fully general operations on CTYPEs: they'll always
+;;;; return a CTYPE representing the result.
+
+;;; shared logic for unions and intersections: Stuff TYPE into the
+;;; vector TYPES, finding pairs of types which can be simplified by
+;;; SIMPLIFY2 and replacing them by their simplified forms.
+(defun accumulate-compound-type (type types simplify2)
+ (declare (type ctype type))
+ (declare (type (vector t) types))
+ (declare (type function simplify2))
+ (dotimes (i (length types) (vector-push-extend type types))
+ (let ((simplified2 (funcall simplify2 type (aref types i))))
+ (when simplified2
+ ;; Discard the old (AREF TYPES I).
+ (setf (aref types i) (vector-pop types))
+ ;; Add the new SIMPLIFIED2 to TYPES, by tail recursing.
+ (return (accumulate-compound-type simplified2
+ types
+ simplify2)))))
+ (values))
+
+;;; shared logic for unions and intersections: Make a COMPOUND-TYPE
+;;; object whose components are the types in TYPES, or skip to
+;;; special cases when TYPES-VECTOR is short.
+(defun make-compound-type-or-something (constructor types enumerable identity)
+ (declare (type function constructor))
+ (declare (type (vector t) types))
+ (declare (type ctype identity))
+ (case (length types)
+ (0 identity)
+ (1 (the ctype (aref types 0)))
+ (t (funcall constructor enumerable (coerce types 'list)))))
+
+(defun type-intersection (&rest input-types)
+ (let (;; components of our result, accumulated as a vector
+ (simplified-types (make-array (length input-types) :fill-pointer 0)))
+ (flet ((accumulate (type)
+ (accumulate-compound-type type
+ simplified-types
+ #'type-intersection2)))
+ (declare (inline accumulate))
+ (dolist (type input-types)
+ (if (intersection-type-p type)
+ (map nil #'accumulate (intersection-type-types type))
+ (accumulate type)))
+ ;; We want to have a canonical representation of types (or failing
+ ;; that, punt to HAIRY-TYPE). Canonical representation would have
+ ;; intersections inside unions but not vice versa, since you can
+ ;; always achieve that by the distributive rule. But we don't want
+ ;; to just apply the distributive rule, since it would be too easy
+ ;; to end up with unreasonably huge type expressions. So instead
+ ;; we punt to HAIRY-TYPE when this comes up.
+ (if (and (> (length simplified-types) 1)
+ (some #'union-type-p simplified-types))
+ (make-hairy-type
+ :specifier `(and ,@(map 'list #'type-specifier simplified-types)))
+ (make-compound-type-or-something #'%make-intersection-type
+ simplified-types
+ (some #'type-enumerable
+ simplified-types)
+ *universal-type*)))))
+
+;;; FIXME: Define TYPE-UNION similar to TYPE-INTERSECTION.
+\f
;;;; built-in types
(!define-type-class named)
(frob t *universal-type*)))
(!define-type-method (named :simple-=) (type1 type2)
+ ;; FIXME: BUG 85: This assertion failed when I added it in
+ ;; sbcl-0.6.11.13. It probably shouldn't fail; but for now it's
+ ;; just commented out.
+ ;;(assert (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (eq type1 type2) t))
(!define-type-method (named :simple-subtypep) (type1 type2)
+ (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
(values (or (eq type1 *empty-type*) (eq type2 *wild-type*)) t))
(!define-type-method (named :complex-subtypep-arg1) (type1 type2)
- (assert (not (hairy-type-p type2)))
+ (assert (not (eq type1 *wild-type*))) ; * isn't really a type.
+ ;; FIXME: Why does this (old CMU CL) assertion hold? Perhaps 'cause
+ ;; the HAIRY-TYPE COMPLEX-SUBTYPEP-ARG2 method takes precedence over
+ ;; this COMPLEX-SUBTYPE-ARG1 method? (I miss CLOS..)
+ (assert (not (hairy-type-p type2)))
+ ;; Besides the old CMU CL assertion above, we also need to avoid
+ ;; compound types, else we could get into trouble with
+ ;; (SUBTYPEP 'T '(OR (SATISFIES FOO) (SATISFIES BAR)))
+ ;; or
+ ;; (SUBTYPEP 'T '(AND (SATISFIES FOO) (SATISFIES BAR))).
+ (assert (not (compound-type-p type2)))
+ ;; Then, since TYPE2 is reasonably tractable, we're good to go.
(values (eq type1 *empty-type*) t))
(!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)
- (vanilla-intersection type1 type2))
+ (assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (cond ((eq type2 *universal-type*)
+ (values t t))
+ ((hairy-type-p type1)
+ (values nil nil))
+ (t
+ ;; FIXME: This seems to rely on there only being 2 or 3
+ ;; HAIRY-TYPE values, and the exclusion of various
+ ;; possibilities above. It would be good to explain it and/or
+ ;; rewrite it so that it's clearer.
+ (values (not (eq type2 *empty-type*)) t))))
+
+(!define-type-method (named :complex-intersection2) (type1 type2)
+ ;; FIXME: This assertion failed when I added it in sbcl-0.6.11.13.
+ ;; Perhaps when bug 85 is fixed it can be reenabled.
+ ;;(assert (not (eq type2 *wild-type*))) ; * isn't really a type.
+ (hierarchical-intersection2 type1 type2))
(!define-type-method (named :unparse) (x)
(named-type-name x))
(!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)
- (type-intersection type1 (specifier-type (cadr hairy-spec)))
- (if win
- (values (eq val *empty-type*) t)
+ (let* ((complement-type2 (specifier-type (cadr hairy-spec)))
+ (intersection2 (type-intersection2 type1
+ complement-type2)))
+ (if intersection2
+ (values (eq intersection2 *empty-type*) t)
(values nil nil))))
(t
(values nil nil)))))
(declare (ignore type1 type2))
(values nil nil))
-(!define-type-method (hairy :simple-intersection :complex-intersection)
- (type1 type2)
- (declare (ignore type2))
- (values type1 nil))
+(!define-type-method (hairy :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ (declare (ignore type1 type2))
+ nil)
(!define-type-method (hairy :complex-union) (type1 type2)
(make-union-type-or-something (list type1 type2)))
\f
;;;; numeric types
-;;; A list of all the float formats, in order of decreasing precision.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defparameter *float-formats*
- '(long-float double-float single-float short-float)))
-
-;;; The type of a float format.
-(deftype float-format () `(member ,@*float-formats*))
-
#!+negative-zero-is-not-zero
(defun make-numeric-type (&key class format (complexp :real) low high
enumerable)
:low lb
:high hb)))
-(defmacro def-bounded-type (type class format)
+(defmacro !def-bounded-type (type class format)
`(!def-type-translator ,type (&optional (low '*) (high '*))
(let ((lb (canonicalized-bound low ',type))
(hb (canonicalized-bound high ',type)))
(error "Lower bound ~S is not less than upper bound ~S." low high))
(make-numeric-type :class ',class :format ',format :low lb :high hb))))
-(def-bounded-type rational rational nil)
-(def-bounded-type float float nil)
-(def-bounded-type real nil nil)
+(!def-bounded-type rational rational nil)
+(!def-bounded-type float float nil)
+(!def-bounded-type real nil nil)
-(defmacro define-float-format (f)
- `(def-bounded-type ,f float ,f))
+(defmacro !define-float-format (f)
+ `(!def-bounded-type ,f float ,f))
-(define-float-format short-float)
-(define-float-format single-float)
-(define-float-format double-float)
-(define-float-format long-float)
+(!define-float-format short-float)
+(!define-float-format single-float)
+(!define-float-format double-float)
+(!define-float-format long-float)
(defun numeric-types-intersect (type1 type2)
(declare (type numeric-type type1 type2))
(if (consp x) (list res) res)))))
nil))
-;;; Handle the case of TYPE-INTERSECTION on two numeric types. We use
+;;; Handle the case of type intersection on two numeric types. We use
;;; TYPES-INTERSECT to throw out the case of types with no
;;; intersection. If an attribute in TYPE1 is unspecified, then we use
;;; TYPE2's attribute, which must be at least as restrictive. If the
;;; 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-intersection2) (type1 type2)
(declare (type numeric-type type1 type2))
(if (numeric-types-intersect type1 type2)
(let* ((class1 (numeric-type-class type1))
'rational))))
(format (or (numeric-type-format type1)
(numeric-type-format type2))))
- (values
- (make-numeric-type
- :class class
- :format format
- :complexp (or (numeric-type-complexp type1)
- (numeric-type-complexp type2))
- :low (numeric-bound-max
- (round-numeric-bound (numeric-type-low type1)
- class format t)
- (round-numeric-bound (numeric-type-low type2)
- class format t)
- > >= nil)
- :high (numeric-bound-max
- (round-numeric-bound (numeric-type-high type1)
- class format nil)
- (round-numeric-bound (numeric-type-high type2)
- class format nil)
- < <= nil))
- t))
- (values *empty-type* t)))
+ (make-numeric-type
+ :class class
+ :format format
+ :complexp (or (numeric-type-complexp type1)
+ (numeric-type-complexp type2))
+ :low (numeric-bound-max
+ (round-numeric-bound (numeric-type-low type1)
+ class format t)
+ (round-numeric-bound (numeric-type-low type2)
+ class format t)
+ > >= nil)
+ :high (numeric-bound-max
+ (round-numeric-bound (numeric-type-high type1)
+ class format nil)
+ (round-numeric-bound (numeric-type-high type2)
+ class format nil)
+ < <= nil)))
+ *empty-type*))
;;; Given two float formats, return the one with more precision. If
;;; either one is null, return NIL.
(t
(values nil t)))))
-(!define-type-method (array :simple-intersection) (type1 type2)
+(!define-type-method (array :simple-intersection2) (type1 type2)
(declare (type array-type type1 type2))
(if (array-types-intersect type1 type2)
(let ((dims1 (array-type-dimensions type1))
(complexp2 (array-type-complexp type2))
(eltype1 (array-type-element-type type1))
(eltype2 (array-type-element-type type2)))
- (values
- (specialize-array-type
- (make-array-type
- :dimensions (cond ((eq dims1 '*) dims2)
- ((eq dims2 '*) dims1)
- (t
- (mapcar (lambda (x y) (if (eq x '*) y x))
- dims1 dims2)))
- :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
- :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1)))
- t))
- (values *empty-type* t)))
+ (specialize-array-type
+ (make-array-type
+ :dimensions (cond ((eq dims1 '*) dims2)
+ ((eq dims2 '*) dims1)
+ (t
+ (mapcar (lambda (x y) (if (eq x '*) y x))
+ dims1 dims2)))
+ :complexp (if (eq complexp1 :maybe) complexp2 complexp1)
+ :element-type (if (eq eltype1 *wild-type*) eltype2 eltype1))))
+ *empty-type*))
;;; Check a supplied dimension list to determine whether it is legal,
;;; and return it in canonical form (as either '* or a list).
(!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))))
+ (t (values nil t))))
-(!define-type-method (member :simple-intersection) (type1 type2)
+(!define-type-method (member :simple-intersection2) (type1 type2)
(let ((mem1 (member-type-members type1))
(mem2 (member-type-members type2)))
- (values (cond ((subsetp mem1 mem2) type1)
- ((subsetp mem2 mem1) type2)
- (t
- (let ((res (intersection mem1 mem2)))
- (if res
- (make-member-type :members res)
- *empty-type*))))
- t)))
+ (cond ((subsetp mem1 mem2) type1)
+ ((subsetp mem2 mem1) type2)
+ (t
+ (let ((res (intersection mem1 mem2)))
+ (if res
+ (make-member-type :members res)
+ *empty-type*))))))
-(!define-type-method (member :complex-intersection) (type1 type2)
+(!define-type-method (member :complex-intersection2) (type1 type2)
(block punt
(collect ((members))
(let ((mem2 (member-type-members type2)))
(dolist (member mem2)
(multiple-value-bind (val win) (ctypep member type1)
(unless win
- (return-from punt (values type2 nil)))
+ (return-from punt nil))
(when val (members member))))
-
- (values (cond ((subsetp mem2 (members)) type2)
- ((null (members)) *empty-type*)
- (t
- (make-member-type :members (members))))
- t)))))
+ (cond ((subsetp mem2 (members)) type2)
+ ((null (members)) *empty-type*)
+ (t
+ (make-member-type :members (members))))))))
;;; 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
;;;; (to the opaque HAIRY-TYPE) on sufficiently complicated types
;;;; involving AND.
-;;; In general, make an INTERSECTION-TYPE object from the specifier
-;;; types. But in various special cases, dodge instead, representing
-;;; the intersection type in some other way.
-(defun make-intersection-type-or-something (types)
- (declare (list types))
- (/show0 "entering MAKE-INTERSECTION-TYPE-OR-SOMETHING")
- (cond ((null types)
- *universal-type*)
- ((null (cdr types))
- (first types))
- (;; if potentially too hairy
- (some (lambda (type)
- ;; Allowing irreducible union types into intersection
- ;; types leads to issues of canonicalization. Those might
- ;; be soluble but it would be nicer just to avoid them
- ;; entirely by punting to HAIRY-TYPE. -- WHN 2001-03-02
- (union-type-p type))
- types)
- ;; (CMU CL punted to HAIRY-TYPE like this for all AND-based
- ;; types. We don't want to do that for simple intersection
- ;; types like the definition of KEYWORD, hence the guard
- ;; clause above. But we do want to punt for any really
- ;; unreasonable cases which might have motivated them to punt
- ;; in all cases, hence the punt-to-HAIRY-TYPE code below.)
- (make-hairy-type :specifier `(and ,@(mapcar #'type-specifier types))))
- (t
- (%make-intersection-type (some #'type-enumerable types) types))))
-
(!define-type-class intersection)
;;; A few intersection types have special names. The others just get
;;; mechanically unparsed.
(!define-type-method (intersection :unparse) (type)
(declare (type ctype type))
- (/show0 "entering INTERSECTION :UNPARSE")
(or (find type '(ratio bignum keyword) :key #'specifier-type :test #'type=)
`(and ,@(mapcar #'type-specifier (intersection-type-types type)))))
;;; shared machinery for type equality: true if every type in the set
;;; TYPES1 matches a type in the set TYPES2 and vice versa
(defun type=-set (types1 types2)
- (/show0 "entering TYPE=-SET")
(flet (;; true if every type in the set X matches a type in the set Y
(type<=-set (x y)
(declare (type list x y))
;;; most about, so it would be good to leverage any ingenuity there
;;; in this more obscure method?
(!define-type-method (intersection :simple-=) (type1 type2)
- (/show0 "entering INTERSECTION :SIMPLE-=")
(type=-set (intersection-type-types type1)
(intersection-type-types type2)))
(!define-type-method (intersection :simple-subtypep) (type1 type2)
- (/show0 "entering INTERSECTION :SIMPLE-SUBTYPEP")
(let ((certain? t))
(dolist (t1 (intersection-type-types type1) (values nil certain?))
(multiple-value-bind (subtypep validp)
(return (values t t))))))))
(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2)
- (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG1")
(any/type (swapped-args-fun #'csubtypep)
type2
(intersection-type-types type1)))
(defun intersection-complex-subtypep-arg2 (type1 type2)
(every/type #'csubtypep type1 (intersection-type-types type2)))
(!define-type-method (intersection :complex-subtypep-arg2) (type1 type2)
- (/show0 "entering INTERSECTION :COMPLEX-SUBTYPEP-ARG2")
(intersection-complex-subtypep-arg2 type1 type2))
-;;; shared logic for unions and intersections: Return a new type list
-;;; where pairs of types which can be simplified by SIMPLIFY2-FUN have
-;;; been replaced by their simplified forms.
-(defun simplify-types (types simplify2-fun)
- (declare (type function simplify2-fun))
- (let (;; our result, accumulated as a vector
- (a (make-array (length types) :fill-pointer 0)))
- (dolist (%type types (coerce a 'list))
- ;; Merge TYPE into RESULT.
- (named-let again ((type %type))
- (dotimes (i (length a) (vector-push-extend type a))
- (let ((ai (aref a i)))
- (multiple-value-bind (simplified win?)
- (funcall simplify2-fun type ai)
- (when win?
- (setf (aref a i) (vector-pop a))
- ;; Give the new SIMPLIFIED its own chance to be
- ;; pairwise simplified w.r.t. elements of A.
- (return (again simplified))))))))))
-
-;;; FIXME: See FIXME note for DEFUN SIMPLIFY2-UNION.
-(defun simplify2-intersection (x y)
- (let ((intersection (type-intersection x y)))
- (if (and (or (intersection-type-p intersection)
- (hairy-type-p intersection))
- (not (intersection-type-p x))
- (not (intersection-type-p y)))
- (values nil nil)
- (values intersection t))))
-
-(!define-type-method (intersection :simple-intersection :complex-intersection)
- (type1 type2)
- (/show0 "entering INTERSECTION :SIMPLE-INTERSECTION :COMPLEX-INTERSECTION")
- (flet ((type-components (type)
- (typecase type
- (intersection-type (intersection-type-types type))
- (t (list type)))))
- (make-intersection-type-or-something
- ;; FIXME: Here and in MAKE-UNION-TYPE and perhaps elsewhere we
- ;; should be looking for simplifications and putting things into
- ;; canonical form.
- (append (type-components type1)
- (type-components type2)))))
-
(!def-type-translator and (&whole whole &rest type-specifiers)
-
- (/show0 "entering type translator for AND")
-
- ;; FIXME: doesn't work (causes cold boot to fail), should probably
- ;; be replaced by something based on simplification of all possible
- ;; pairs
- #|
- (make-intersection-type-or-something
- (mapcar #'specifier-type type-specifiers))
- |#
-
- ;; substantially the old CMU CL code
- ;;
- ;; FIXME: should be replaced by something based on simplification
- ;; of all pairs, not just adjacent pairs
- (let ((res *wild-type*))
- (dolist (type-specifier type-specifiers res)
- (let ((ctype (specifier-type type-specifier)))
- (multiple-value-bind (int win) (type-intersection res ctype)
- (unless win
- (return (make-hairy-type :specifier whole)))
- (setq res int))))))
+ (apply #'type-intersection
+ (mapcar #'specifier-type
+ type-specifiers)))
\f
;;;; union types
;;; recognize a special case which can be represented more simply.
(defun make-union-type-or-something (types)
(declare (list types))
- (/show0 "entering MAKE-UNION-TYPE-OR-SOMETHING")
(cond ((null types)
*empty-type*)
((null (cdr types))
(!define-type-class union)
-;;; The LIST type has a special name. Other union types
-;;; just get mechanically unparsed.
+;;; The LIST type has a special name. Other union types just get
+;;; mechanically unparsed.
(!define-type-method (union :unparse) (type)
(declare (type ctype type))
(if (type= type (specifier-type 'list))
((not subtypep)
(return (values nil t)))))))
-(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+(defun union-complex-subtypep-arg1 (type1 type2)
(every/type (swapped-args-fun #'csubtypep)
type2
(union-type-types type1)))
+(!define-type-method (union :complex-subtypep-arg1) (type1 type2)
+ (union-complex-subtypep-arg1 type1 type2))
(defun union-complex-subtypep-arg2 (type1 type2)
(any/type #'csubtypep type1 (union-type-types type2)))
(dolist (t2 (union-type-types type2) res)
(setq res (type-union res t2)))))
-(!define-type-method (union :simple-intersection :complex-intersection)
- (type1 type2)
- (let ((res *empty-type*)
- (win t))
- (dolist (type (union-type-types type2) (values res win))
- (multiple-value-bind (int w) (type-intersection type1 type)
- (setq res (type-union res int))
- (unless w (setq win nil))))))
-
-;;; FIXME: Obviously, this could be implemented more efficiently if it
-;;; were a primitive. (Making it construct the entire result before
-;;; discarding it because it turns out to be insufficiently simple is
-;;; less than optimum.) A little less obviously, if it were a
-;;; primitive, we could use it a lot more -- basically everywhere we
-;;; do MAKE-UNION-TYPE-OR-SOMETHING. So perhaps this should become
-;;; a primitive; and SIMPLIFY2-INTERSECTION, too, for the same reason.
-(defun simplify2-union (x y)
- (let ((union (type-union x y)))
- (if (and (or (union-type-p union)
- (hairy-type-p union))
- (not (union-type-p x))
- (not (union-type-p y)))
- (values nil nil)
- (values union t))))
+(!define-type-method (union :simple-intersection2 :complex-intersection2)
+ (type1 type2)
+ ;; The CSUBTYPEP clauses here let us simplify e.g.
+ ;; (TYPE-INTERSECTION2 (SPECIFIER-TYPE 'LIST)
+ ;; (SPECIFIER-TYPE '(OR LIST VECTOR)))
+ ;; (where LIST is (OR CONS NULL)).
+ ;;
+ ;; The tests are more or less (CSUBTYPEP TYPE1 TYPE2) and vice
+ ;; versa, but it's important that we pre-expand them into
+ ;; specialized operations on individual elements of
+ ;; UNION-TYPE-TYPES, instead of using the ordinary call to
+ ;; CSUBTYPEP, in order to avoid possibly invoking any methods which
+ ;; might in turn invoke (TYPE-INTERSECTION2 TYPE1 TYPE2) and thus
+ ;; cause infinite recursion.
+ (cond ((union-complex-subtypep-arg2 type1 type2)
+ type1)
+ ((union-complex-subtypep-arg1 type2 type1)
+ type2)
+ (t
+ (let (;; a component of TYPE2 whose intersection with TYPE1
+ ;; is nonempty
+ (nontriv-t2 nil))
+ (dolist (t2 (union-type-types type2) (or nontriv-t2 *empty-type*))
+ (unless (eq *empty-type* (type-intersection type1 t2))
+ (if nontriv-t2 ; if this is second nonempty intersection
+ (return nil) ; too many: can't find nice result
+ (setf nontriv-t2 t2))))))))
(!def-type-translator or (&rest type-specifiers)
- ;; FIXME: new code -- doesn't work?
- #|
- (make-union-type-or-something
- (simplify-types (mapcar #'specifier-type type-specifiers)
- #'simplify2-union))
- |#
- ;; old code
(reduce #'type-union
(mapcar #'specifier-type type-specifiers)
:initial-value *empty-type*))
(make-cons-type (type-union cdr-type1 cdr-type2)
cdr-type1)))))
-(!define-type-method (cons :simple-intersection) (type1 type2)
+(!define-type-method (cons :simple-intersection2) (type1 type2)
(declare (type cons-type type1 type2))
- (multiple-value-bind (int-car win-car)
- (type-intersection (cons-type-car-type type1)
- (cons-type-car-type type2))
- (multiple-value-bind (int-cdr win-cdr)
- (type-intersection (cons-type-cdr-type type1)
- (cons-type-cdr-type type2))
- (values (make-cons-type int-car int-cdr)
- (and win-car win-cdr)))))
+ (let (car-int2
+ cdr-int2)
+ (and (setf car-int2 (type-intersection2 (cons-type-car-type type1)
+ (cons-type-car-type type2)))
+ (setf cdr-int2 (type-intersection2 (cons-type-cdr-type type1)
+ (cons-type-cdr-type type2)))
+ (make-cons-type car-int2 cdr-int2))))
\f
;;; Return the type that describes all objects that are in X but not
;;; in Y. If we can't determine this type, then return NIL.
:complexp nil)))
\f
(!defun-from-collected-cold-init-forms !late-type-cold-init)
+
+(/show0 "late-type.lisp end of file")
\f
;;;; macros for (&KEY (KEY #'IDENTITY) (TEST #'EQL TESTP) (TEST-NOT NIL NOTP))
-;;; Use these with the following keyword args:
+;;; Use these with the following &KEY args:
(defmacro with-set-keys (funcall)
- `(cond ((and testp notp) (error "Test and test-not both supplied."))
+ `(cond ((and testp notp) (error ":TEST and :TEST-NOT were both supplied."))
(notp ,(append funcall '(:key key :test-not test-not)))
(t ,(append funcall '(:key key :test test)))))
(defvar *user-lets* nil) ; LET bindings that the user has explicitly supplied
(declaim (type list *user-lets*))
-;; the default default for unsupplied optional and keyword args
+;; the default default for unsupplied &OPTIONAL and &KEY args
(defvar *default-default* nil)
;;; temps that we introduce and might not reference
;; the "9" entry intentionally left blank for some reason -- WHN 19990806
(defconstant multiple-escape 10)
(defconstant package-delimiter 11)
-(defconstant delimiter 12) ; (a fake for use in read-unqualified-token)
+(defconstant delimiter 12) ; (a fake for use in READ-UNQUALIFIED-TOKEN)
\f
;;;; macros and functions for character tables
;; stored in the character attribute table by having different
;; varieties of constituents.
(character-attribute-table
- (make-array char-code-limit :element-type '(unsigned-byte 8)
+ (make-array char-code-limit
+ :element-type '(unsigned-byte 8)
:initial-element constituent)
:type attribute-table)
;; The CHARACTER-MACRO-TABLE is a vector of CHAR-CODE-LIMIT
documentation about this and other security issues in script-like
programs.)
- The keyword arguments have the following meanings:
+ The &KEY arguments have the following meanings:
:ENVIRONMENT
a list of SIMPLE-STRINGs describing the new Unix environment (as
in \"man environ\"). The default is to copy the environment of
killing the current Lisp invocation in the process (unless it bails
out early because of some argument error or something).
- The following keyword args are defined:
+ The following &KEY args are defined:
:TOPLEVEL
The function to run when the created core file is resumed.
(setf (aref sequence index) newval))))
(defun length (sequence)
- #!+sb-doc "Returns an integer that is the length of SEQUENCE."
+ #!+sb-doc "Return an integer that is the length of SEQUENCE."
(etypecase sequence
(vector (length (truly-the vector sequence)))
(list (length (truly-the list sequence)))))
(defun make-sequence (type length &key (initial-element NIL iep))
#!+sb-doc
- "Returns a sequence of the given Type and Length, with elements initialized
- to :Initial-Element."
+ "Return a sequence of the given TYPE and LENGTH, with elements initialized
+ to :INITIAL-ELEMENT."
(declare (fixnum length))
(let ((type (specifier-type type)))
(cond ((csubtypep type (specifier-type 'list))
result is Nil. Otherwise, the result is a non-negative integer, the index
within Sequence1 of the leftmost position at which they fail to match; or,
if one is shorter than and a matching prefix of the other, the index within
- Sequence1 beyond the last position tested is returned. If a non-Nil
- :From-End keyword argument is given, then one plus the index of the
- rightmost position in which the sequences differ is returned."
+ Sequence1 beyond the last position tested is returned. If a non-NIL
+ :FROM-END argument is given, then one plus the index of the rightmost
+ position in which the sequences differ is returned."
(declare (fixnum start1 start2))
(let* ((length1 (length sequence1))
(end1 (or end1 length1))
;;; a trivial version of /SHOW which only prints a constant string,
;;; implemented at a sufficiently low level that it can be used early
-;;; in cold load
+;;; in cold init
;;;
;;; Unlike the other /SHOW-related functions, this one doesn't test
;;; */SHOW* at runtime, because messing with special variables early
;;; in cold load is too much trouble to be worth it.
-(defmacro /show0 (s)
- (declare (type simple-string s))
- (declare (ignorable s)) ; (for when #!-SB-SHOW)
- #+sb-xc-host `(/show ,s)
- #-sb-xc-host `(progn
- #!+sb-show
- (sb!sys:%primitive print
- ,(concatenate 'simple-string "/" s))))
+(defmacro /show0 (&rest string-designators)
+ ;; We can't use inline MAPCAR here because, at least in 0.6.11.x,
+ ;; this code gets compiled before DO-ANONYMOUS is defined.
+ (declare (notinline mapcar))
+ (let ((s (apply #'concatenate
+ 'simple-string
+ (mapcar #'string string-designators))))
+ (declare (ignorable s)) ; (for when #!-SB-SHOW)
+ #+sb-xc-host `(/show ,s)
+ #-sb-xc-host `(progn
+ #!+sb-show
+ (sb!sys:%primitive print
+ ,(concatenate 'simple-string "/" s)))))
(defmacro /noshow0 (s)
(declare (ignore s)))
+
+;;; low-level display of a string, works even early in cold init
+(defmacro /primitive-print (thing)
+ (declare (ignorable thing)) ; (for when #!-SB-SHOW)
+ #!+sb-show
+ (progn
+ #+sb-xc-host `(/show "(/primitive-print)" ,thing)
+ #-sb-xc-host `(sb!sys:%primitive print (the simple-string ,thing))))
+
+(defmacro /nohexstr (thing)
+ (declare (ignore thing)))
+
+;;; low-level display of a system word, works even early in cold init
+(defmacro /hexstr (thing)
+ (declare (ignorable thing)) ; (for when #!-SB-SHOW)
+ #!+sb-show
+ (progn
+ #+sb-xc-host `(/show "(/hexstr)" ,thing)
+ #-sb-xc-host `(sb!sys:%primitive print (hexstr ,thing))))
+
+(defmacro /nohexstr (thing)
+ (declare (ignore thing)))
\f
(/show0 "done with show.lisp")
;;;; files for more information.
(in-package "SB!KERNEL")
+
+(/show0 "target-defstruct.lisp 12")
\f
;;;; structure frobbing primitives
(dsd-type dsd)
new-value))))
(setf (%instance-ref structure (dsd-index dsd)) new-value)))))
+
+(/show0 "target-defstruct.lisp end of file")
;;; take effect. If the compiler is loaded, we make the
;;; compiler-policy local to LOAD by binding it to itself.
;;;
-;;; FIXME: ANSI specifies an EXTERNAL-FORMAT keyword argument.
+;;; FIXME: ANSI specifies a &KEY :EXTERNAL-FORMAT argument.
;;;
;;; FIXME: Daniel Barlow's ilsb.tar ILISP-for-SBCL patches contain an
;;; implementation of "DEFUN SOURCE-FILE" which claims, in a comment, that CMU
(let* ((pkg (apply #'make-package (first spec)))
(internal (package-internal-symbols pkg))
(external (package-external-symbols pkg)))
- (/show0 "back from MAKE-PACKAGE")
- #!+sb-show (sb!sys:%primitive print (package-name pkg))
+ (/show0 "back from MAKE-PACKAGE, PACKAGE-NAME=..")
+ (/primitive-print (package-name pkg))
;; Put internal symbols in the internal hashtable and set package.
(dolist (symbol (second spec))
;;; return whether the object is of that type as the first value and
;;; second value true. Otherwise return NIL, NIL.
;;;
-;;; We give up on unknown types and pick off FUNCTION and UNION types.
-;;; For structure types, we require that the type be defined in both
-;;; the current and compiler environments, and that the INCLUDES be
-;;; the same.
+;;; We give up on unknown types and pick off FUNCTION- and COMPOUND-
+;;; types. For STRUCTURE- types, we require that the type be defined
+;;; in both the current and compiler environments, and that the
+;;; INCLUDES be the same.
(defun ctypep (obj type)
(declare (type ctype type))
(etypecase type
(values (sb!xc:typep obj type) t)
(values nil nil))
(values nil t)))
- (union-type
- (dolist (mem (union-type-types type) (values nil t))
- (multiple-value-bind (val win) (ctypep obj mem)
- (unless win (return (values nil nil)))
- (when val (return (values t t))))))
+ (compound-type
+ (let ((certain? t))
+ (etypecase type
+ ;; FIXME: The cases here are very similar to #'EVERY/TYPE and
+ ;; #'ANY/TYPE. It would be good to fix them so that they
+ ;; share the same code. (That will require making sure that
+ ;; the two-value return convention for CTYPEP really is
+ ;; exactly compatible with the two-value convention the
+ ;; quantifier/TYPE functions operate on, and probably also
+ ;; making sure that things are inlined and defined early
+ ;; enough that consing can be avoided.)
+ (union-type
+ (dolist (mem (union-type-types type) (values nil certain?))
+ (multiple-value-bind (val win) (ctypep obj mem)
+ (if win
+ (when val (return (values t t)))
+ (setf certain? nil)))))
+ (intersection-type
+ (dolist (mem (intersection-type-types type)
+ (if certain? (values t t) (values nil nil)))
+ (multiple-value-bind (val win) (ctypep obj mem)
+ (if win
+ (unless val (return (values nil t)))
+ (setf certain? nil))))))))
(function-type
(values (functionp obj) t))
(unknown-type
type-union-cache-clear
values-subtypep-cache-clear
csubtypep-cache-clear
- type-intersection-cache-clear
+ type-intersection2-cache-clear
values-type-intersection-cache-clear))
(funcall (symbol-function sym))))
(values))
(/show0 "failing in MUST-SUPPLY-THIS")
(error "missing type method for ~S" foo))
-;;; A TYPE-CLASS object represents the "kind" of a type. It mainly contains
-;;; functions which are methods on that kind of type, but is also used in EQ
-;;; comparisons to determined if two types have the "same kind".
+;;; A TYPE-CLASS object represents the "kind" of a type. It mainly
+;;; contains functions which are methods on that kind of type, but is
+;;; also used in EQ comparisons to determined if two types have the
+;;; "same kind".
(def!struct (type-class
#-no-ansi-print-object
(:print-object (lambda (x stream)
(simple-subtypep #'must-supply-this :type function)
(complex-subtypep-arg1 nil :type (or function null))
(complex-subtypep-arg2 nil :type (or function null))
- ;; SIMPLE-UNION combines two types of the same class into a single
- ;; type of that class. If the result is a two-type union, then
- ;; return NIL. VANILLA-UNION returns whichever argument is a
- ;; supertype of the other, or NIL.
+ ;; SIMPLE-UNION2, COMPLEX-UNION2, SIMPLE-INTERSECTION2, and
+ ;; COMPLEX-INTERSECTION2 methods take pairs of types and try to find
+ ;; a new type which expresses the result nicely, better than could
+ ;; be done by just stuffing the two component types into an
+ ;; UNION-TYPE or INTERSECTION-TYPE object. They return NIL on
+ ;; failure, or a CTYPE for success.
+ ;;
+ ;; Note: These methods are similar to CMU CL's SIMPLE-UNION,
+ ;; COMPLEX-UNION, SIMPLE-INTERSECTION, and COMPLEX-UNION methods.
+ ;; They were reworked in SBCL because SBCL has INTERSECTION-TYPE
+ ;; objects (where CMU CL just punted to HAIRY-TYPE) and because SBCL
+ ;; wants to simplify unions and intersections by considering all
+ ;; possible pairwise simplifications (where the CMU CL code only
+ ;; considered simplifications between types which happened to appear
+ ;; next to each other the argument sequence).
+ ;;
+ ;; Differences in detail from old CMU CL methods:
+ ;; * SBCL's methods are more parallel between union and
+ ;; intersection forms. Each returns one values, (OR NULL CTYPE).
+ ;; * SBCL doesn't use type methods to deal with unions or
+ ;; intersections of the COMPOUND-TYPE of the corresponding form.
+ ;; Instead the wrapper functions TYPE-UNION2, TYPE-INTERSECTION2,
+ ;; TYPE-UNION, and TYPE-INTERSECTION handle those cases specially
+ ;; (and deal with canonicalization/simplification issues at the
+ ;; same time).
+ ;;
+ ;; FIXME: SIMPLE-UNION and COMPLEX-UNION methods haven't been
+ ;; converted to the new scheme yet. (Thus they never return NIL, I
+ ;; think. -- WHN 2001-03-11)
(simple-union #'vanilla-union :type function)
(complex-union nil :type (or function null))
- ;; The default intersection methods assume that if one type is a
- ;; subtype of the other, then that type is the intersection.
- (simple-intersection #'vanilla-intersection :type function)
- (complex-intersection nil :type (or function null))
+ (simple-intersection2 #'hierarchical-intersection2 :type function)
+ (complex-intersection2 nil :type (or function null))
(simple-= #'must-supply-this :type function)
(complex-= nil :type (or function null))
;; a function which returns a Common Lisp type specifier
(defun copy-type-class-coldly (x)
;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here will have
;; to be hand-tweaked to match. -- WHN 19991021
- (make-type-class :name (type-class-name x)
+ (make-type-class :name (type-class-name x)
:simple-subtypep (type-class-simple-subtypep x)
:complex-subtypep-arg1 (type-class-complex-subtypep-arg1 x)
:complex-subtypep-arg2 (type-class-complex-subtypep-arg2 x)
:simple-union (type-class-simple-union x)
- :complex-union (type-class-complex-union x)
- :simple-intersection (type-class-simple-intersection x)
- :complex-intersection (type-class-complex-intersection x)
- :simple-= (type-class-simple-= x)
- :complex-= (type-class-complex-= x)
- :unparse (type-class-unparse x)))
+ :complex-union (type-class-complex-union x)
+ :simple-intersection2 (type-class-simple-intersection2 x)
+ :complex-intersection2 (type-class-complex-intersection2 x)
+ :simple-= (type-class-simple-= x)
+ :complex-= (type-class-complex-= x)
+ :unparse (type-class-unparse x)))
;;; KLUDGE: If the slots of TYPE-CLASS ever change, the slots here
;;; will have to be tweaked to match. -- WHN 19991021
(:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
(:simple-union . type-class-simple-union)
(:complex-union . type-class-complex-union)
- (:simple-intersection . type-class-simple-intersection)
- (:complex-intersection . type-class-complex-intersection)
+ (:simple-intersection2 . type-class-simple-intersection2)
+ (:complex-intersection2 . type-class-complex-intersection2)
(:simple-= . type-class-simple-=)
(:complex-= . type-class-complex-=)
(:unparse . type-class-unparse)))
;;; 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.
+;;;
+;;; KLUDGE: It might be a lot easier to understand this and the rest
+;;; of the type system code if we used CLOS to express it instead of
+;;; trying to maintain this squirrely hand-crufted object system.
+;;; Unfortunately that'd require reworking PCL bootstrapping so that
+;;; all the compilation can get done by the cross-compiler, which I
+;;; suspect is hard, so we'll bear with the old system for the time
+;;; being. -- WHN 2001-03-11
(defmacro !invoke-type-method (simple complex-arg2 type1 type2 &key
(default '(values nil t))
(complex-arg1 :foo complex-arg1-p))
(dolist (x *built-in-classes*)
(destructuring-bind (name &key (translation nil trans-p) &allow-other-keys)
x
- #+sb-show (progn
- (/show0 "doing class with name=..")
- #+sb-xc-host (/show0 name)
- #-sb-xc-host (%primitive print (symbol-name name)))
+ (/show0 "doing class with NAME=..")
+ (/primitive-print (symbol-name name))
(when trans-p
(/show0 "in TRANS-P case")
(let ((class (class-cell-class (find-class-cell name)))
(:constructor nil)
(:make-load-form-fun make-type-load-form)
#-sb-xc-host (:pure t))
- ;; The class of this type.
+ ;; the class of this type
;;
;; FIXME: It's unnecessarily confusing to have a structure accessor
;; named TYPE-CLASS-INFO which is an accessor for the CTYPE structure
;; even though the TYPE-CLASS structure also exists in the system.
;; Rename this slot: TYPE-CLASS or ASSOCIATED-TYPE-CLASS or something.
(class-info (required-argument) :type type-class)
- ;; True if this type has a fixed number of members, and as such could
- ;; possibly be completely specified in a MEMBER type. This is used by the
- ;; MEMBER type methods.
- (enumerable nil :type (member t nil) :read-only t)
- ;; an arbitrary hash code used in EQ-style hashing of identity (since EQ
- ;; hashing can't be done portably)
+ ;; True if this type has a fixed number of members, and as such
+ ;; could possibly be completely specified in a MEMBER type. This is
+ ;; used by the MEMBER type methods.
+ (enumerable nil :read-only t)
+ ;; an arbitrary hash code used in EQ-style hashing of identity
+ ;; (since EQ hashing can't be done portably)
(hash-value (random (1+ most-positive-fixnum))
:type (and fixnum unsigned-byte)
:read-only t))
(lambda (x y)
(funcall fun y x)))
-;;; Compute the intersection for types that intersect only when one is a
-;;; hierarchical subtype of the other.
-(defun vanilla-intersection (type1 type2)
- (multiple-value-bind (stp1 win1) (csubtypep type1 type2)
- (multiple-value-bind (stp2 win2) (csubtypep type2 type1)
- (cond (stp1 (values type1 t))
- (stp2 (values type2 t))
- ((and win1 win2) (values *empty-type* t))
- (t
- (values type1 nil))))))
+;;; Look for a nice intersection for types that intersect only when
+;;; one is a hierarchical subtype of the other.
+(defun hierarchical-intersection2 (type1 type2)
+ (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
+ (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
+ (cond (subtypep1 type1)
+ (subtypep2 type2)
+ ((and win1 win2) *empty-type*)
+ (t nil)))))
(defun vanilla-union (type1 type2)
(cond ((csubtypep type1 type2) type2)
#+sb-xc-host (ctypep object type)
#-sb-xc-host (class-typep (layout-of object) type object))
(union-type
- (some (lambda (typ) (%%typep object typ))
+ (some (lambda (union-type-type) (%%typep object union-type-type))
(union-type-types type)))
(intersection-type
- (every (lambda (typ) (%%typep object typ))
+ (every (lambda (intersection-type-type)
+ (%%typep object intersection-type-type))
(intersection-type-types type)))
(cons-type
(and (consp object)
;;; load time instead of in GENESIS. It's probably simple, I just haven't
;;; figured it out, or found it written down anywhere. -- WHN 19990908
#!+gencgc
-(defun do-load-time-code-fixup (code offset fixup kind)
+(defun !do-load-time-code-fixup (code offset fixup kind)
(flet ((add-load-time-code-fixup (code offset)
(let ((fixups (code-header-ref code sb!vm:code-constants-offset)))
(cond ((typep fixups '(simple-array (unsigned-byte 32) (*)))
(setf (code-header-ref code sb!vm:code-constants-offset)
new-fixups)))
(t
- ;; FIXME: This doesn't look like production code, and
- ;; should be a fatal error, not just a print.
(unless (or (eq (get-type fixups)
sb!vm:unbound-marker-type)
(zerop fixups))
- (%primitive print "** Init. code FU"))
+ (sb!impl::!cold-lose "Argh! can't process fixup"))
(setf (code-header-ref code sb!vm:code-constants-offset)
(make-specializable-array
1
(defun internal-error-arguments (context)
(declare (type (alien (* os-context-t)) context))
(/show0 "entering INTERNAL-ERROR-ARGUMENTS, CONTEXT=..")
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr context))
+ (/hexstr context)
(let ((pc (context-pc context)))
(declare (type system-area-pointer pc))
;; using INT3 the pc is .. INT3 <here> code length bytes...
(declare (type (unsigned-byte 8) length)
(type (simple-array (unsigned-byte 8) (*)) vector))
(/show0 "LENGTH,VECTOR,ERROR-NUMBER=..")
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr length))
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr vector))
+ (/hexstr length)
+ (/hexstr vector)
(copy-from-system-area pc (* sb!vm:byte-bits 2)
vector (* sb!vm:word-bits
sb!vm:vector-data-offset)
(* length sb!vm:byte-bits))
(let* ((index 0)
(error-number (sb!c::read-var-integer vector index)))
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr error-number))
+ (/hexstr error-number)
(collect ((sc-offsets))
(loop
(/show0 "INDEX=..")
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr index))
+ (/hexstr index)
(when (>= index length)
(return))
(let ((sc-offset (sb!c::read-var-integer vector index)))
(/show0 "SC-OFFSET=..")
- #!+sb-show (sb!sys:%primitive print (sb!impl::hexstr sc-offset))
+ (/hexstr sc-offset)
(sc-offsets sc-offset)))
(values error-number (sc-offsets)))))))
\f
;;; Compile the source file whose basic name is STEM, using some
;;; standard-for-the-SBCL-build-process procedures to generate the full
;;; pathnames of source file and object file. Return the pathname of the object
-;;; file for STEM. Several keyword arguments are accepted:
-;;; SRC-PREFIX, SRC-SUFFIX =
-;;; strings to be concatenated to STEM to produce source filename
-;;; OBJ-PREFIX, OBJ-SUFFIX =
-;;; strings to be concatenated to STEM to produce object filename
-;;; TMP-OBJ-SUFFIX-SUFFIX
-;;; string to be appended to the name of an object file to produce the
-;;; name of a temporary object file
-;;; COMPILE-FILE, IGNORE-FAILURE-P =
-;;; COMPILE-FILE is a function to use for compiling the file (with the
-;;; same calling conventions as ANSI CL:COMPILE-FILE). If the third
-;;; return value (FAILURE-P) of this function is true, a continuable
-;;; error will be signalled, unless IGNORE-FAILURE-P is set, in which
-;;; case only a warning will be signalled.
+;;; file for STEM. Several &KEY arguments are accepted:
+;;; :SRC-PREFIX, :SRC-SUFFIX =
+;;; strings to be concatenated to STEM to produce source filename
+;;; :OBJ-PREFIX, :OBJ-SUFFIX =
+;;; strings to be concatenated to STEM to produce object filename
+;;; :TMP-OBJ-SUFFIX-SUFFIX =
+;;; string to be appended to the name of an object file to produce
+;;; the name of a temporary object file
+;;; :COMPILE-FILE, :IGNORE-FAILURE-P =
+;;; :COMPILE-FILE is a function to use for compiling the file (with the
+;;; same calling conventions as ANSI CL:COMPILE-FILE). If the third
+;;; return value (FAILURE-P) of this function is true, a continuable
+;;; error will be signalled, unless :IGNORE-FAILURE-P is set, in which
+;;; case only a warning will be signalled.
(defun compile-stem (stem
&key
(obj-prefix "")
;; :NOT-HOST is also set, since the SBCL assembler doesn't exist
;; while the cross-compiler is being built in the host ANSI Lisp.)
:assem
- ;; meaning: The COMPILE-STEM keyword argument called
- ;; IGNORE-FAILURE-P should be true. (This is a KLUDGE: I'd like to
- ;; get rid of it. For now, it exists so that compilation can
- ;; proceed through the legacy warnings in
- ;; src/compiler/x86/array.lisp, which I've never figured out but
- ;; which were apparently acceptable in CMU CL. Eventually, it
- ;; would be great to just get rid of all warnings and remove
- ;; support for this flag. -- WHN 19990323)
+ ;; meaning: The #'COMPILE-STEM argument called :IGNORE-FAILURE-P
+ ;; should be true. (This is a KLUDGE: I'd like to get rid of it.
+ ;; For now, it exists so that compilation can proceed through the
+ ;; legacy warnings in src/compiler/x86/array.lisp, which I've
+ ;; never figured out but which were apparently acceptable in CMU
+ ;; CL. Eventually, it would be great to just get rid of all
+ ;; warnings and remove support for this flag. -- WHN 19990323)
:ignore-failure-p))
(defparameter *stems-and-flags* (read-from-file "stems-and-flags.lisp-expr"))
;;; The T primitive-type is kept in this variable so that people who
;;; have to special-case it can get at it conveniently. This variable
;;; has to be set by the machine-specific VM definition, since the
-;;; DEF-PRIMITIVE-TYPE for T must specify the SCs that boxed objects
+;;; !DEF-PRIMITIVE-TYPE for T must specify the SCs that boxed objects
;;; can be allocated in.
(defvar *backend-t-primitive-type*)
(declaim (type primitive-type *backend-t-primitive-type*))
(incf num-more)
(setf rest-arg-p t))
(:keyword
+ ;; FIXME: Since ANSI specifies that &KEY arguments
+ ;; needn't actually be keywords, :KEY would be a
+ ;; better label for this behavior than :KEYWORD is,
+ ;; and (KEY-ARGS) would be a better name for the
+ ;; accumulator than (KEYWORDS) is.
(let ((s-p (arg-info-supplied-p arg-info))
(default (arg-info-default arg-info)))
(incf num-more (if s-p 2 1))
- (keywords (list (arg-info-keyword arg-info)
+ (keywords (list (arg-info-key arg-info)
(if (constantp default)
(eval default)
nil)
(in-package "SB!IMPL")
+(/show0 "compiler-deftype.lisp 14")
+
(defun %compiler-deftype (name expander &optional doc)
(ecase (info :type :kind name)
(:primitive
(sb!c::%note-type-defined name)
(warn "defining type before %NOTE-TYPE-DEFINED is defined"))
name)
+
+(/show0 "compiler-deftype.lisp end of file")
(typep
(if not-p
(setq not-res (type-union not-res other))
- (setq res (type-intersection res other))))
+ (setq res (type-approx-intersection2 res other))))
(eql
(let ((other-type (leaf-type other)))
(if not-p
(t
(check-fixed-and-rest args (append required optional) rest)
(when keyp
- (check-keywords args max-args type))))
+ (check-key-args args max-args type))))
(let* ((dtype (node-derived-type call))
(return-type (function-type-returns type))
(check-arg-type (car arg) (car type) n))
(values))
-;;; Check that the keyword args are of the correct type. Each keyword
-;;; should be known and the corresponding argument should be of the
-;;; correct type. If the keyword isn't a constant, then we can't tell,
-;;; so we note slime.
-(declaim (ftype (function (list fixnum function-type) (values)) check-keywords))
-(defun check-keywords (args pre-key type)
+;;; Check that the &KEY args are of the correct type. Each key should
+;;; be known and the corresponding argument should be of the correct
+;;; type. If the key isn't a constant, then we can't tell, so we note
+;;; slime.
+(declaim (ftype (function (list fixnum function-type) (values)) check-key-args))
+(defun check-key-args (args pre-key type)
(do ((key (nthcdr pre-key args) (cddr key))
(n (1+ pre-key) (+ n 2)))
((null key))
(:required (req type))
(:optional (opt type))
(:keyword
- (keys (make-key-info :name (arg-info-keyword info)
+ (keys (make-key-info :name (arg-info-key info)
:type type)))
((:rest :more-context)
(setq rest *universal-type*))
;;;; previous uses.
(defstruct (approximate-function-type (:copier nil))
- ;; The smallest and largest numbers of arguments that this function has been
- ;; called with.
+ ;; the smallest and largest numbers of arguments that this function
+ ;; has been called with.
(min-args call-arguments-limit :type fixnum)
(max-args 0 :type fixnum)
;; A list of lists of the all the types that have been used in each argument
;; position.
(types () :type list)
- ;; A list of the Approximate-Key-Info structures describing all the things
- ;; that looked like keyword arguments. There are distinct structures
- ;; describing each argument position in which the keyword appeared.
+ ;; A list of APPROXIMATE-KEY-INFO structures describing all the
+ ;; things that looked like &KEY arguments. There are distinct
+ ;; structures describing each argument position in which the keyword
+ ;; appeared.
(keys () :type list))
(defstruct (approximate-key-info (:copier nil))
- ;; The keyword name of this argument. Although keyword names don't have to
- ;; be keywords, we only match on keywords when figuring an approximate type.
+ ;; The keyword name of this argument. Although keyword names don't
+ ;; have to be keywords, we only match on keywords when figuring an
+ ;; approximate type.
(name (required-argument) :type keyword)
;; The position at which this keyword appeared. 0 if it appeared as the
;; first argument, etc.
(defun try-type-intersections (vars types where)
(declare (list vars types) (string where))
(collect ((res))
- (mapc #'(lambda (var type)
- (let* ((vtype (leaf-type var))
- (int (type-intersection vtype type)))
- (cond
- ((eq int *empty-type*)
- (note-lossage
- "Definition's declared type for variable ~A:~% ~S~@
+ (mapc (lambda (var type)
+ (let* ((vtype (leaf-type var))
+ (int (type-approx-intersection2 vtype type)))
+ (cond
+ ((eq int *empty-type*)
+ (note-lossage
+ "Definition's declared type for variable ~A:~% ~S~@
conflicts with this type from ~A:~% ~S"
- (leaf-name var) (type-specifier vtype)
- where (type-specifier type))
- (return-from try-type-intersections (values nil nil)))
- (t
- (res int)))))
+ (leaf-name var) (type-specifier vtype)
+ where (type-specifier type))
+ (return-from try-type-intersections (values nil nil)))
+ (t
+ (res int)))))
vars types)
(values vars (res))))
;;; Note that the variables in the returned list are the actual
;;; original variables (extracted from the optional dispatch arglist),
;;; rather than the variables that are arguments to the main entry.
-;;; This difference is significant only for keyword args with hairy
+;;; This difference is significant only for &KEY args with hairy
;;; defaults. Returning the actual vars allows us to use the right
;;; variable name in warnings.
;;;
(flet ((frob (x y what)
(unless (= x y)
(note-lossage
- "Definition has ~R ~A arg~P, but ~A has ~R."
+ "The definition has ~R ~A arg~P, but ~A has ~R."
x what x where y))))
(frob min (length req) "fixed")
(frob (- (optional-dispatch-max-args od) min) (length opt) "optional"))
(flet ((frob (x y what)
(unless (eq x y)
(note-lossage
- "Definition ~:[doesn't have~;has~] ~A, but ~
+ "The definition ~:[doesn't have~;has~] ~A, but ~
~A ~:[doesn't~;does~]."
x what where y))))
(frob (optional-dispatch-keyp od) (function-type-keyp type)
- "keyword args")
+ "&KEY arguments")
(unless (optional-dispatch-keyp od)
(frob (not (null (optional-dispatch-more-entry od)))
(not (null (function-type-rest type)))
- "rest args"))
+ "&REST arguments"))
(frob (optional-dispatch-allowp od) (function-type-allowp type)
- "&allow-other-keys"))
+ "&ALLOW-OTHER-KEYS"))
(when *lossage-detected*
(return-from find-optional-dispatch-types (values nil nil)))
(ctype-of (eval default)))))
(ecase (arg-info-kind info)
(:keyword
- (let* ((key (arg-info-keyword info))
+ (let* ((key (arg-info-key info))
(kinfo (find key keys :key #'key-info-name)))
(cond
(kinfo
:key #'(lambda (x)
(let ((info (lambda-var-arg-info x)))
(when info
- (arg-info-keyword info)))))
+ (arg-info-key info)))))
(note-lossage
- "The definition lacks the ~S keyword present in ~A."
+ "The definition lacks the ~S key present in ~A."
(key-info-name key) where))))
(try-type-intersections (vars) (res) where))))
(note-lossage
"The definition has no ~A, but the ~A did."
what where))))
- (frob (function-type-optional type) "optional args")
- (frob (function-type-keyp type) "keyword args")
- (frob (function-type-rest type) "rest arg"))
+ (frob (function-type-optional type) "&OPTIONAL arguments")
+ (frob (function-type-keyp type) "&KEY arguments")
+ (frob (function-type-rest type) "&REST argument"))
(let* ((vars (lambda-vars lambda))
(nvars (length vars))
(req (function-type-required type))
(cond (info
(case (arg-info-kind info)
(:keyword
- (res (arg-info-keyword info)))
+ (res (arg-info-key info)))
(:rest
(res 'rest-arg))
(:more-context
#|
(defmacro set-disassem-params (&rest args)
#!+sb-doc
- "Specify global disassembler params. Keyword arguments include:
+ "Specify global disassembler params. &KEY arguments include:
:INSTRUCTION-ALIGNMENT number
Minimum alignment of instructions, in bits.
#!+sb-doc
"DEFINE-ARGUMENT-TYPE Name {Key Value}*
Define a disassembler argument type NAME (which can then be referenced in
- another argument definition using the :TYPE keyword argument). Keyword
- arguments are:
+ another argument definition using the :TYPE argument). &KEY args are:
:SIGN-EXTEND boolean
If non-NIL, the raw value of this argument is sign-extended.
#|
%listify-rest-args %more-arg %verify-argument-count %argument-count-error
-%odd-keyword-arguments-error %unknown-keyword-argument-error
+%odd-key-arguments-error %unknown-key-argument-error
|#
(defun %verify-argument-count (supplied-args defined-args)
:format-control "wrong number of arguments passed: ~S"
:format-arguments (list args-passed-count)))
-(defun %odd-keyword-arguments-error ()
+(defun %odd-key-arguments-error ()
(error 'simple-program-error
- :format-control "function called with odd number of keyword arguments"
+ :format-control "function called with odd number of &KEY arguments"
:format-arguments nil))
-(defun %unknown-keyword-argument-error (keyword)
+(defun %unknown-key-argument-error (key-arg-name)
(error 'simple-program-error
- :format-control "unknown keyword argument: ~S"
- :format-arguments (list keyword)))
+ :format-control "unknown &KEY argument: ~S"
+ :format-arguments (list key-arg-name)))
(defun %cleanup-point ())
(defknown %%primitive (t t &rest t) *)
(defknown %pop-values (t) t)
(defknown %type-check-error (t t) nil)
-(defknown %odd-keyword-arguments-error () nil)
-(defknown %unknown-keyword-argument-error (t) nil)
+(defknown %odd-key-arguments-error () nil)
+(defknown %unknown-key-argument-error (t) nil)
(defknown (%ldb %mask-field) (bit-index bit-index integer) unsigned-byte
(movable foldable flushable explicit-check))
(defknown (%dpb %deposit-field) (integer bit-index bit-index integer) integer
;;; comparing the byte order of *BACKEND* to the byte order of
;;; *NATIVE-BACKEND*, a concept which doesn't exist in SBCL. Instead,
;;; in SBCL byte order swapping would need to be explicitly requested
-;;; with a keyword argument to GENESIS.
+;;; with a &KEY argument to GENESIS.
;;;
;;; I'm not sure whether this is a problem or not, and I don't have a
;;; machine with different byte order to test to find out for sure.
\f
;;;; symbol magic
-;;; FIXME: This should be a keyword argument of ALLOCATE-SYMBOL.
+;;; FIXME: This should be a &KEY argument of ALLOCATE-SYMBOL.
(defvar *cold-symbol-allocation-gspace* nil)
;;; Allocate (and initialize) a symbol.
;; much. (And the old CMU CL code is still useful for making
;; sure that the appropriate keywords and internal symbols end
;; up interned in the target Lisp, which is good, e.g. in order
- ;; to make keyword arguments work right and in order to make
+ ;; to make &KEY arguments work right and in order to make
;; BACKTRACEs into target Lisp system code be legible.)
(dolist (exported-name
(sb-cold:read-from-file "common-lisp-exports.lisp-expr"))
"division by zero")
(object-not-type
"Object is of the wrong type.")
- (odd-keyword-arguments
- "odd number of keyword arguments")
- (unknown-keyword-argument
- "unknown keyword")
+ (odd-key-arguments
+ "odd number of &KEY arguments")
+ (unknown-key-argument
+ "unknown &KEY argument")
nil
nil
(invalid-array-index
\f
;;;; primitive type definitions
-(def-primitive-type t (descriptor-reg))
+(/show0 "primtype.lisp 17")
+
+(!def-primitive-type t (descriptor-reg))
+(/show0 "primtype.lisp 20")
(setf *backend-t-primitive-type* (primitive-type-or-lose 't))
;;; primitive integer types that fit in registers
-(def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
+(/show0 "primtype.lisp 24")
+(!def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
:type (unsigned-byte 29))
+(/show0 "primtype.lisp 27")
#!-alpha
-(def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 31))
+(/show0 "primtype.lisp 31")
#!-alpha
-(def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
:type (unsigned-byte 32))
+(/show0 "primtype.lisp 35")
#!+alpha
-(def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
:type (unsigned-byte 63))
#!+alpha
-(def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
+(!def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
:type (unsigned-byte 64))
-(def-primitive-type fixnum (any-reg signed-reg)
+(!def-primitive-type fixnum (any-reg signed-reg)
:type (signed-byte 30))
#!-alpha
-(def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
+(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
:type (signed-byte 32))
#!+alpha
-(def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
+(!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
:type (signed-byte 64))
(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
-(def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
-(def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
- #!-alpha unsigned-byte-31
- #!+alpha unsigned-byte-64
- #!+alpha unsigned-byte-63
- positive-fixnum))
-(def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
- #!+alpha signed-byte-64
- fixnum
- #!-alpha unsigned-byte-31
- #!+alpha unsigned-byte-63
- positive-fixnum))
+(/show0 "primtype.lisp 53")
+(!def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
+(!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-64
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
+(!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
+ #!+alpha signed-byte-64
+ fixnum
+ #!-alpha unsigned-byte-31
+ #!+alpha unsigned-byte-63
+ positive-fixnum))
;;; other primitive immediate types
-(def-primitive-type base-char (base-char-reg any-reg))
+(/show0 "primtype.lisp 68")
+(!def-primitive-type base-char (base-char-reg any-reg))
;;; primitive pointer types
-(def-primitive-type function (descriptor-reg))
-(def-primitive-type list (descriptor-reg))
-(def-primitive-type instance (descriptor-reg))
+(/show0 "primtype.lisp 73")
+(!def-primitive-type function (descriptor-reg))
+(!def-primitive-type list (descriptor-reg))
+(!def-primitive-type instance (descriptor-reg))
-(def-primitive-type funcallable-instance (descriptor-reg))
+(/show0 "primtype.lisp 77")
+(!def-primitive-type funcallable-instance (descriptor-reg))
;;; primitive other-pointer number types
-(def-primitive-type bignum (descriptor-reg))
-(def-primitive-type ratio (descriptor-reg))
-(def-primitive-type complex (descriptor-reg))
-(def-primitive-type single-float (single-reg descriptor-reg))
-(def-primitive-type double-float (double-reg descriptor-reg))
+(/show0 "primtype.lisp 81")
+(!def-primitive-type bignum (descriptor-reg))
+(!def-primitive-type ratio (descriptor-reg))
+(!def-primitive-type complex (descriptor-reg))
+(/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
+(!def-primitive-type single-float (single-reg descriptor-reg))
+(/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
+(!def-primitive-type double-float (double-reg descriptor-reg))
#!+long-float
-(def-primitive-type long-float (long-reg descriptor-reg))
-(def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
+(!def-primitive-type long-float (long-reg descriptor-reg))
+(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
+(!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
:type (complex single-float))
-(def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
+(/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
+(!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
:type (complex double-float))
#!+long-float
-(def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
+(!def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
:type (complex long-float))
;;; primitive other-pointer array types
-(def-primitive-type simple-string (descriptor-reg)
+(/show0 "primtype.lisp 96")
+(!def-primitive-type simple-string (descriptor-reg)
:type simple-base-string)
-(def-primitive-type simple-bit-vector (descriptor-reg))
-(def-primitive-type simple-vector (descriptor-reg))
-(def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
+(!def-primitive-type simple-bit-vector (descriptor-reg))
+(!def-primitive-type simple-vector (descriptor-reg))
+(!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
:type (simple-array (unsigned-byte 2) (*)))
-(def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
+(!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
:type (simple-array (unsigned-byte 4) (*)))
-(def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
+(!def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
:type (simple-array (unsigned-byte 8) (*)))
-(def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
+(!def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
:type (simple-array (unsigned-byte 16) (*)))
-(def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
+(!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
:type (simple-array (unsigned-byte 32) (*)))
-(def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
+(!def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
:type (simple-array (signed-byte 8) (*)))
-(def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
+(!def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
:type (simple-array (signed-byte 16) (*)))
-(def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
+(!def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
:type (simple-array (signed-byte 30) (*)))
-(def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
+(!def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
:type (simple-array (signed-byte 32) (*)))
-(def-primitive-type simple-array-single-float (descriptor-reg)
+(!def-primitive-type simple-array-single-float (descriptor-reg)
:type (simple-array single-float (*)))
-(def-primitive-type simple-array-double-float (descriptor-reg)
+(!def-primitive-type simple-array-double-float (descriptor-reg)
:type (simple-array double-float (*)))
#!+long-float
-(def-primitive-type simple-array-long-float (descriptor-reg)
+(!def-primitive-type simple-array-long-float (descriptor-reg)
:type (simple-array long-float (*)))
-(def-primitive-type simple-array-complex-single-float (descriptor-reg)
+(!def-primitive-type simple-array-complex-single-float (descriptor-reg)
:type (simple-array (complex single-float) (*)))
-(def-primitive-type simple-array-complex-double-float (descriptor-reg)
+(!def-primitive-type simple-array-complex-double-float (descriptor-reg)
:type (simple-array (complex double-float) (*)))
#!+long-float
-(def-primitive-type simple-array-complex-long-float (descriptor-reg)
+(!def-primitive-type simple-array-complex-long-float (descriptor-reg)
:type (simple-array (complex long-float) (*)))
;;; Note: The complex array types are not included, 'cause it is pointless to
;;; restrict VOPs to them.
;;; other primitive other-pointer types
-(def-primitive-type system-area-pointer (sap-reg descriptor-reg))
-(def-primitive-type weak-pointer (descriptor-reg))
+(!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
+(!def-primitive-type weak-pointer (descriptor-reg))
;;; miscellaneous primitive types that don't exist at the LISP level
-(def-primitive-type catch-block (catch-block) :type nil)
+(!def-primitive-type catch-block (catch-block) :type nil)
\f
;;;; PRIMITIVE-TYPE-OF and friends
;;; Return the most restrictive primitive type that contains Object.
+(/show0 "primtype.lisp 147")
(!def-vm-support-routine primitive-type-of (object)
(let ((type (ctype-of object)))
(cond ((not (member-type-p type)) (primitive-type type))
;;; 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 and DEFUN-CACHED.
+(/show0 "primtype.lisp 188")
(!def-vm-support-routine primitive-type (type)
(primitive-type-aux type))
+(/show0 "primtype.lisp 191")
(defun-cached (primitive-type-aux
:hash-function (lambda (x)
(logand (type-hash-value x) #x1FF))
(part-of instance)))
(ctype
(any))))))
+
+(/show0 "primtype.lisp end of file")
(in-package "SB!KERNEL")
+(/show0 "vm-type.lisp 17")
+
(!begin-collecting-cold-init-forms)
\f
;;;; FIXME: I'm not sure where to put this. -- WHN 19990817
nil)))
\f
(!defun-from-collected-cold-init-forms !vm-type-cold-init)
+
+(/show0 "vm-type.lisp end of file")
(eval-when (:compile-toplevel :execute)
(setf *info-classes* (make-hash-table)))
-;;; If Name is the name of a type in Class, then return the TYPE-INFO,
+;;; If NAME is the name of a type in CLASS, then return the TYPE-INFO,
;;; otherwise NIL.
(defun find-type-info (name class)
(declare (type keyword name) (type class-info class))
(declaim (ftype (function (keyword) class-info) class-info-or-lose))
(defun class-info-or-lose (class)
(declare (type keyword class))
- (or (gethash class *info-classes*)
- (error "~S is not a defined info class." class)))
+ #+sb-xc (/noshow0 "entering CLASS-INFO-OR-LOSE, CLASS=..")
+ #+sb-xc (/nohexstr class)
+ (prog1
+ (or (gethash class *info-classes*)
+ (error "~S is not a defined info class." class))
+ #+sb-xc (/noshow0 "returning from CLASS-INFO-OR-LOSE")))
(declaim (ftype (function (keyword keyword) type-info) type-info-or-lose))
(defun type-info-or-lose (class type)
- (or (find-type-info type (class-info-or-lose class))
- (error "~S is not a defined info type." type)))
+ #+sb-xc (/noshow0 "entering TYPE-INFO-OR-LOSE, CLASS,TYPE=..")
+ #+sb-xc (/nohexstr class)
+ #+sb-xc (/nohexstr type)
+ (prog1
+ (or (find-type-info type (class-info-or-lose class))
+ (error "~S is not a defined info type." type))
+ #+sb-xc (/noshow0 "returning from TYPE-INFO-OR-LOSE")))
) ; EVAL-WHEN
\f
(eval-when (:compile-toplevel :execute)
-;;; Set up the data structures to support an info class. We make sure
-;;; that the class exists at compile time so that macros can use it,
-;;; but don't actually store the init function until load time so that
-;;; we don't break the running compiler.
+;;; Set up the data structures to support an info class.
+;;;
+;;; comment from CMU CL:
+;;; We make sure that the class exists at compile time so that
+;;; macros can use it, but we don't actually store the init function
+;;; until load time so that we don't break the running compiler.
+;;; KLUDGE: I don't think that's the way it is any more, but I haven't
+;;; looked into it enough to write a better comment. -- WHN 2001-03-06
(#+sb-xc-host defmacro
#-sb-xc-host sb!xc:defmacro
define-info-class (class)
- #!+sb-doc
- "Define-Info-Class Class
- Define a new class of global information."
(declare (type keyword class))
`(progn
;; (We don't need to evaluate this at load time, compile time is
;;; info environment in names/bucket
(defconstant compact-info-environment-density 65)
-;;; Iterate over the environment once to find out how many names and entries
-;;; it has, then build the result. This code assumes that all the entries for
-;;; a name well be iterated over contiguously, which holds true for the
-;;; implementation of iteration over both kinds of environments.
-;;;
-;;; When building the table, we sort the entries by POINTER< in an attempt
-;;; to preserve any VM locality present in the original load order, rather than
-;;; randomizing with the original hash function.
+;;; Return a new compact info environment that holds the same
+;;; information as ENV.
(defun compact-info-environment (env &key (name (info-env-name env)))
- #!+sb-doc
- "Return a new compact info environment that holds the same information as
- Env."
(let ((name-count 0)
(prev-name 0)
(entry-count 0))
+ (/show0 "before COLLECT in COMPACT-INFO-ENVIRONMENT")
+
+ ;; Iterate over the environment once to find out how many names
+ ;; and entries it has, then build the result. This code assumes
+ ;; that all the entries for a name well be iterated over
+ ;; contiguously, which holds true for the implementation of
+ ;; iteration over both kinds of environments.
(collect ((names))
+
+ (/show0 "at head of COLLECT in COMPACT-INFO-ENVIRONMENT")
(let ((types ()))
(do-info (env :name name :type-number num :value value)
+ (/noshow0 "at head of DO-INFO in COMPACT-INFO-ENVIRONMENT")
(unless (eq name prev-name)
+ (/noshow0 "not (EQ NAME PREV-NAME) case")
(incf name-count)
(unless (eql prev-name 0)
(names (cons prev-name types)))
(incf entry-count)
(push (cons num value) types))
(unless (eql prev-name 0)
+ (/show0 "not (EQL PREV-NAME 0) case")
(names (cons prev-name types))))
+ ;; Now that we know how big the environment is, we can build
+ ;; a table to represent it.
+ ;;
+ ;; When building the table, we sort the entries by pointer
+ ;; comparison in an attempt to preserve any VM locality present
+ ;; in the original load order, rather than randomizing with the
+ ;; original hash function.
+ (/show0 "about to make/sort vectors in COMPACT-INFO-ENVIRONMENT")
(let* ((table-size (primify
(+ (truncate (* name-count 100)
compact-info-environment-density)
:element-type 'compact-info-entry))
(sorted (sort (names)
#+sb-xc-host #'<
+ ;; (This MAKE-FIXNUM hack implements
+ ;; pointer comparison, as explained above.)
#-sb-xc-host (lambda (x y)
- ;; FIXME: What's going on here?
(< (%primitive make-fixnum x)
(%primitive make-fixnum y))))))
+ (/show0 "done making/sorting vectors in COMPACT-INFO-ENVIRONMENT")
(let ((entries-idx 0))
(dolist (types sorted)
(let* ((name (first types))
(setf (aref entries-info entries-idx) num)
(setf (aref entries entries-idx) value)
(incf entries-idx)))
+ (/show0 "done w/ DOLIST (TYPES SORTED) in COMPACT-INFO-ENVIRONMENT")
(unless (zerop entry-count)
+ (/show0 "nonZEROP ENTRY-COUNT")
(setf (aref entries-info (1- entry-count))
(logior (aref entries-info (1- entry-count))
compact-info-entry-last)))
+ (/show0 "falling through to MAKE-COMPACT-INFO-ENV")
(make-compact-info-env :name name
:table table
:index index
(setf *info-types*
(map 'vector
(lambda (x)
+ (/show0 "in LAMBDA (X), X=..")
+ (/hexstr x)
(when x
(let* ((class-info (class-info-or-lose (second x)))
(type-info (make-type-info :name (first x)
:class class-info
:number (third x)
:type (fourth x))))
+ (/show0 "got CLASS-INFO in LAMBDA (X)")
(push type-info (class-info-types class-info))
type-info)))
'#.(map 'list
(declare (type leaf leaf) (type ctype type))
(let ((var-type (leaf-type leaf)))
(unless (function-type-p var-type)
- (let ((int (type-intersection var-type type)))
+ (let ((int (type-approx-intersection2 var-type type)))
(when (type/= int var-type)
(setf (leaf-type leaf) int)
(dolist (ref (leaf-refs leaf))
(int (if (or (function-type-p type)
(function-type-p old-type))
type
- (type-intersection old-type type))))
+ (type-approx-intersection2 old-type type))))
(cond ((eq int *empty-type*)
(unless (policy nil (= inhibit-warnings 3))
(compiler-warning
;;; RES and returning it as a result. VARS and FVARS are as described in
;;; PROCESS-DECLS.
(defun process-1-decl (raw-spec res vars fvars cont)
- (declare (list spec vars fvars) (type lexenv res) (type continuation cont))
+ (declare (type list raw-spec vars fvars))
+ (declare (type lexenv res))
+ (declare (type continuation cont))
(let ((spec (canonized-decl-spec raw-spec)))
(case (first spec)
(special (process-special-decl spec res vars))
(note-lexical-binding name)
(make-lambda-var :name name)))))
-;;; Make the keyword for a keyword arg, checking that the keyword
-;;; isn't already used by one of the Vars. We also check that the
-;;; keyword isn't the magical :allow-other-keys.
+;;; Make the default keyword for a &KEY arg, checking that the keyword
+;;; isn't already used by one of the VARS. We also check that the
+;;; keyword isn't the magical :ALLOW-OTHER-KEYS.
(declaim (ftype (function (symbol list t) keyword) make-keyword-for-arg))
(defun make-keyword-for-arg (symbol vars keywordify)
(let ((key (if (and keywordify (not (keywordp symbol)))
(intern (symbol-name symbol) "KEYWORD")
symbol)))
(when (eq key :allow-other-keys)
- (compiler-error "No keyword arg can be called :ALLOW-OTHER-KEYS."))
+ (compiler-error "No &KEY arg can be called :ALLOW-OTHER-KEYS."))
(dolist (var vars)
(let ((info (lambda-var-arg-info var)))
(when (and info
(eq (arg-info-kind info) :keyword)
- (eq (arg-info-keyword info) key))
+ (eq (arg-info-key info) key))
(compiler-error
"The keyword ~S appears more than once in the lambda-list."
key))))
key))
-;;; Parse a lambda-list into a list of Var structures, stripping off
+;;; Parse a lambda-list into a list of VAR structures, stripping off
;;; any aux bindings. Each arg name is checked for legality, and
;;; duplicate names are checked for. If an arg is globally special,
-;;; the var is marked as :special instead of :lexical. Keyword,
-;;; optional and rest args are annotated with an arg-info structure
+;;; the var is marked as :SPECIAL instead of :LEXICAL. &KEY,
+;;; &OPTIONAL and &REST args are annotated with an ARG-INFO structure
;;; which contains the extra information. If we hit something losing,
-;;; we bug out with Compiler-Error. These values are returned:
-;;; 1. A list of the var structures for each top-level argument.
-;;; 2. A flag indicating whether &key was specified.
-;;; 3. A flag indicating whether other keyword args are allowed.
-;;; 4. A list of the &aux variables.
-;;; 5. A list of the &aux values.
+;;; we bug out with COMPILER-ERROR. These values are returned:
+;;; 1. a list of the var structures for each top-level argument;
+;;; 2. a flag indicating whether &KEY was specified;
+;;; 3. a flag indicating whether other &KEY args are allowed;
+;;; 4. a list of the &AUX variables; and
+;;; 5. a list of the &AUX values.
(declaim (ftype (function (list) (values list boolean boolean list list))
find-lambda-vars))
(defun find-lambda-vars (list)
(names-so-far)
(aux-vars)
(aux-vals))
- ;; Parse-Default deals with defaults and supplied-p args for optionals
- ;; and keywords args.
- (flet ((parse-default (spec info)
+ (flet (;; PARSE-DEFAULT deals with defaults and supplied-p args
+ ;; for optionals and keywords args.
+ (parse-default (spec info)
(when (consp (cdr spec))
(setf (arg-info-default info) (second spec))
(when (consp (cddr spec))
(let ((var (varify-lambda-arg spec (names-so-far))))
(setf (lambda-var-arg-info var)
(make-arg-info :kind :keyword
- :keyword (make-keyword-for-arg spec
- (vars)
- t)))
+ :key (make-keyword-for-arg spec
+ (vars)
+ t)))
(vars var)
(names-so-far spec)))
((atom (first spec))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg name (vars) t))))
+ :key (make-keyword-for-arg name (vars) t))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(t
(let ((head (first spec)))
(unless (proper-list-of-length-p head 2)
- (error "malformed keyword arg specifier: ~S" spec))
+ (error "malformed &KEY argument specifier: ~S" spec))
(let* ((name (second head))
(var (varify-lambda-arg name (names-so-far)))
(info (make-arg-info
:kind :keyword
- :keyword (make-keyword-for-arg (first head)
- (vars)
- nil))))
+ :key (make-keyword-for-arg (first head)
+ (vars)
+ nil))))
(setf (lambda-var-arg-info var) info)
(vars var)
(names-so-far name)
(list (arg-info-default info) nil)
(list (arg-info-default info))))))
-;;; Create the More-Entry function for the Optional-Dispatch Res.
-;;; Entry-Vars and Entry-Vals describe the fixed arguments. Rest is the var
-;;; for any Rest arg. Keys is a list of the keyword arg vars.
+;;; Create the MORE-ENTRY function for the OPTIONAL-DISPATCH RES.
+;;; ENTRY-VARS and ENTRY-VALS describe the fixed arguments. REST is
+;;; the var for any &REST arg. KEYS is a list of the &KEY arg vars.
;;;
-;;; The most interesting thing that we do is parse keywords. We create a
-;;; bunch of temporary variables to hold the result of the parse, and then loop
-;;; over the supplied arguments, setting the appropriate temps for the supplied
-;;; keyword. Note that it is significant that we iterate over the keywords in
-;;; reverse order --- this implements the CL requirement that (when a keyword
-;;; appears more than once) the first value is used.
+;;; The most interesting thing that we do is parse keywords. We create
+;;; a bunch of temporary variables to hold the result of the parse,
+;;; and then loop over the supplied arguments, setting the appropriate
+;;; temps for the supplied keyword. Note that it is significant that
+;;; we iterate over the keywords in reverse order --- this implements
+;;; the CL requirement that (when a keyword appears more than once)
+;;; the first value is used.
;;;
;;; If there is no supplied-p var, then we initialize the temp to the
-;;; default and just pass the temp into the main entry. Since non-constant
-;;; keyword args are forcibly given a supplied-p var, we know that the default
-;;; is constant, and thus safe to evaluate out of order.
+;;; default and just pass the temp into the main entry. Since
+;;; non-constant &KEY args are forcibly given a supplied-p var, we
+;;; know that the default is constant, and thus safe to evaluate out
+;;; of order.
;;;
-;;; If there is a supplied-p var, then we create temps for both the value
-;;; and the supplied-p, and pass them into the main entry, letting it worry
-;;; about defaulting.
+;;; If there is a supplied-p var, then we create temps for both the
+;;; value and the supplied-p, and pass them into the main entry,
+;;; letting it worry about defaulting.
;;;
-;;; We deal with :allow-other-keys by delaying unknown keyword errors until
-;;; we have scanned all the keywords.
+;;; We deal with :ALLOW-OTHER-KEYS by delaying unknown keyword errors
+;;; until we have scanned all the keywords.
;;;
;;; When converting the function, we bind *LEXENV* to change the
;;; compilation policy over to the interface policy, so that keyword
(dolist (key keys)
(let* ((info (lambda-var-arg-info key))
(default (arg-info-default info))
- (keyword (arg-info-keyword info))
+ (keyword (arg-info-key info))
(supplied-p (arg-info-supplied-p info))
(n-value (gensym "N-VALUE-")))
(temps `(,n-value ,default))
(body
`(when (oddp ,n-count)
- (%odd-keyword-arguments-error)))
+ (%odd-key-arguments-error)))
(body
`(locally
(unless allowp
(body `(when (and ,n-losep (not ,n-allowp))
- (%unknown-keyword-argument-error ,n-losep)))))))
+ (%unknown-key-argument-error ,n-losep)))))))
(let ((ep (ir1-convert-lambda-body
`((let ,(temps)
(values))
-;;; Called by IR1-Convert-Hairy-Args when we run into a rest or
-;;; keyword arg. The arguments are similar to that function, but we
-;;; split off any rest arg and pass it in separately. Rest is the rest
-;;; arg var, or NIL if there is no rest arg. Keys is a list of the
-;;; keyword argument vars.
+;;; This is called by IR1-Convert-Hairy-Args when we run into a &REST
+;;; or &KEY arg. The arguments are similar to that function, but we
+;;; split off any &REST arg and pass it in separately. REST is the
+;;; &REST arg var, or NIL if there is no &REST arg. KEYS is a list of
+;;; the &KEY argument vars.
;;;
-;;; When there are keyword arguments, we introduce temporary gensym
+;;; When there are &KEY arguments, we introduce temporary gensym
;;; variables to hold the values while keyword defaulting is in
;;; progress to get the required sequential binding semantics.
;;;
-;;; This gets interesting mainly when there are keyword arguments with
+;;; This gets interesting mainly when there are &KEY arguments with
;;; supplied-p vars or non-constant defaults. In either case, pass in
;;; a supplied-p var. If the default is non-constant, we introduce an
;;; IF in the main entry that tests the supplied-p var and decides
;;; the entry point function will be the same, but when supplied-p args are
;;; present they may be different.
;;;
-;;; When we run into a rest or keyword arg, we punt out to
-;;; IR1-Convert-More, which finishes for us in this case.
+;;; When we run into a &REST or &KEY arg, we punt out to
+;;; IR1-CONVERT-MORE, which finishes for us in this case.
(defun ir1-convert-hairy-args (res default-vars default-vals
entry-vars entry-vals
vars supplied-p-p body aux-vars
(return-from careful-call (values nil nil))))))
t))
\f
-;;;; utilities used at run-time for parsing keyword args in IR1
+;;;; utilities used at run-time for parsing &KEY args in IR1
-;;; This function is used by the result of Parse-Deftransform to find
-;;; the continuation for the value of the keyword argument Key in the
-;;; list of continuations Args. It returns the continuation if the
+;;; This function is used by the result of PARSE-DEFTRANSFORM to find
+;;; the continuation for the value of the &KEY argument KEY in the
+;;; list of continuations ARGS. It returns the continuation if the
;;; keyword is present, or NIL otherwise. The legality and
;;; constantness of the keywords should already have been checked.
(declaim (ftype (function (list keyword) (or continuation null))
(when (eq (continuation-value (first arg)) key)
(return (second arg)))))
-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that alternating continuations in Args are constant and
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that alternating continuations in ARGS are constant and
;;; that there is an even number of args.
-(declaim (ftype (function (list) boolean) check-keywords-constant))
-(defun check-keywords-constant (args)
+(declaim (ftype (function (list) boolean) check-key-args-constant))
+(defun check-key-args-constant (args)
(do ((arg args (cddr arg)))
((null arg) t)
(unless (and (rest arg)
(constant-continuation-p (first arg)))
(return nil))))
-;;; This function is used by the result of Parse-Deftransform to
-;;; verify that the list of continuations Args is a well-formed
-;;; keyword arglist and that only keywords present in the list Keys
-;;; are supplied.
+;;; This function is used by the result of PARSE-DEFTRANSFORM to
+;;; verify that the list of continuations ARGS is a well-formed &KEY
+;;; arglist and that only keywords present in the list KEYS are
+;;; supplied.
(declaim (ftype (function (list list) boolean) check-transform-keys))
(defun check-transform-keys (args keys)
- (and (check-keywords-constant args)
+ (and (check-key-args-constant args)
(do ((arg args (cddr arg)))
((null arg) t)
(unless (member (continuation-value (first arg)) keys)
(in-package "SB!C")
+(/show0 "knownfun.lisp 17")
+
;;; IR1 boolean function attributes
;;;
;;; There are a number of boolean attributes of known functions which we like
(let ((cont (nth (1- n) (combination-args call))))
(when (and cont (constant-continuation-p cont))
(specifier-type (continuation-value cont))))))
+
+(/show0 "knownfun.lisp end of file")
\f
;;;; optional, more and keyword calls
-;;; Similar to Convert-Lambda-Call, but deals with Optional-Dispatches. If
-;;; only fixed args are supplied, then convert a call to the correct entry
-;;; point. If keyword args are supplied, then dispatch to a subfunction. We
-;;; don't convert calls to functions that have a more (or rest) arg.
+;;; This is similar to CONVERT-LAMBDA-CALL, but deals with
+;;; OPTIONAL-DISPATCHes. If only fixed args are supplied, then convert
+;;; a call to the correct entry point. If &KEY args are supplied, then
+;;; dispatch to a subfunction. We don't convert calls to functions
+;;; that have a &MORE (or &REST) arg.
(defun convert-hairy-call (ref call fun)
(declare (type ref ref) (type combination call)
(type optional-dispatch fun))
(dolist (ref (leaf-refs entry))
(convert-call-if-possible ref (continuation-dest (node-cont ref))))))
-;;; Use Convert-Hairy-Fun-Entry to convert a more-arg call to a known
-;;; function into a local call to the Main-Entry.
+;;; Use CONVERT-HAIRY-FUN-ENTRY to convert a &MORE-arg call to a known
+;;; function into a local call to the MAIN-ENTRY.
;;;
;;; First we verify that all keywords are constant and legal. If there
;;; aren't, then we warn the user and don't attempt to convert the call.
;;;
-;;; We massage the supplied keyword arguments into the order expected by the
-;;; main entry. This is done by binding all the arguments to the keyword call
-;;; to variables in the introduced lambda, then passing these values variables
-;;; in the correct order when calling the main entry. Unused arguments
-;;; (such as the keywords themselves) are discarded simply by not passing them
-;;; along.
+;;; We massage the supplied &KEY arguments into the order expected
+;;; by the main entry. This is done by binding all the arguments to
+;;; the keyword call to variables in the introduced lambda, then
+;;; passing these values variables in the correct order when calling
+;;; the main entry. Unused arguments (such as the keywords themselves)
+;;; are discarded simply by not passing them along.
;;;
-;;; If there is a rest arg, then we bundle up the args and pass them to LIST.
+;;; If there is a &REST arg, then we bundle up the args and pass them
+;;; to LIST.
(defun convert-more-call (ref call fun)
(declare (type ref ref) (type combination call) (type optional-dispatch fun))
(let* ((max (optional-dispatch-max-args fun))
(ignores dummy val)
(setq loser name)))
(let ((info (lambda-var-arg-info var)))
- (when (eq (arg-info-keyword info) name)
+ (when (eq (arg-info-key info) name)
(ignores dummy)
(supplied (cons var val))
(return)))))))
`(<= ,min-args ,n-length))
,@(when keyp
(if allowp
- `((check-keywords-constant ,n-keys))
+ `((check-key-args-constant ,n-keys))
`((check-transform-keys ,n-keys ',(keywords))))))
,error-form)
(let ,(binds)
(or (gethash name *backend-meta-primitive-type-names*)
(error "~S is not a defined primitive type." name))))
-;;; If the PRIMITIVE-TYPE structure already exists, we destructively
-;;; modify it so that existing references in templates won't be
-;;; invalidated.
-(defmacro def-primitive-type (name scs &key (type name))
- #!+sb-doc
- "Def-Primitive-Type Name (SC*) {Key Value}*
- Define a primitive type Name. Each SC specifies a Storage Class that values
- of this type may be allocated in. The following keyword options are
- defined:
-
- :Type
- The type descriptor for the Lisp type that is equivalent to this type
- (defaults to Name.)"
+;;; Define a primitive type NAME. Each SCS entry specifies a storage
+;;; class that values of this type may be allocated in. TYPE is the
+;;; type descriptor for the Lisp type that is equivalent to this type.
+(defmacro !def-primitive-type (name scs &key (type name))
(check-type name symbol)
(check-type scs list)
(let ((scns (mapcar #'meta-sc-number-or-lose scs))
(get-type `(specifier-type ',type)))
`(progn
+ (/show0 "doing !DEF-PRIMITIVE-TYPE, NAME=..")
+ (/primitive-print ,(symbol-name name))
(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *backend-meta-primitive-type-names*)
(make-primitive-type :name ',name
,(once-only ((n-old `(gethash ',name *backend-primitive-type-names*))
(n-type get-type))
`(progn
+ ;; If the PRIMITIVE-TYPE structure already exists, we
+ ;; destructively modify it so that existing references in
+ ;; templates won't be invalidated. FIXME: This should no
+ ;; longer be an issue in SBCL, since we don't try to do
+ ;; serious surgery on ourselves. Probably this should
+ ;; just become an assertion that N-OLD is NIL, so that we
+ ;; don't have to try to maintain the correctness of the
+ ;; never-ordinarily-used clause.
+ (/show0 "in !DEF-PRIMITIVE-TYPE, about to COND")
(cond (,n-old
+ (/show0 "in ,N-OLD clause of COND")
(setf (primitive-type-scs ,n-old) ',scns)
(setf (primitive-type-type ,n-old) ,n-type))
(t
+ (/show0 "in T clause of COND")
(setf (gethash ',name *backend-primitive-type-names*)
(make-primitive-type :name ',name
:scs ',scns
:type ,n-type))))
+ (/show0 "done with !DEF-PRIMITIVE-TYPE")
',name)))))
-;;; Just record the translation.
-(defmacro def-primitive-type-alias (name result)
- #!+sb-doc
- "DEF-PRIMITIVE-TYPE-ALIAS Name Result
- Define name to be an alias for Result in VOP operand type restrictions."
+;;; Define NAME to be an alias for RESULT in VOP operand type restrictions.
+(defmacro !def-primitive-type-alias (name result)
+ ;; Just record the translation.
`(eval-when (:compile-toplevel :load-toplevel :execute)
(setf (gethash ',name *backend-primitive-type-aliases*) ',result)
',name))
(make-list (+ (length ops) (if more-ops 1 0)) :initial-element '*)
types))
-;;; Return a list of forms to use as keyword args to Make-VOP-Info for
+;;; Return a list of forms to use as &KEY args to MAKE-VOP-INFO for
;;; setting up the template argument and result types. Here we make an
-;;; initial dummy Template-Type, since it is awkward to compute the
+;;; initial dummy TEMPLATE-TYPE, since it is awkward to compute the
;;; type until the template has been made.
(defun make-vop-info-types (parse)
(let* ((more-args (vop-parse-more-args parse))
(make-generator-function parse)))
:variant (list ,@variant))))
\f
-;;; Parse the syntax into a VOP-Parse structure, and then expand into
-;;; code that creates the appropriate VOP-Info structure at load time.
-;;; We implement inheritance by copying the VOP-Parse structure for
-;;; the inherited structure.
+;;; Define the symbol NAME to be a Virtual OPeration in the compiler. If
+;;; specified, INHERITS is the name of a VOP that we default unspecified
+;;; information from. Each SPEC is a list beginning with a keyword indicating
+;;; the interpretation of the other forms in the SPEC:
+;;;
+;;; :Args {(Name {Key Value}*)}*
+;;; :Results {(Name {Key Value}*)}*
+;;; The Args and Results are specifications of the operand TNs passed
+;;; to the VOP. If there is an inherited VOP, any unspecified options
+;;; are defaulted from the inherited argument (or result) of the same
+;;; name. The following operand options are defined:
+;;;
+;;; :SCs (SC*)
+;;; :SCs specifies good SCs for this operand. Other SCs will be
+;;; penalized according to move costs. A load TN will be allocated if
+;;; necessary, guaranteeing that the operand is always one of the
+;;; specified SCs.
+;;;
+;;; :Load-TN Load-Name
+;;; Load-Name is bound to the load TN allocated for this operand,
+;;; or to NIL if no load TN was allocated.
+;;;
+;;; :Load-If EXPRESSION
+;;; Controls whether automatic operand loading is done.
+;;; EXPRESSION is evaluated with the fixed operand TNs bound.
+;;; If EXPRESSION is true,then loading is done and the variable
+;;; is bound to the load TN in the generator body. Otherwise,
+;;; loading is not done, and the variable is bound to the actual
+;;; operand.
+;;;
+;;; :More T-or-NIL
+;;; If specified, Name is bound to the TN-Ref for the first
+;;; argument or result following the fixed arguments or results.
+;;; A :MORE operand must appear last, and cannot be targeted or
+;;; restricted.
+;;;
+;;; :Target Operand
+;;; This operand is targeted to the named operand, indicating a
+;;; desire to pack in the same location. Not legal for results.
+;;;
+;;; :From Time-Spec
+;;; :To Time-Spec
+;;; Specify the beginning or end of the operand's lifetime.
+;;; :FROM can only be used with results, and :TO only with
+;;; arguments. The default for the N'th argument/result is
+;;; (:ARGUMENT N)/(:RESULT N). These options are necessary
+;;; primarily when operands are read or written out of order.
+;;;
+;;; :Conditional
+;;; This is used in place of :RESULTS with conditional branch VOPs.
+;;; There are no result values: the result is a transfer of control.
+;;; The target label is passed as the first :INFO arg. The second
+;;; :INFO arg is true if the sense of the test should be negated.
+;;; A side-effect is to set the PREDICATE attribute for functions
+;;; in the :TRANSLATE option.
+;;;
+;;; :Temporary ({Key Value}*) Name*
+;;; Allocate a temporary TN for each Name, binding that variable to
+;;; the TN within the body of the generators. In addition to :TARGET
+;;; (which is is the same as for operands), the following options are
+;;; defined:
+;;;
+;;; :SC SC-Name
+;;; :Offset SB-Offset
+;;; Force the temporary to be allocated in the specified SC with the
+;;; specified offset. Offset is evaluated at macroexpand time. If
+;;; Offset is emitted, the register allocator chooses a free
+;;; location in SC. If both SC and Offset are omitted, then the
+;;; temporary is packed according to its primitive type.
+;;;
+;;; :From Time-Spec
+;;; :To Time-Spec
+;;; Similar to the argument/result option, this specifies the start and
+;;; end of the temporaries' lives. The defaults are :Load and :Save,
+;;; i.e. the duration of the VOP. The other intervening phases are
+;;; :Argument,:Eval and :Result. Non-zero sub-phases can be specified
+;;; by a list, e.g. by default the second argument's life ends at
+;;; (:Argument 1).
+;;;
+;;; :Generator Cost Form*
+;;; Specifies the translation into assembly code. Cost is the
+;;; estimated cost of the code emitted by this generator. The body
+;;; is arbitrary Lisp code that emits the assembly language
+;;; translation of the VOP. An ASSEMBLE form is wrapped around
+;;; the body, so code may be emitted by using the local INST macro.
+;;; During the evaluation of the body, the names of the operands
+;;; and temporaries are bound to the actual TNs.
+;;;
+;;; :Effects Effect*
+;;; :Affected Effect*
+;;; Specifies the side effects that this VOP has and the side
+;;; effects that effect its execution. If unspecified, these
+;;; default to the worst case.
+;;;
+;;; :Info Name*
+;;; Define some magic arguments that are passed directly to the code
+;;; generator. The corresponding trailing arguments to VOP or
+;;; %PRIMITIVE are stored in the VOP structure. Within the body
+;;; of the generators, the named variables are bound to these
+;;; values. Except in the case of :Conditional VOPs, :Info arguments
+;;; cannot be specified for VOPS that are the direct translation
+;;; for a function (specified by :Translate).
+;;;
+;;; :Ignore Name*
+;;; Causes the named variables to be declared IGNORE in the
+;;; generator body.
+;;;
+;;; :Variant Thing*
+;;; :Variant-Vars Name*
+;;; These options provide a way to parameterize families of VOPs
+;;; that differ only trivially. :Variant makes the specified
+;;; evaluated Things be the "variant" associated with this VOP.
+;;; :VARIANT-VARS causes the named variables to be bound to the
+;;; corresponding Things within the body of the generator.
+;;;
+;;; :Variant-Cost Cost
+;;; Specifies the cost of this VOP, overriding the cost of any
+;;; inherited generator.
+;;;
+;;; :Note {String | NIL}
+;;; A short noun-like phrase describing what this VOP "does", i.e.
+;;; the implementation strategy. If supplied, efficency notes will
+;;; be generated when type uncertainty prevents :TRANSLATE from
+;;; working. NIL inhibits any efficency note.
+;;;
+;;; :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
+;;; :Result-Types {* | PType | (:OR PType*)}*
+;;; Specify the template type restrictions used for automatic translation.
+;;; If there is a :More operand, the last type is the more type. :CONSTANT
+;;; specifies that the argument must be a compile-time constant of the
+;;; specified Lisp type. The constant values of :CONSTANT arguments are
+;;; passed as additional :INFO arguments rather than as :ARGS.
+;;;
+;;; :Translate Name*
+;;; This option causes the VOP template to be entered as an IR2
+;;; translation for the named functions.
+;;;
+;;; :Policy {:Small | :Fast | :Safe | :Fast-Safe}
+;;; Specifies the policy under which this VOP is the best translation.
+;;;
+;;; :Guard Form
+;;; Specifies a Form that is evaluated in the global environment. If
+;;; form returns NIL, then emission of this VOP is prohibited even when
+;;; all other restrictions are met.
+;;;
+;;; :VOP-Var Name
+;;; :Node-Var Name
+;;; In the generator, bind the specified variable to the VOP or
+;;; the Node that generated this VOP.
+;;;
+;;; :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
+;;; Indicates how a VOP wants live registers saved.
+;;;
+;;; :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
+;;; Indicates if and how the more args should be moved into a
+;;; different frame.
(def!macro define-vop ((name &optional inherits) &rest specs)
- #!+sb-doc
- "Define-VOP (Name [Inherits]) Spec*
- Define the symbol Name to be a Virtual OPeration in the compiler. If
- specified, Inherits is the name of a VOP that we default unspecified
- information from. Each Spec is a list beginning with a keyword indicating
- the interpretation of the other forms in the Spec:
-
- :Args {(Name {Key Value}*)}*
- :Results {(Name {Key Value}*)}*
- The Args and Results are specifications of the operand TNs passed to the
- VOP. If there is an inherited VOP, any unspecified options are defaulted
- from the inherited argument (or result) of the same name. The following
- operand options are defined:
-
- :SCs (SC*)
- :SCs specifies good SCs for this operand. Other SCs will be
- penalized according to move costs. A load TN will be allocated if
- necessary, guaranteeing that the operand is always one of the
- specified SCs.
-
- :Load-TN Load-Name
- Load-Name is bound to the load TN allocated for this operand, or to
- NIL if no load TN was allocated.
-
- :Load-If Expression
- Controls whether automatic operand loading is done. Expression is
- evaluated with the fixed operand TNs bound. If Expression is true,
- then loading is done and the variable is bound to the load TN in
- the generator body. Otherwise, loading is not done, and the variable
- is bound to the actual operand.
-
- :More T-or-NIL
- If specified, Name is bound to the TN-Ref for the first argument or
- result following the fixed arguments or results. A more operand must
- appear last, and cannot be targeted or restricted.
-
- :Target Operand
- This operand is targeted to the named operand, indicating a desire to
- pack in the same location. Not legal for results.
-
- :From Time-Spec
- :To Time-Spec
- Specify the beginning or end of the operand's lifetime. :From can
- only be used with results, and :To only with arguments. The default
- for the N'th argument/result is (:ARGUMENT N)/(:RESULT N). These
- options are necessary primarily when operands are read or written out
- of order.
-
- :Conditional
- This is used in place of :RESULTS with conditional branch VOPs. There
- are no result values: the result is a transfer of control. The target
- label is passed as the first :INFO arg. The second :INFO arg is true if
- the sense of the test should be negated. A side-effect is to set the
- PREDICATE attribute for functions in the :TRANSLATE option.
-
- :Temporary ({Key Value}*) Name*
- Allocate a temporary TN for each Name, binding that variable to the TN
- within the body of the generators. In addition to :Target (which is
- is the same as for operands), the following options are
- defined:
-
- :SC SC-Name
- :Offset SB-Offset
- Force the temporary to be allocated in the specified SC with the
- specified offset. Offset is evaluated at macroexpand time. If
- Offset is emitted, the register allocator chooses a free location in
- SC. If both SC and Offset are omitted, then the temporary is packed
- according to its primitive type.
-
- :From Time-Spec
- :To Time-Spec
- Similar to the argument/result option, this specifies the start and
- end of the temporaries' lives. The defaults are :Load and :Save,
- i.e. the duration of the VOP. The other intervening phases are
- :Argument,:Eval and :Result. Non-zero sub-phases can be specified
- by a list, e.g. by default the second argument's life ends at
- (:Argument 1).
-
- :Generator Cost Form*
- Specifies the translation into assembly code. Cost is the estimated cost
- of the code emitted by this generator. The body is arbitrary Lisp code
- that emits the assembly language translation of the VOP. An Assemble
- form is wrapped around the body, so code may be emitted by using the
- local Inst macro. During the evaluation of the body, the names of the
- operands and temporaries are bound to the actual TNs.
-
- :Effects Effect*
- :Affected Effect*
- Specifies the side effects that this VOP has and the side effects that
- effect its execution. If unspecified, these default to the worst case.
-
- :Info Name*
- Define some magic arguments that are passed directly to the code
- generator. The corresponding trailing arguments to VOP or %Primitive are
- stored in the VOP structure. Within the body of the generators, the
- named variables are bound to these values. Except in the case of
- :Conditional VOPs, :Info arguments cannot be specified for VOPS that are
- the direct translation for a function (specified by :Translate).
-
- :Ignore Name*
- Causes the named variables to be declared IGNORE in the generator body.
-
- :Variant Thing*
- :Variant-Vars Name*
- These options provide a way to parameterize families of VOPs that differ
- only trivially. :Variant makes the specified evaluated Things be the
- \"variant\" associated with this VOP. :Variant-Vars causes the named
- variables to be bound to the corresponding Things within the body of the
- generator.
-
- :Variant-Cost Cost
- Specifies the cost of this VOP, overriding the cost of any inherited
- generator.
-
- :Note {String | NIL}
- A short noun-like phrase describing what this VOP \"does\", i.e. the
- implementation strategy. If supplied, efficency notes will be generated
- when type uncertainty prevents :TRANSLATE from working. NIL inhibits any
- efficency note.
-
- :Arg-Types {* | PType | (:OR PType*) | (:CONSTANT Type)}*
- :Result-Types {* | PType | (:OR PType*)}*
- Specify the template type restrictions used for automatic translation.
- If there is a :More operand, the last type is the more type. :CONSTANT
- specifies that the argument must be a compile-time constant of the
- specified Lisp type. The constant values of :CONSTANT arguments are
- passed as additional :INFO arguments rather than as :ARGS.
-
- :Translate Name*
- This option causes the VOP template to be entered as an IR2 translation
- for the named functions.
-
- :Policy {:Small | :Fast | :Safe | :Fast-Safe}
- Specifies the policy under which this VOP is the best translation.
-
- :Guard Form
- Specifies a Form that is evaluated in the global environment. If
- form returns NIL, then emission of this VOP is prohibited even when
- all other restrictions are met.
-
- :VOP-Var Name
- :Node-Var Name
- In the generator, bind the specified variable to the VOP or the Node that
- generated this VOP.
-
- :Save-P {NIL | T | :Compute-Only | :Force-To-Stack}
- Indicates how a VOP wants live registers saved.
-
- :Move-Args {NIL | :Full-Call | :Local-Call | :Known-Return}
- Indicates if and how the more args should be moved into a different
- frame."
+ ;; Parse the syntax into a VOP-PARSE structure, and then expand into
+ ;; code that creates the appropriate VOP-INFO structure at load time.
+ ;; We implement inheritance by copying the VOP-PARSE structure for
+ ;; the inherited structure.
(check-type name symbol)
-
(let* ((inherited-parse (when inherits
(vop-parse-or-lose inherits)))
(parse (if inherits
(arglist nil :type list)
;; true if &ALLOW-OTHER-KEYS was supplied
(allowp nil :type boolean)
- ;; true if &KEY was specified (doesn't necessarily mean that there
- ;; are any keyword arguments...)
+ ;; true if &KEY was specified (which doesn't necessarily mean that
+ ;; there are any &KEY arguments..)
(keyp nil :type boolean)
;; the number of required arguments. This is the smallest legal
;; number of arguments.
;; defaults even when there is no user-specified supplied-p var.
(supplied-p nil :type (or lambda-var null))
;; the default for a keyword or optional, represented as the
- ;; original Lisp code. This is set to NIL in keyword arguments that
- ;; are defaulted using the SUPPLIED-P arg.
+ ;; original Lisp code. This is set to NIL in &KEY arguments that are
+ ;; defaulted using the SUPPLIED-P arg.
(default nil :type t)
- ;; the actual keyword for a keyword argument
- (keyword nil :type (or keyword null)))
+ ;; the actual key for a &KEY argument. Note that in ANSI CL this is not
+ ;; necessarily a keyword: (DEFUN FOO (&KEY ((BAR BAR))) ..).
+ (key nil :type symbol))
(defprinter (arg-info)
(specialp :test specialp)
kind
(supplied-p :test supplied-p)
(default :test default)
- (keyword :test keyword))
+ (key :test key))
;;; The LAMBDA-VAR structure represents a lexical lambda variable.
;;; This structure is also used during IR1 conversion to describe
(in-package "SB!C")
-;;; Break a lambda-list into its component parts. We return eleven
+(/show0 "parse-lambda-list.lisp 12")
+
+;;; Break a lambda list into its component parts. We return eleven
;;; values:
-;;; 1. A list of the required args.
-;;; 2. A list of the optional arg specs.
-;;; 3. True if a rest arg was specified.
-;;; 4. The rest arg.
-;;; 5. A boolean indicating whether keywords args are present.
-;;; 6. A list of the keyword arg specs.
-;;; 7. True if &allow-other-keys was specified.
-;;; 8. A list of the &aux specifiers.
-;;; 9. True if a more arg was specified.
-;;; 10. The &more context var
-;;; 11. The &more count var
+;;; 1. a list of the required args;
+;;; 2. a list of the optional arg specs;
+;;; 3. true if a rest arg was specified;
+;;; 4. the &rest arg;
+;;; 5. true if &KEY args are present;
+;;; 6. a list of the &KEY arg specs;
+;;; 7. true if &ALLOW-OTHER-KEYS was specified.;
+;;; 8. a list of the &AUX specifiers;
+;;; 9. true if a &MORE arg was specified;
+;;; 10. the &MORE context var;
+;;; 11. the &MORE count var.
;;;
-;;; The top-level lambda-list syntax is checked for validity, but the
+;;; The top-level lambda list syntax is checked for validity, but the
;;; arg specifiers are just passed through untouched. If something is
-;;; wrong, we use Compiler-Error, aborting compilation to the last
+;;; wrong, we use COMPILER-ERROR, aborting compilation to the last
;;; recovery point.
(declaim (ftype (function (list)
(values list list boolean t boolean list boolean
(values (required) (optional) restp rest keyp (keys) allowp (aux)
morep more-context more-count))))
+
+(/show0 "parse-lambda-list.lisp end of file")
(setf (sset-elements res) (copy-list (sset-elements set)))
res))
-;;; Perform the appropriate set operation on Set1 and Set2 by destructively
-;;; modifying Set1. We return true if Set1 was modified, false otherwise.
+;;; Perform the appropriate set operation on SET1 and SET2 by destructively
+;;; modifying SET1. We return true if SET1 was modified, false otherwise.
(declaim (ftype (function (sset sset) boolean) sset-union sset-intersection
sset-difference))
(defun sset-union (set1 set2)
(let ((sap (sb!sys:int-sap address)))
#'(lambda () sap)))
\f
+;;; Return a memory segment located at the system-area-pointer returned by
+;;; SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
+;;;
+;;; &KEY arguments include :VIRTUAL-LOCATION (by default the same as
+;;; the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a
+;;; SOURCE-FORM-CACHE object), and :HOOKS (a list of OFFS-HOOK
+;;; objects).
(defun make-segment (sap-maker length
&key
code virtual-location
debug-function source-form-cache
hooks)
- #!+sb-doc
- "Return a memory segment located at the system-area-pointer returned by
- SAP-MAKER and LENGTH bytes long in the disassem-state object DSTATE.
- Optional keyword arguments include :VIRTUAL-LOCATION (by default the same as
- the address), :DEBUG-FUNCTION, :SOURCE-FORM-CACHE (a source-form-cache
- object), and :HOOKS (a list of offs-hook objects)."
(declare (type (function () sb!sys:system-area-pointer) sap-maker)
(type length length)
(type (or null address) virtual-location)
object type)
(frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
object layout)
- (frob odd-keyword-arguments-error odd-keyword-arguments-error
- sb!c::%odd-keyword-arguments-error)
- (frob unknown-keyword-argument-error unknown-keyword-argument-error
- sb!c::%unknown-keyword-argument-error key)
+ (frob odd-key-arguments-error odd-key-arguments-error
+ sb!c::%odd-key-arguments-error)
+ (frob unknown-key-argument-error unknown-key-argument-error
+ sb!c::%unknown-key-argument-error key)
(frob nil-function-returned-error nil-function-returned-error nil fun))
(let ((initargs ())
(methods ()))
(flet ((duplicate-option (name)
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "The option ~S appears more than once."
:format-arguments (list name)))
(expand-method-definition (qab) ; QAB = qualifiers, arglist, body
(t
;; ANSI requires that unsupported things must get a
;; PROGRAM-ERROR.
- (error 'sb-kernel:simple-program-error
+ (error 'simple-program-error
:format-control "unsupported option ~S"
:format-arguments (list option))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
- (parse-keyword-argument (arg)
+ (parse-key-argument (arg)
(if (listp arg)
(if (listp (car arg))
(caar arg)
(ecase state
(required (incf nrequired))
(optional (incf noptional))
- (key (push (parse-keyword-argument x) keywords)
+ (key (push (parse-key-argument x) keywords)
(push x keyword-parameters))
(rest ()))))
(values nrequired noptional keysp restp allow-other-keys-p
existing function-name all-keys))))
(defun generic-clobbers-function (function-name)
- (error 'sb-kernel:simple-program-error
- :format-control
- "~S already names an ordinary function or a macro."
+ (error 'simple-program-error
+ :format-control "~S already names an ordinary function or a macro."
:format-arguments (list function-name)))
(defvar *sgf-wrapper*
(!bootstrap-slot-index 'standard-generic-function 'dfun-state))
(defstruct (arg-info
- (:conc-name nil)
- (:constructor make-arg-info ())
- (:copier nil))
+ (:conc-name nil)
+ (:constructor make-arg-info ())
+ (:copier nil))
(arg-info-lambda-list :no-lambda-list)
arg-info-precedence
arg-info-metatypes
arg-info-number-optional
arg-info-key/rest-p
- arg-info-keywords ;nil no keyword or rest allowed
- ;(k1 k2 ..) each method must accept these keyword arguments
- ;T must have &key or &rest
+ arg-info-keys ;nil no &KEY or &REST allowed
+ ;(k1 k2 ..) Each method must accept these &KEY arguments.
+ ;T must have &KEY or &REST
gf-info-simple-accessor-type ; nil, reader, writer, boundp
(gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info
(esetf (arg-info-metatypes arg-info) (make-list nreq))
(esetf (arg-info-number-optional arg-info) nopt)
(esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp))))
- (esetf (arg-info-keywords arg-info)
+ (esetf (arg-info-keys arg-info)
(if lambda-list-p
(if allow-other-keys-p t keywords)
(arg-info-key/rest-p arg-info)))))
(let ((gf-nreq (arg-info-number-required arg-info))
(gf-nopt (arg-info-number-optional arg-info))
(gf-key/rest-p (arg-info-key/rest-p arg-info))
- (gf-keywords (arg-info-keywords arg-info)))
+ (gf-keywords (arg-info-keys arg-info)))
(unless (= nreq gf-nreq)
(lose
"the method has ~A required arguments than the generic function."
(unless (or (and restp (not keysp))
allow-other-keys-p
(every #'(lambda (k) (memq k keywords)) gf-keywords))
- (lose "the method does not accept each of the keyword arguments~%~
+ (lose "the method does not accept each of the &KEY arguments~%~
~S."
gf-keywords)))))))
operation
&optional new-value))
\f
-;;;; keyword arguments
+;;;; &KEY arguments
(defgeneric allocate-instance (class &rest initargs))
("compiler/late-macros")
- ;; for e.g. DEF-PRIMITIVE-TYPE, needed by primtype.lisp, and
+ ;; for e.g. !DEF-PRIMITIVE-TYPE, needed by primtype.lisp, and
;; DEFINE-STORAGE-CLASS, needed by target/vm.lisp
("compiler/meta-vmdef")
;; host-alieneval.lisp
("code/host-c-call")
- ;; SB!XC:DEFTYPE is needed in order to compile late-target-type
+ ;; SB!XC:DEFTYPE is needed in order to compile late-type
;; in the host Common Lisp, and in order to run, it needs
;; %COMPILER-DEFTYPE.
("compiler/compiler-deftype")
fi
done
+# (*.before-xc.lisp and *.after-xc.lisp files aren't handled in this
+# script at all. They're tests intended to run in the cross-compiler,
+# so that some functionality can be tested even when cold init doesn't
+# work.)
+
echo '//apparent success (reached end of run-tests.sh normally)'
--- /dev/null
+;;;; tests of the type system, intended to be executed in the
+;;;; cross-compiler after cross-compilation
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "SB!KERNEL")
+
+(/show "beginning tests/type.after-xc.lisp")
+
+;;; various dead bugs
+(assert (eql *empty-type*
+ (type-intersection *empty-type*
+ (specifier-type 'keyword))))
+(assert (eql *empty-type*
+ (type-intersection (specifier-type 'keyword)
+ *empty-type*)))
+(assert (member-type-p (specifier-type '(or float-format null))))
+
+(/show "done with tests/type.after-xc.lisp")
--- /dev/null
+;;;; tests of the type system, intended to be executed as soon as
+;;;; the cross-compiler is built
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+(in-package "SB!KERNEL")
+
+(/show "beginning tests/type.before-xc.lisp")
+
+(assert (type= (specifier-type '(and fixnum (satisfies foo)))
+ (specifier-type '(and (satisfies foo) fixnum))))
+(assert (type= (specifier-type '(member 1 2 3))
+ (specifier-type '(member 2 3 1))))
+(assert (type= (specifier-type '(and (member 1.0 2 3) single-float))
+ (specifier-type '(member 1.0))))
+
+(assert (sb-xc:typep #(1 2 3) 'simple-vector))
+(assert (sb-xc:typep #(1 2 3) 'vector))
+(assert (not (sb-xc:typep '(1 2 3) 'vector)))
+(assert (not (sb-xc:typep 1 'vector)))
+
+(assert (sb-xc:typep '(1 2 3) 'list))
+(assert (sb-xc:typep '(1 2 3) 'cons))
+(assert (not (sb-xc:typep '(1 2 3) 'null)))
+(assert (not (sb-xc:typep "1 2 3" 'list)))
+(assert (not (sb-xc:typep 1 'list)))
+
+(assert (sb-xc:typep nil 'null))
+(assert (sb-xc:typep nil '(member nil)))
+(assert (sb-xc:typep nil '(member 1 2 nil 3)))
+(assert (not (sb-xc:typep nil '(member 1 2 3))))
+
+(assert (type= *empty-type*
+ (type-intersection (specifier-type 'list)
+ (specifier-type 'vector))))
+(assert (eql *empty-type*
+ (type-intersection (specifier-type 'list)
+ (specifier-type 'vector))))
+(assert (type= (specifier-type 'null)
+ (type-intersection (specifier-type 'list)
+ (specifier-type '(or vector null)))))
+(assert (type= (specifier-type 'null)
+ (type-intersection (specifier-type 'sequence)
+ (specifier-type 'symbol))))
+(assert (type= (specifier-type 'cons)
+ (type-intersection (specifier-type 'sequence)
+ (specifier-type '(or cons number)))))
+(assert (eql *empty-type*
+ (type-intersection (specifier-type '(satisfies keywordp))
+ *empty-type*)))
+
+;;; Identities should be identities.
+(dolist (type-specifier '(nil
+ t
+ null
+ (satisfies keywordp)
+ (satisfies foo)
+ (not fixnum)
+ (not null)
+ (and symbol (satisfies foo))
+ (and (satisfies foo) string)
+ (or symbol sequence)
+ (or single-float character)
+ (or float (satisfies bar))
+ integer (integer 0 1)
+ character standard-char
+ (member 1 2 3)))
+ (/show type-specifier)
+ (let ((ctype (specifier-type type-specifier)))
+
+ (assert (eql *empty-type* (type-intersection ctype *empty-type*)))
+ (assert (eql *empty-type* (type-intersection *empty-type* ctype)))
+ (assert (eql *empty-type* (type-intersection2 ctype *empty-type*)))
+ (assert (eql *empty-type* (type-intersection2 *empty-type* ctype)))
+
+ (assert (type= ctype (type-intersection ctype *universal-type*)))
+ (assert (type= ctype (type-intersection *universal-type* ctype)))
+ (assert (type= ctype (type-intersection2 ctype *universal-type*)))
+ (assert (type= ctype (type-intersection2 *universal-type* ctype)))
+
+ ;; FIXME: TYPE-UNION still acts CMU-CL-ish as of 0.6.11.13, so
+ ;; e.g. (TYPE-UNION #<HAIRY-TYPE (SATISFIES KEYWORDP)> *EMPTY-TYPE*)
+ ;; returns a UNION-TYPE instead of the HAIRY-TYPE. When that's
+ ;; fixed, these tests should be enabled.
+ ;;(assert (eql ctype (type-union ctype *empty-type*)))
+ ;;(assert (eql ctype (type-union *empty-type* ctype)))
+
+ ;; FIXME: TYPE-UNION2 is not defined yet as of 0.6.11.13, and when
+ ;; it's defined, these tests should be enabled.
+ ;;(assert (eql *empty-type* (type-union2 ctype *empty-type*)))
+ ;;(assert (eql *empty-type* (type-union2 *empty-type* ctype)))
+
+ ;;(assert (eql *universal-type* (type-union ctype *universal-type*)))
+ ;;(assert (eql *universal-type* (type-union *universal-type* ctype)))
+ ;;(assert (eql ctype (type-union2 ctype *universal-type*)))
+ ;;(assert (eql ctype (type-union2 *universal-type* ctype)))
+
+ (assert (csubtypep *empty-type* ctype))
+ (assert (csubtypep ctype *universal-type*))))
+(/show "done with identities-should-be-identities block")
+
+(assert (sb-xc:subtypep 'simple-vector 'vector))
+(assert (sb-xc:subtypep 'simple-vector 'simple-array))
+(assert (sb-xc:subtypep 'vector 'array))
+(assert (not (sb-xc:subtypep 'vector 'simple-vector)))
+(assert (not (sb-xc:subtypep 'vector 'simple-array)))
+
+(macrolet ((assert-secondnil (expr) `(assert (null (nth-value 1 ,expr)))))
+ (assert-secondnil (sb-xc:subtypep t '(satisfies foo)))
+ (assert-secondnil (sb-xc:subtypep t '(and (satisfies foo) (satisfies bar))))
+ (assert-secondnil (sb-xc:subtypep t '(or (satisfies foo) (satisfies bar))))
+ ;; FIXME: Enable these tests when bug 84 is fixed.
+ #|
+ (assert-secondnil (sb-xc:subtypep '(satisfies foo) nil))
+ (assert-secondnil (sb-xc:subtypep '(and (satisfies foo) (satisfies bar))
+ nil))
+ (assert-secondnil (sb-xc:subtypep '(or (satisfies foo) (satisfies bar))
+ nil))
+ |#)
+
+;;; various dead bugs
+(assert (union-type-p (type-intersection (specifier-type 'list)
+ (specifier-type '(or list vector)))))
+(assert (type= (type-intersection (specifier-type 'list)
+ (specifier-type '(or list vector)))
+ (specifier-type 'list)))
+(assert (array-type-p (type-intersection (specifier-type 'vector)
+ (specifier-type '(or list vector)))))
+(assert (type= (type-intersection (specifier-type 'vector)
+ (specifier-type '(or list vector)))
+ (specifier-type 'vector)))
+(assert (type= (type-intersection (specifier-type 'number)
+ (specifier-type 'integer))
+ (specifier-type 'integer)))
+(assert (null (type-intersection2 (specifier-type 'symbol)
+ (specifier-type '(satisfies foo)))))
+(assert (intersection-type-p (specifier-type '(and symbol (satisfies foo)))))
+
+(/show "done with tests/type.before-xc.lisp")
(assert (not (typep 11 '(or))))
;;; bug 12: type system didn't grok nontrivial intersections
-#| ; "we gotta target, but you gotta be patient": 0.6.11.x work in progress
(assert (subtypep '(and symbol (satisfies keywordp)) 'symbol))
(assert (not (subtypep '(and symbol (satisfies keywordp)) 'null)))
(assert (subtypep 'keyword 'symbol))
(assert (not (subtypep 'symbol 'keyword)))
(assert (subtypep 'ratio 'real))
(assert (subtypep 'ratio 'number))
-|#
;;; success
(quit :unix-status 104)
;;; 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.11.12"
+"0.6.11.13"
projects / sbcl.git / commitdiff