unsigned-byte
(integer -1 1))) => NIL,T
An analogous problem with SINGLE-FLOAT and REAL types was fixed in
- sbcl-0.6.11.22, but some peculiarites of the RATIO type makes it
+ sbcl-0.6.11.22, but some peculiarites of the RATIO type make it
awkward to generalize the fix to INTEGER and RATIONAL. It's not
clear what's the best fix. (See the "bug in type handling" discussion
on cmucl-imp ca. 2001-03-22 and ca. 2001-02-12.)
This is a bug in the original CMU CL code. I reported it to cmucl-imp
2001-03-22 in hopes that they'll fix it for us.
+93:
+ In sbcl-0.6.11.26, (COMPILE 'IN-HOST-COMPILATION-MODE) in
+ src/cold/shared.lisp doesn't correctly translate the
+ interpreted function
+ (defun in-host-compilation-mode (fn)
+ (let ((*features* (cons :sb-xc-host *features*))
+ ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in
+ ;; base-target-features.lisp-expr:
+ (*shebang-features* (set-difference *shebang-features*
+ '(:sb-propagate-float-type
+ :sb-propagate-fun-type))))
+ (with-additional-nickname ("SB-XC" "SB!XC")
+ (funcall fn))))
+ No error is reported by the compiler, but when the function is executed,
+ it causes an error
+ TYPE-ERROR in SB-KERNEL::OBJECT-NOT-TYPE-ERROR-HANDLER:
+ (:LINUX :X86 :IEEE-FLOATING-POINT :SB-CONSTRAIN-FLOAT-TYPE :SB-TEST
+ :SB-INTERPRETER :SB-DOC :UNIX ...) is not of type SYMBOL.
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
complicated result types, and interactions of various variants of
STREAM).
-Raymond Toy wrote the propagate-float-type extension and various
+Raymond Toy wrote the PROPAGATE-FLOAT-TYPE extension and various
other floating point optimizations.
CMU CL's long float support was written by Douglas T. Crosher.
complex special functions have been merged from CMU CL sources.
(When I was first setting up SBCL, I misunderstood a compile-time
conditional #-OLD-SPECFUN, and so accidentally deleted them.)
-?? The :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE features
+* The :SB-PROPAGATE-FLOAT-TYPE and :SB-PROPAGATE-FUN-TYPE features
are now supported, and enabled by default. Thus, the compiler can
handle many floating point and complex operations much less
inefficiently. (Thus e.g. you can implement a complex FFT
;; you are a developer.
:sb-test
+ ;; :SB-PROPAGATE-FLOAT-TYPE and :SB-PROPAGATE-FUN-TYPE enable
+ ;; some numeric optimizer code in the target compiler. They
+ ;; correspond to the :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE
+ ;; features in the original CMU CL code, and while documentation
+ ;; existed for those, it seemed a little inconsistent. Despite the
+ ;; name, :SB-PROPAGATE-FLOAT-TYPE seems to control not only
+ ;; floating point optimizations, but some integer optimizations as
+ ;; well.
+ ;;
+ ;; CROSS-FLOAT-INFINITY-KLUDGE:
+ ;; * Even when these target features are enabled, the optimizations
+ ;; aren't enabled in the cross-compiler, because some of them
+ ;; depend on floating point infinities, which aren't in general
+ ;; supported on the cross-compilation host.
+ ;; * This is supported by hacking the features out of the
+ ;; *SHEBANG-FEATURES* list while we're building the cross-compiler.
+ ;; This is ugly and confusing and weird, but all the alternatives
+ ;; that I could think of seem messy and error-prone. That doesn't
+ ;; mean there's not a better way, though. Suggestions are welcome;
+ ;; or if you'd like to submit patches to make this code work
+ ;; without requiring floating point infinities, so that the entire
+ ;; problem goes away, that might be even better! -- WHN 2001-03-22
+ :sb-propagate-float-type
+ :sb-propagate-fun-type
+
;; Setting this makes more debugging information available.
;; If you aren't hacking or troubleshooting SBCL itself, you
;; probably don't want this set.
; :mp-i486
;; This affects the definition of a lot of things in bignum.lisp. It
- ;; doesn't seem to be documented anywhere what systems it might apply to.
- ;; It doesn't seem to be needed for X86 systems anyway.
+ ;; doesn't seem to be documented anywhere what systems it might apply
+ ;; to. It doesn't seem to be needed for X86 systems anyway.
; :32x16-divide
- ;; This is probably true for some processor types, but not X86. It affects
- ;; a lot of floating point code.
+ ;; This is probably true for some processor types, but not X86. It
+ ;; affects a lot of floating point code.
; :negative-zero-is-not-zero
- ;; This is mentioned in cmu-user.tex, which says that it enables
- ;; the compiler to reason about integer arithmetic. It also seems to
- ;; control other fancy numeric reasoning, e.g. knowing the result type of
- ;; a remainder calculation given the type of its inputs.
- ;;
- ;; CROSS-FLOAT-INFINITY-KLUDGE: The :PROPAGATE-FLOAT-TYPE and
- ;; :PROPAGATE-FUN-TYPE features are problematic when building
- ;; the cross-compiler itself. Their implementation depends on
- ;; floating point infinities, which might not be supported in the
- ;; cross-compilation host. In order to avoid this problem, while
- ;; still supporting these features in the target Lisp compiler,
- ;; we use the :WILL-PROPAGATE-FLOAT-TYPE feature when building
- ;; the cross-compiler, and munge it into :PROPAGATE-FLOAT-TYPE
- ;; only when building the target compiler; and similarly for
- ;; :WILL-PROPAGATE-FUN-TYPE.
- ;:will-propagate-float-type ; (becomes :PROPAGATE-FLOAT-TYPE)
-
- ;; According to cmu-user.tex, this enables the compiler to infer result
- ;; types for mathematical functions like SQRT, EXPT, and LOG, allowing
- ;; it to e.g. eliminate the possibility that a complex result will be
- ;; generated. This applies only to the target compiler, not the
- ;; cross-compiler: see CROSS-FLOAT-INFINITY-KLUDGE.
- ;:will-propagate-fun-type ; (becomes :PROPAGATE-FUN-TYPE)
-
- ;; It's unclear to me what this does (but it was enabled in the code that I
- ;; picked up from Peter Van Eynde). -- WHN 19990224
- :constrain-float-type
+ ;; It's unclear to me what this does (but it was enabled in the code
+ ;; that I picked up from Peter Van Eynde, called CONSTRAIN-FLOAT-TYPE
+ ;; instead of SB-CONSTRAIN-FLOAT-TYPE). -- WHN 19990224
+ :sb-constrain-float-type
;; This is set in classic CMU CL, and presumably there it means
;; that the floating point arithmetic implementation
;; phase of cross-compilation bootstrapping, when the cross-compiler is
;; being used to create the first target Lisp.
- ;; notes on the :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE
- ;; features: See the comments on CROSS-FLOAT-INFINITY-KLUDGE.
-
;; notes on the :SB-ASSEMBLING feature (which isn't controlled by
;; this file):
;;
(sb!c::*top-level-lambda-max* 10)
;; Let the target know that we're the cross-compiler.
(*features* (cons :sb-xc *features*))
- ;; the CROSS-FLOAT-INFINITY-KLUDGE: When building a
- ;; compiler which runs under the SBCL runtime, which
- ;; supports floating point infinities, it's safe to
- ;; build with true PROPAGATE-FLOAT-TYPE and
- ;; PROPAGATE-FUN-TYPE features. (It wasn't safe
- ;; when building a cross-compiler to run under the
- ;; cross-compilation host Lisp).
- #+nil ; FIXME: suppressed since 0.6.11.3 has no fp infinities
- (sb-cold:*shebang-features*
- (substitute
- :propagate-float-type
- :will-propagate-float-type
- (substitute
- :propagate-fun-type
- :will-propagate-fun-type
- sb-cold:*shebang-features*)))
;; We need to tweak the readtable..
(*readtable* (copy-readtable)))
;; ..in order to make backquotes expand into target code
"ALIEN-SINGLE-FLOAT-TYPE-P" "ALIEN-SUBTYPE-P" "ALIEN-TYPE"
"ALIEN-TYPE-=" "ALIEN-TYPE-ALIGNMENT" "ALIEN-TYPE-BITS"
"ALIEN-TYPE-P" "ALIEN-TYPEP"
- "ALIEN-VALUE" "ALIEN-VALUE-TYPE"
+ "ALIEN-VALUE" "ALIEN-VALUE-TYPE"
"ALIEN-VALUE-SAP" "ALIEN-VALUE-P"
"ALIEN-VALUES-TYPE" "ALIEN-VALUES-TYPE-P"
"ALIEN-VALUES-TYPE-VALUES" "ALIGN-OFFSET" "COMPUTE-ALIEN-REP-TYPE"
"VARIABLE-LENGTH"
"SEGMENT-COLLECT-DYNAMIC-STATISTICS"
- ;; FIXME: These are in the SB-ASSEM package now, but
+ ;; FIXME: These are in the SB-ASSEM package now, but
;; (left over from CMU CL) are defined in files which
;; are IN-PACKAGE SB-C. It would probably be cleaner
;; to move at least most of them to files which are
"*COUNT-VOP-USAGES*" "*ELSEWHERE*"
"*FASL-HEADER-STRING-START-STRING*"
"*FASL-HEADER-STRING-STOP-CHAR-CODE*"
- "*SETF-ASSUMED-FBOUNDP*"
+ "*SETF-ASSUMED-FBOUNDP*"
"*SUPPRESS-VALUES-DECLARATION*"
"ALLOC-ALIEN-STACK-SPACE" "ALLOC-NUMBER-STACK-SPACE"
:use ("CL" "SB!ALIEN-INTERNALS" "SB!ALIEN" "SB!BIGNUM"
"SB!EXT" "SB!INT" "SB!KERNEL" "SB!ASSEM" "SB!SYS")
:export ("*COLLECT-DYNAMIC-STATISTICS*" "COUNT-ME"
- "DYNCOUNT-INFO-COUNTS" "DYNCOUNT-INFO-COSTS"
+ "DYNCOUNT-INFO-COUNTS" "DYNCOUNT-INFO-COSTS"
"IR2-COMPONENT-DYNCOUNT-INFO"
"DYNCOUNT-INFO" "DYNCOUNT-INFO-P"))
like *STACK-TOP-HINT*"
:use ("CL" "SB!EXT" "SB!INT" "SB!SYS")
:export ("*AUTO-EVAL-IN-FRAME*" "*DEBUG-CONDITION*"
- "*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*"
+ "*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*"
"*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
"*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
"*TRACE-INDENTATION-STEP*" "*MAX-TRACE-INDENTATION*"
;; FIXME: These seem like the right thing, but are they
;; consistent with ANSI? (And actually maybe they're not
;; quite the right thing; it might be better to also do
- ;; WITH-STANDARD-IO-SYNTAX or something.)
+ ;; WITH-STANDARD-IO-SYNTAX or something.)
"*ERROR-PRINT-LENGTH*" "*ERROR-PRINT-LEVEL*" "*ERROR-PRINT-LINES*"
;; KLUDGE: CMU CL had
;; are assertions" default
"TRULY-THE"
- ;; This is something which must exist inside any Common Lisp
- ;; implementation, and which someone writing a customized toplevel
- ;; might well want. It seems perverse to hide it from
- ;; them..
+ ;; This is something which must exist inside any Common Lisp
+ ;; implementation, and which someone writing a customized toplevel
+ ;; might well want. It seems perverse to hide it from
+ ;; them..
"INTERACTIVE-EVAL"
;; weak pointers and finalization
;; miscellaneous non-standard but handy user-level functions..
"ASSQ" "DELQ" "MEMQ" "POSQ" "NEQ"
- "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
+ "%FIND-PACKAGE-OR-LOSE" "FIND-UNDELETED-PACKAGE-OR-LOSE"
"SANE-PACKAGE"
"CIRCULAR-LIST-P"
"SWAPPED-ARGS-FUN"
"ANY/TYPE" "EVERY/TYPE"
+ "TYPE-BOUND-NUMBER"
- ;; ..and macros..
+ ;; ..and macros..
"COLLECT"
"DO-ANONYMOUS" "DOHASH" "DOVECTOR"
"NAMED-LET"
"+EMPTY-HT-SLOT+"
;; not used any more, I think -- WHN 19991206
- #+nil
+ #+nil
("SERVE-BUTTON-PRESS"
"SERVE-BUTTON-RELEASE" "SERVE-CIRCULATE-NOTIFY"
"SERVE-CIRCULATE-REQUEST" "SERVE-CLIENT-MESSAGE"
"%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT"
"%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO"
"%MAP" "%MAP-TO-SIMPLE-VECTOR-ARITY-1" "%MAP-TO-LIST-ARITY-1"
- "%MAP-TO-NIL-ON-SEQUENCE" "%MAP-TO-NIL-ON-SIMPLE-VECTOR"
+ "%MAP-TO-NIL-ON-SEQUENCE" "%MAP-TO-NIL-ON-SIMPLE-VECTOR"
"%MAP-TO-NIL-ON-VECTOR" "%MASK-FIELD" "%NEGATE" "%POW"
"%PUTHASH" "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE"
"%RAW-REF-COMPLEX-LONG"
"CONSTANT-TYPE-P" "CONSTANT-TYPE-TYPE"
"CONTAINING-INTEGER-TYPE"
"CONTROL-STACK-POINTER-SAP" "COPY-FROM-SYSTEM-AREA"
- "COPY-NUMERIC-TYPE" "COPY-TO-SYSTEM-AREA"
- "COPY-BYTE-VECTOR-TO-SYSTEM-AREA"
+ "COPY-TO-SYSTEM-AREA"
+ "COPY-BYTE-VECTOR-TO-SYSTEM-AREA"
"CSUBTYPEP" "CTYPE" "TYPE-HASH-VALUE"
"CTYPE-OF" "CTYPE-P" "CTYPEP" "CURRENT-FP" "CURRENT-SP"
"DATA-VECTOR-REF" "DATA-VECTOR-SET" "DECODE-DOUBLE-FLOAT"
"%MAKE-INSTANCE"
"MAKE-VALUES-TYPE"
"MAYBE-GC" "MEMBER-TYPE" "MEMBER-TYPE-MEMBERS"
- "MEMBER-TYPE-P" "MERGE-BITS"
+ "MEMBER-TYPE-P" "MERGE-BITS" "MODIFIED-NUMERIC-TYPE"
"DEFMACRO-MUNDANELY" "MUTATOR-SELF"
"NAMED-TYPE" "NAMED-TYPE-NAME" "NAMED-TYPE-P"
"NATIVE-BYTE-ORDER" "NEGATE"
"NAMESTRING-PARSE-ERROR" "NAMESTRING-PARSE-ERROR-OFFSET"
"DESCRIBE-CONDITION"
- "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF"
+ "!COLD-INIT" "!UNINTERN-INIT-ONLY-STUFF"
"!GLOBALDB-COLD-INIT" "!FDEFN-COLD-INIT"
"!TYPE-CLASS-COLD-INIT" "!TYPEDEFS-COLD-INIT"
"!ALIEN-TYPE-COLD-INIT" "!CLASSES-COLD-INIT"
"!READER-COLD-INIT"
"STREAM-COLD-INIT-OR-RESET" "!LOADER-COLD-INIT"
"!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT"
- "!POLICY-COLD-INIT-OR-RESANIFY" "!VM-TYPE-COLD-INIT"
+ "!POLICY-COLD-INIT-OR-RESANIFY" "!VM-TYPE-COLD-INIT"
"!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT"
- "!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT"
+ "!CLASS-FINALIZE" "GC-COLD-INIT-OR-REINIT"
;; These belong in an "SB!LOAD" package someday.
"*STATIC-FOREIGN-SYMBOLS*" "*ASSEMBLER-ROUTINES*"
"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" "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"
(type bit-offset src-bit-offset))
(cond
((<= (+ dst-bit-offset length) unit-bits)
- ;; We are only writing one word, so it doesn't matter what order
- ;; we do it in. But we might be reading from multiple words, so take
- ;; care.
+ ;; We are only writing one word, so it doesn't matter what
+ ;; order we do it in. But we might be reading from multiple
+ ;; words, so take care.
(cond
((zerop length)
;; Actually, we aren't even writing one word. This is really easy.
)
((= length unit-bits)
- ;; DST-BIT-OFFSET must be equal to zero, or we would be writing
- ;; multiple words. If SRC-BIT-OFFSET is also zero, then we
- ;; just transfer the single word. Otherwise we have to extract bits
- ;; from two src words.
+ ;; DST-BIT-OFFSET must be equal to zero, or we would be
+ ;; writing multiple words. If SRC-BIT-OFFSET is also zero,
+ ;; then we just transfer the single word. Otherwise we have
+ ;; to extract bits from two src words.
(funcall dst-set-fn dst dst-word-offset
(if (zerop src-bit-offset)
(funcall src-ref-fn src src-word-offset)
(funcall src-ref-fn src (1+ src-word-offset))
(- src-bit-offset))))))
(t
- ;; We are only writing some portion of the dst word, so we need to
- ;; preserve the extra bits. Also, we still don't know whether we need
- ;; one or two source words.
+ ;; We are only writing some portion of the dst word, so we
+ ;; need to preserve the extra bits. Also, we still don't
+ ;; know whether we need one or two source words.
(let ((mask (shift-towards-end (start-mask length) dst-bit-offset))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value
(if (> src-bit-offset dst-bit-offset)
- ;; The source starts further into the word than does
- ;; the dst, so the source could extend into the next
- ;; word. If it does, we have to merge the two words,
- ;; and if not, we can just shift the first word.
+ ;; The source starts further into the word than
+ ;; does the dst, so the source could extend into
+ ;; the next word. If it does, we have to merge
+ ;; the two words, and if not, we can just shift
+ ;; the first word.
(let ((src-bit-shift (- src-bit-offset dst-bit-offset)))
(if (> (+ src-bit-offset length) unit-bits)
(32bit-logical-or
(shift-towards-start
(funcall src-ref-fn src src-word-offset)
src-bit-shift)))
- ;; The dst starts further into the word than does the
- ;; source, so we know the source can not extend into
- ;; a second word (or else the dst would too, and we
- ;; wouldn't be in this branch.
+ ;; The dst starts further into the word than does
+ ;; the source, so we know the source can not
+ ;; extend into a second word (or else the dst
+ ;; would too, and we wouldn't be in this branch.
(shift-towards-end
(funcall src-ref-fn src src-word-offset)
(- dst-bit-offset src-bit-offset)))))
(32bit-logical-andc2 orig mask)))))))
((= src-bit-offset dst-bit-offset)
;; The source and dst are aligned, so we don't need to shift
- ;; anything. But we have to pick the direction of the loop
- ;; in case the source and dst are really the same thing.
+ ;; anything. But we have to pick the direction of the loop in
+ ;; case the source and dst are really the same thing.
(multiple-value-bind (words final-bits)
(floor (+ dst-bit-offset length) unit-bits)
(declare (type word-offset words) (type bit-offset final-bits))
((<= dst-offset src-offset)
;; We need to loop from left to right
(unless (zerop dst-bit-offset)
- ;; We are only writing part of the first word, so mask off the
- ;; bits we want to preserve.
+ ;; We are only writing part of the first word, so mask
+ ;; off the bits we want to preserve.
(let ((mask (end-mask (- dst-bit-offset)))
(orig (funcall dst-ref-fn dst dst-word-offset))
(value (funcall src-ref-fn src src-word-offset)))
-;;;; character functions
-;;;;
-;;;; This file assumes the use of ASCII codes and the specific
-;;;; character formats used in SBCL (and its ancestor, CMU CL). It is
-;;;; optimized for performance rather than for portability and
-;;;; elegance, and may have to be rewritten if the character
-;;;; representation is changed.
-;;;;
-;;;; FIXME: should perhaps be renamed ascii.lisp since it's an
-;;;; unportable ASCII-dependent implementation
+;;;; character implementation stuff which is to be visible at
+;;;; build-the-cross-compiler time
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!IMPL")
-;;; We compile some trivial character operations via inline expansion.
-#!-sb-fluid
-(declaim (inline standard-char-p graphic-char-p alpha-char-p
- upper-case-p lower-case-p both-case-p alphanumericp
- char-int))
-(declaim (maybe-inline digit-char-p digit-weight))
-
-(defconstant char-code-limit 256
+(defconstant sb!xc:char-code-limit 256
#!+sb-doc
"the upper exclusive bound on values produced by CHAR-CODE")
-
-(deftype char-code ()
- `(integer 0 (,char-code-limit)))
-
-(macrolet ((frob (char-names-list)
- (collect ((results))
- (dolist (code char-names-list)
- (destructuring-bind (ccode names) code
- (dolist (name names)
- (results (cons name (code-char ccode))))))
- `(defparameter *char-name-alist* ',(results)
- #!+sb-doc
- "This is the alist of (character-name . character) for characters with
- long names. The first name in this list for a given character is used
- on typeout and is the preferred form for input."))))
- (frob ((#x00 ("Null" "^@" "Nul"))
- (#x01 ("^a" "Soh"))
- (#x02 ("^b" "Stx"))
- (#x03 ("^c" "Etx"))
- (#x04 ("^d" "Eot"))
- (#x05 ("^e" "Enq"))
- (#x06 ("^f" "Ack"))
- (#x07 ("Bell" "^g" "Bel"))
- (#x08 ("Backspace" "^h" "Bs"))
- (#x09 ("Tab" "^i" "Ht"))
- (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" ))
- (#x0B ("Vt" "^k"))
- (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np"))
- (#x0D ("Return" "^m" "Cr"))
- (#x0E ("^n" "So"))
- (#x0F ("^o" "Si"))
- (#x10 ("^p" "Dle"))
- (#x11 ("^q" "Dc1"))
- (#x12 ("^r" "Dc2"))
- (#x13 ("^s" "Dc3"))
- (#x14 ("^t" "Dc4"))
- (#x15 ("^u" "Nak"))
- (#x16 ("^v" "Syn"))
- (#x17 ("^w" "Etb"))
- (#x18 ("^x" "Can"))
- (#x19 ("^y" "Em"))
- (#x1A ("^z" "Sub"))
- (#x1B ("Escape" "^[" "Altmode" "Esc" "Alt"))
- (#x1C ("^\\" "Fs"))
- (#x1D ("^]" "Gs"))
- (#x1E ("^^" "Rs"))
- (#x1F ("^_" "Us"))
- (#x20 ("Space" "Sp"))
- (#x7f ("Rubout" "Delete" "Del")))))
-\f
-;;;; accessor functions
-
-(defun char-code (char)
- #!+sb-doc
- "Returns the integer code of CHAR."
- (etypecase char
- (base-char (char-code (truly-the base-char char)))))
-
-(defun char-int (char)
- #!+sb-doc
- "Returns the integer code of CHAR. This is the same as char-code, as
- CMU Common Lisp does not implement character bits or fonts."
- (char-code char))
-
-(defun code-char (code)
- #!+sb-doc
- "Returns the character with the code CODE."
- (declare (type char-code code))
- (code-char code))
-
-(defun character (object)
- #!+sb-doc
- "Coerces its argument into a character object if possible. Accepts
- characters, strings and symbols of length 1."
- (flet ((do-error (control args)
- (error 'simple-type-error
- :datum object
- ;;?? how to express "symbol with name of length 1"?
- :expected-type '(or character (string 1))
- :format-control control
- :format-arguments args)))
- (typecase object
- (character object)
- (string (if (= 1 (length (the string object)))
- (char object 0)
- (do-error
- "String is not of length one: ~S" (list object))))
- (symbol (if (= 1 (length (symbol-name object)))
- (schar (symbol-name object) 0)
- (do-error
- "Symbol name is not of length one: ~S" (list object))))
- (t (do-error "~S cannot be coerced to a character." (list object))))))
-
-(defun char-name (char)
- #!+sb-doc
- "Given a character object, char-name returns the name for that
- object (a symbol)."
- (car (rassoc char *char-name-alist*)))
-
-(defun name-char (name)
- #!+sb-doc
- "Given an argument acceptable to string, name-char returns a character
- object whose name is that symbol, if one exists. Otherwise, () is returned."
- (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
-\f
-;;;; predicates
-
-(defun standard-char-p (char)
- #!+sb-doc
- "The argument must be a character object. Standard-char-p returns T if the
- argument is a standard character -- one of the 95 ASCII printing characters
- or <return>."
- (declare (character char))
- (and (typep char 'base-char)
- (let ((n (char-code (the base-char char))))
- (or (< 31 n 127)
- (= n 10)))))
-
-(defun %standard-char-p (thing)
- #!+sb-doc
- "Return T if and only if THING is a standard-char. Differs from
- standard-char-p in that THING doesn't have to be a character."
- (and (characterp thing) (standard-char-p thing)))
-
-(defun graphic-char-p (char)
- #!+sb-doc
- "The argument must be a character object. Graphic-char-p returns T if the
- argument is a printing character (space through ~ in ASCII), otherwise
- returns ()."
- (declare (character char))
- (and (typep char 'base-char)
- (< 31
- (char-code (the base-char char))
- 127)))
-
-(defun alpha-char-p (char)
- #!+sb-doc
- "The argument must be a character object. Alpha-char-p returns T if the
- argument is an alphabetic character, A-Z or a-z; otherwise ()."
- (declare (character char))
- (let ((m (char-code char)))
- (or (< 64 m 91) (< 96 m 123))))
-
-(defun upper-case-p (char)
- #!+sb-doc
- "The argument must be a character object; upper-case-p returns T if the
- argument is an upper-case character, () otherwise."
- (declare (character char))
- (< 64
- (char-code char)
- 91))
-
-(defun lower-case-p (char)
- #!+sb-doc
- "The argument must be a character object; lower-case-p returns T if the
- argument is a lower-case character, () otherwise."
- (declare (character char))
- (< 96
- (char-code char)
- 123))
-
-(defun both-case-p (char)
- #!+sb-doc
- "The argument must be a character object. Both-case-p returns T if the
- argument is an alphabetic character and if the character exists in
- both upper and lower case. For ASCII, this is the same as Alpha-char-p."
- (declare (character char))
- (let ((m (char-code char)))
- (or (< 64 m 91) (< 96 m 123))))
-
-(defun digit-char-p (char &optional (radix 10.))
- #!+sb-doc
- "If char is a digit in the specified radix, returns the fixnum for
- which that digit stands, else returns NIL. Radix defaults to 10
- (decimal)."
- (declare (character char) (type (integer 2 36) radix))
- (let ((m (- (char-code char) 48)))
- (declare (fixnum m))
- (cond ((<= radix 10.)
- ;; Special-case decimal and smaller radices.
- (if (and (>= m 0) (< m radix)) m nil))
- ;; Digits 0 - 9 are used as is, since radix is larger.
- ((and (>= m 0) (< m 10)) m)
- ;; Check for upper case A - Z.
- ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
- ;; Also check lower case a - z.
- ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
- ;; Else, fail.
- (t nil))))
-
-(defun alphanumericp (char)
- #!+sb-doc
- "Given a character-object argument, alphanumericp returns T if the
- argument is either numeric or alphabetic."
- (declare (character char))
- (let ((m (char-code char)))
- (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
-
-(defun char= (character &rest more-characters)
- #!+sb-doc
- "Returns T if all of its arguments are the same character."
- (do ((clist more-characters (cdr clist)))
- ((atom clist) T)
- (unless (eq (car clist) character) (return nil))))
-
-(defun char/= (character &rest more-characters)
- #!+sb-doc
- "Returns T if no two of its arguments are the same character."
- (do* ((head character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (do* ((l list (cdr l))) ;inner loop returns T
- ((atom l) T) ; iff head /= rest.
- (if (eq head (car l)) (return nil)))
- (return nil))))
-
-(defun char< (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly increasing alphabetic order."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (< (char-int c)
- (char-int (car list)))
- (return nil))))
-
-(defun char> (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly decreasing alphabetic order."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (> (char-int c)
- (char-int (car list)))
- (return nil))))
-
-(defun char<= (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly non-decreasing alphabetic order."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (<= (char-int c)
- (char-int (car list)))
- (return nil))))
-
-(defun char>= (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly non-increasing alphabetic order."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (>= (char-int c)
- (char-int (car list)))
- (return nil))))
-
-;;; Equal-Char-Code is used by the following functions as a version of char-int
-;;; which loses font, bits, and case info.
-
-(defmacro equal-char-code (character)
- `(let ((ch (char-code ,character)))
- (if (< 96 ch 123) (- ch 32) ch)))
-
-(defun char-equal (character &rest more-characters)
- #!+sb-doc
- "Returns T if all of its arguments are the same character.
- Font, bits, and case are ignored."
- (do ((clist more-characters (cdr clist)))
- ((atom clist) T)
- (unless (= (equal-char-code (car clist))
- (equal-char-code character))
- (return nil))))
-
-(defun char-not-equal (character &rest more-characters)
- #!+sb-doc
- "Returns T if no two of its arguments are the same character.
- Font, bits, and case are ignored."
- (do* ((head character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (do* ((l list (cdr l)))
- ((atom l) T)
- (if (= (equal-char-code head)
- (equal-char-code (car l)))
- (return nil)))
- (return nil))))
-
-(defun char-lessp (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly increasing alphabetic order.
- Font, bits, and case are ignored."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (< (equal-char-code c)
- (equal-char-code (car list)))
- (return nil))))
-
-(defun char-greaterp (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly decreasing alphabetic order.
- Font, bits, and case are ignored."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (> (equal-char-code c)
- (equal-char-code (car list)))
- (return nil))))
-
-(defun char-not-greaterp (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly non-decreasing alphabetic order.
- Font, bits, and case are ignored."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (<= (equal-char-code c)
- (equal-char-code (car list)))
- (return nil))))
-
-(defun char-not-lessp (character &rest more-characters)
- #!+sb-doc
- "Returns T if its arguments are in strictly non-increasing alphabetic order.
- Font, bits, and case are ignored."
- (do* ((c character (car list))
- (list more-characters (cdr list)))
- ((atom list) T)
- (unless (>= (equal-char-code c)
- (equal-char-code (car list)))
- (return nil))))
-\f
-;;;; miscellaneous functions
-
-(defun char-upcase (char)
- #!+sb-doc
- "Returns CHAR converted to upper-case if that is possible."
- (declare (character char))
- (if (lower-case-p char)
- (code-char (- (char-code char) 32))
- char))
-
-(defun char-downcase (char)
- #!+sb-doc
- "Returns CHAR converted to lower-case if that is possible."
- (declare (character char))
- (if (upper-case-p char)
- (code-char (+ (char-code char) 32))
- char))
-
-(defun digit-char (weight &optional (radix 10))
- #!+sb-doc
- "All arguments must be integers. Returns a character object that
- represents a digit of the given weight in the specified radix. Returns
- NIL if no such character exists. The character will have the specified
- font attributes."
- (declare (type (integer 2 36) radix) (type unsigned-byte weight))
- (and (typep weight 'fixnum)
- (>= weight 0) (< weight radix) (< weight 36)
- (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
;;; a list of toplevel things set by GENESIS
(defvar *!reversed-cold-toplevels*)
-;;; a SIMPLE-VECTOR set by genesis
+;;; a SIMPLE-VECTOR set by GENESIS
(defvar *!load-time-values*)
(defun !cold-lose (msg)
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!IMPL")
+(in-package "SB!KERNEL")
;;; Is X a fixnum in the target Lisp?
(defun fixnump (x)
host-object
target-type-spec))))
-;;; This implementation is an incomplete, portable version for use at
+;;; This is an incomplete, portable implementation for use at
;;; cross-compile time only.
(defun ctypep (obj ctype)
(check-type ctype ctype)
(symbol
(make-member-type :members (list x)))
(number
- (let* ((num (if (complexp x) (realpart x) x))
- (res (make-numeric-type
- :class (etypecase num
- (integer 'integer)
- (rational 'rational)
- (float 'float))
- :format (if (floatp num)
- (float-format-name num)
- nil))))
- (cond ((complexp x)
- (setf (numeric-type-complexp res) :complex)
- (let ((imag (imagpart x)))
- (setf (numeric-type-low res) (min num imag))
- (setf (numeric-type-high res) (max num imag))))
- (t
- (setf (numeric-type-low res) num)
- (setf (numeric-type-high res) num)))
- res))
+ (ctype-of-number x))
(array
(let ((etype (specifier-type (array-element-type x))))
(make-array-type :dimensions (array-dimensions x)
;;;; retained in such a way that we can get to it even on vanilla
;;;; ANSI Common Lisp at cross-compiler build time.
;;;; 2. MAKE-LOAD-FORM information is stored in such a way that we can
-;;;; get to it at bootstrap time before CLOS is built.
+;;;; get to it at bootstrap time before CLOS is built. This is
+;;;; important because at least as of sbcl-0.6.11.26, CLOS is built
+;;;; (compiled) after cold init, so we need to have the compiler
+;;;; even before CLOS runs.
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(warn "*DELAYED-DEF!STRUCTS* is already unbound.")))
;;; The STRUCTURE!OBJECT abstract class is the base of the type
-;;; hierarchy for objects which use DEF!STRUCT functionality.
+;;; hierarchy for objects which have/use DEF!STRUCT functionality.
+;;; (The extra hackery in DEF!STRUCT-defined things isn't needed for
+;;; STRUCTURE-OBJECTs defined by ordinary, post-warm-init programs, so
+;;; it's only put into STRUCTURE-OBJECTs which inherit from
+;;; STRUCTURE!OBJECT.)
(def!struct (structure!object (:constructor nil)))
\f
;;;; hooking this all into the standard MAKE-LOAD-FORM system
+;;; MAKE-LOAD-FORM for DEF!STRUCT-defined types
(defun structure!object-make-load-form (object &optional env)
- #!+sb-doc
- "MAKE-LOAD-FORM for DEF!STRUCT-defined types"
(declare (ignore env))
(funcall (def!struct-type-make-load-form-fun (type-of object))
object))
;;;; the legendary DEFSTRUCT macro itself (both CL:DEFSTRUCT and its
;;;; close personal friend SB!XC:DEFSTRUCT)
-;;; Return a list of forms to install print and make-load-form funs, mentioning
-;;; them in the expansion so that they can be compiled.
+;;; Return a list of forms to install PRINT and MAKE-LOAD-FORM funs,
+;;; mentioning them in the expansion so that they can be compiled.
(defun class-method-definitions (defstruct)
(let ((name (dd-name defstruct)))
`((locally
'(or float (complex float)))
;;; character components
-(sb!xc:deftype char-code () `(integer 0 (,char-code-limit)))
+(sb!xc:deftype char-code () `(integer 0 (,sb!xc:char-code-limit)))
;;; a consed sequence result. If a vector, is a simple array.
(sb!xc:deftype consed-sequence () '(or list (simple-array * (*))))
(format nil "~S" expr)))))
(defun %failed-aver (expr-as-string)
(error "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+
+;;; Return the numeric value of a type bound, i.e. an interval bound
+;;; more or less in the format of bounds in ANSI's type specifiers,
+;;; where a bare numeric value is a closed bound and a list of a
+;;; single numeric value is an open bound.
+;;;
+;;; The "more or less" bit is that the no-bound-at-all case is
+;;; represented by NIL (not by * as in ANSI type specifiers); and in
+;;; this case we return NIL.
+(defun type-bound-number (x)
+ (if (consp x)
+ (destructuring-bind (result) x result)
+ x))
\f
;;;; utilities for two-VALUES predicates
;;; Has the type system been properly initialized? (I.e. is it OK to
;;; use it?)
(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
-
-;;; Use experimental type functionality?
-;;;
-;;; REMOVEME: Eventually the new type functionality should be stable
-;;; enough that nothing depends on this, and we can remove it again.
-(defvar *xtype?*)
-(!cold-init-forms (setf *xtype?* nil))
\f
;;; Return the type structure corresponding to a type specifier. We
;;; pick off structure types as a special case.
;;; such as FIXNUM.
(defstruct (numeric-type (:include ctype
(class-info (type-class-or-lose 'number)))
- #!+negative-zero-is-not-zero
- (:constructor %make-numeric-type))
+ (:constructor %make-numeric-type)
+ (:copier nil))
;; the kind of numeric type we have, or NIL if not specified (just
;; NUMBER or COMPLEX)
;;
;; weird that comment above says "Numeric-Type is used to represent
;; 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))
+ ;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
+ ;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
+ ;; whatnot be concrete subclasses..
+ (class nil :type (member integer rational float nil) :read-only t)
;; "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 :type (or float-format null))
+ (format nil :type (or float-format null) :read-only t)
;; 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?
- (complexp :real :type (member :real :complex nil))
+ (complexp :real :type (member :real :complex nil) :read-only t)
;; The upper and lower bounds on the value, or NIL if there is no
;; bound. If a list of a number, the bound is exclusive. Integer
- ;; types never have exclusive bounds.
- (low nil :type (or number cons null))
- (high nil :type (or number cons null)))
+ ;; types never have exclusive bounds, i.e. they may have them on
+ ;; input, but they're canonicalized to inclusive bounds before we
+ ;; store them here.
+ (low nil :type (or number cons null) :read-only t)
+ (high nil :type (or number cons null) :read-only t))
+
+;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
+;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
+;;; NUMERIC-TYPE.
+(defun make-numeric-type (&key class format (complexp :real) low high
+ enumerable)
+ ;; if interval is empty
+ (if (and low
+ high
+ (if (or (consp low) (consp high)) ; if either bound is exclusive
+ (>= (type-bound-number low) (type-bound-number high))
+ (> low high)))
+ *empty-type*
+ (multiple-value-bind (canonical-low canonical-high)
+ (case class
+ (integer
+ ;; INTEGER types always have their LOW and HIGH bounds
+ ;; represented as inclusive, not exclusive values.
+ (values (if (consp low)
+ (1+ (type-bound-number low))
+ low)
+ (if (consp high)
+ (1- (type-bound-number high))
+ high)))
+ #!+negative-zero-is-not-zero
+ (float
+ ;; Canonicalize a low bound of (-0.0) to 0.0, and a high
+ ;; bound of (+0.0) to -0.0.
+ (values (if (and (consp low)
+ (floatp (car low))
+ (zerop (car low))
+ (minusp (float-sign (car low))))
+ (float 0.0 (car low))
+ low)
+ (if (and (consp high)
+ (floatp (car high))
+ (zerop (car high))
+ (plusp (float-sign (car high))))
+ (float -0.0 (car high))
+ high)))
+ (t
+ ;; no canonicalization necessary
+ (values low high)))
+ (%make-numeric-type :class class
+ :format format
+ :complexp complexp
+ :low canonical-low
+ :high canonical-high
+ :enumerable enumerable))))
+
+(defun modified-numeric-type (base
+ &key
+ (class (numeric-type-class base))
+ (format (numeric-type-format base))
+ (complexp (numeric-type-complexp base))
+ (low (numeric-type-low base))
+ (high (numeric-type-high base))
+ (enumerable (numeric-type-enumerable base)))
+ (make-numeric-type :class class
+ :format format
+ :complexp complexp
+ :low low
+ :high high
+ :enumerable enumerable))
;;; An ARRAY-TYPE is used to represent any array type, including
;;; things such as SIMPLE-STRING.
\f
(/show0 "filesys.lisp 899")
-;;; Predicate to order pathnames by. Goes by name.
+;;; predicate to order pathnames by; goes by name
(defun pathname-order (x y)
(let ((xn (%pathname-name x))
(yn (%pathname-name y)))
\f
;;;; numeric types
-#!+negative-zero-is-not-zero
-(defun make-numeric-type (&key class format (complexp :real) low high
- enumerable)
- (flet ((canonicalise-low-bound (x)
- ;; Canonicalise a low bound of (-0.0) to 0.0.
- (if (and (consp x) (floatp (car x)) (zerop (car x))
- (minusp (float-sign (car x))))
- (float 0.0 (car x))
- x))
- (canonicalise-high-bound (x)
- ;; Canonicalise a high bound of (+0.0) to -0.0.
- (if (and (consp x) (floatp (car x)) (zerop (car x))
- (plusp (float-sign (car x))))
- (float -0.0 (car x))
- x)))
- (%make-numeric-type :class class
- :format format
- :complexp complexp
- :low (canonicalise-low-bound low)
- :high (canonicalise-high-bound high)
- :enumerable enumerable)))
-
(!define-type-class number)
(!define-type-method (number :simple-=) (type1 type2)
(when (eq (numeric-type-complexp component-type) :complex)
(error "The component type for COMPLEX is complex: ~S"
typespec))
- (let ((result (copy-numeric-type component-type)))
- (setf (numeric-type-complexp result) :complex)
- result)))
+ (modified-numeric-type component-type :complexp :complex)))
(let ((type (specifier-type typespec)))
(typecase type
;; This is all that CMU CL handled.
:element-type (specifier-type element-type)
:complexp nil)))
\f
+;;;; utilities shared between cross-compiler and target system
+
+;;; This messy case of CTYPE for NUMBER is shared between the
+;;; cross-compiler and the target system.
+(defun ctype-of-number (x)
+ (let ((num (if (complexp x) (realpart x) x)))
+ (multiple-value-bind (complexp low high)
+ (if (complexp x)
+ (let ((imag (imagpart x)))
+ (values :complex (min num imag) (max num imag)))
+ (values :real num num))
+ (make-numeric-type :class (etypecase num
+ (integer 'integer)
+ (rational 'rational)
+ (float 'float))
+ :format (and (floatp num) (float-format-name num))
+ :complexp complexp
+ :low low
+ :high high))))
+\f
(!defun-from-collected-cold-init-forms !late-type-cold-init)
(/show0 "late-type.lisp end of file")
;;; the guts of DEFCONSTANT
(defun sb!c::%defconstant (name value doc)
(unless (symbolp name)
- (error "constant name not a symbol: ~S" name))
+ (error "The constant name is not a symbol: ~S" name))
(about-to-modify name)
(let ((kind (info :variable :kind name)))
(case kind
(t (warn "redefining ~(~A~) ~S to be a constant" kind name))))
(when doc
(setf (fdocumentation name 'variable) doc))
- (setf (symbol-value name) value)
+
+ ;; We want to set the cross-compilation host's symbol value, not just
+ ;; the cross-compiler's (INFO :VARIABLE :CONSTANT-VALUE NAME), so
+ ;; that code like
+ ;; (defconstant max-entries 61)
+ ;; (deftype entry-index () `(mod ,max-entries))
+ ;; will be cross-compiled correctly.
+ #-sb-xc-host (setf (symbol-value name) value)
+ #+sb-xc-host (progn
+ (/show (symbol-package name))
+ ;; Redefining our cross-compilation host's CL symbols
+ ;; would be poor form.
+ ;;
+ ;; FIXME: Having to check this and then not treat it
+ ;; as a fatal error seems like a symptom of things
+ ;; being pretty broken. It's also a problem in and of
+ ;; itself, since it makes it too easy for cases of
+ ;; using the cross-compilation host Lisp's CL
+ ;; constant values in the target Lisp to slip by. I
+ ;; got backed into this because the cross-compiler
+ ;; translates DEFCONSTANT SB!XC:FOO into DEFCONSTANT
+ ;; CL:FOO. It would be good to unscrew the
+ ;; cross-compilation package hacks so that that
+ ;; translation doesn't happen. Perhaps:
+ ;; * Replace SB-XC with SB-CL. SB-CL exports all the
+ ;; symbols which ANSI requires to be exported from CL.
+ ;; * Make a nickname SB!CL which behaves like SB!XC.
+ ;; * Go through the loaded-on-the-host code making
+ ;; every target definition be in SB-CL. E.g.
+ ;; DEFMACRO-MUNDANELY DEFCONSTANT becomes
+ ;; DEFMACRO-MUNDANELY SB!CL:DEFCONSTANT.
+ ;; * Make IN-TARGET-COMPILATION-MODE do
+ ;; UNUSE-PACKAGE CL and USE-PACKAGE SB-CL in each
+ ;; of the target packages (then undo it on exit).
+ ;; * Make the cross-compiler's implementation of
+ ;; EVAL-WHEN (:COMPILE-TOPLEVEL) do UNCROSS.
+ ;; (This may not require any change.)
+ ;; * Hack GENESIS as necessary so that it outputs
+ ;; SB-CL stuff as COMMON-LISP stuff.
+ ;; * Now the code here can assert that the symbol
+ ;; being defined isn't in the cross-compilation
+ ;; host's CL package.
+ (unless (eql (find-symbol (symbol-name name) :cl) name)
+ ;; KLUDGE: In the cross-compiler, we use the
+ ;; cross-compilation host's DEFCONSTANT macro
+ ;; instead of just (SETF SYMBOL-VALUE), in order to
+ ;; get whatever blessing the cross-compilation host
+ ;; may expect for a global (SETF SYMBOL-VALUE).
+ ;; (CMU CL, at least around 2.4.19, generated full
+ ;; WARNINGs for code -- e.g. DEFTYPE expanders --
+ ;; which referred to symbols which had been set by
+ ;; (SETF SYMBOL-VALUE). I doubt such warnings are
+ ;; ANSI-compliant, but I'm not sure, so I've
+ ;; written this in a way that CMU CL will tolerate
+ ;; and which ought to work elsewhere too.) -- WHN
+ ;; 2001-03-24
+ (eval `(defconstant ,name ',value))))
+
(setf (info :variable :kind name) :constant)
(setf (info :variable :constant-value name) value)
name)
(unless ,(first endlist) (go ,label-1))
(return-from ,block (progn ,@(rest endlist))))))))))
-;;; DO-ANONYMOUS ({(Var [Init] [Step])}*) (Test Exit-Form*) Declaration* Form*
-;;;
;;; This is like DO, except it has no implicit NIL block. Each VAR is
;;; initialized in parallel to the value of the specified INIT form.
;;; On subsequent iterations, the VARS are assigned the value of the
;; Then complain.
(error 'simple-type-error
:datum maybe-package
- :expected-type 'package
+ :expected-type '(and package (satisfies package-name))
:format-control
- "~@<~S can't be a ~S: ~2I~_~S has been reset to ~S.~:>"
- :format-arguments (list '*package* (type-of maybe-package)
+ "~@<~S can't be a ~A: ~2I~_~S has been reset to ~S.~:>"
+ :format-arguments (list '*package*
+ (if (packagep maybe-package)
+ "deleted package"
+ (type-of maybe-package))
'*package* really-package)))))))
;;; Give names to elements of a numeric sequence.
;;; character has. At characters have at least one bit set, so we can
;;; search for any character with a positive test.
(defvar *character-attributes*
- (make-array char-code-limit :element-type '(unsigned-byte 16)
+ (make-array char-code-limit
+ :element-type '(unsigned-byte 16)
:initial-element 0))
(declaim (type (simple-array (unsigned-byte 16) (#.char-code-limit))
*character-attributes*))
(in-package "SB!IMPL")
(sb!xc:deftype attribute-table ()
- '(simple-array (unsigned-byte 8) (#.char-code-limit)))
+ '(simple-array (unsigned-byte 8) (#.sb!xc:char-code-limit)))
;;; constants for readtable character attributes. These are all as in
;;; the manual.
(defconstant +char-attr-delimiter+ 12) ; (a fake for READ-UNQUALIFIED-TOKEN)
(sb!xc:defstruct (readtable (:conc-name nil)
- (:predicate readtablep))
+ (:predicate readtablep)
+ ;; ANSI requires a CL:COPY-READTABLE to do
+ ;; a deep copy, so the DEFSTRUCT-generated
+ ;; default is not suitable.
+ (:copier nil))
#!+sb-doc
"A READTABLE is a data structure that maps characters into syntax
types for the Common Lisp expression reader."
;; in the character attribute table by having different varieties of
;; constituents.
(character-attribute-table
- (make-array char-code-limit
+ (make-array sb!xc:char-code-limit
:element-type '(unsigned-byte 8)
:initial-element +char-attr-constituent+)
:type attribute-table)
;; implement user-defined read-macros, system read-macros, and the
;; number-symbol reader.
(character-macro-table
- (make-array char-code-limit :initial-element #'undefined-macro-char)
- :type (simple-vector #.char-code-limit))
+ (make-array sb!xc:char-code-limit :initial-element #'undefined-macro-char)
+ :type (simple-vector #.sb!xc:char-code-limit))
;; an alist from dispatch characters to vectors of CHAR-CODE-LIMIT
;; functions, for use in defining dispatching macros (like #-macro)
(dispatch-tables () :type list)
--- /dev/null
+;;;; character functions
+;;;;
+;;;; This implementation assumes the use of ASCII codes and the
+;;;; specific character formats used in SBCL (and its ancestor, CMU
+;;;; CL). It is optimized for performance rather than for portability
+;;;; and elegance, and may have to be rewritten if the character
+;;;; representation is changed.
+;;;;
+;;;; KLUDGE: As of sbcl-0.6.11.25, at least, the ASCII-dependence is
+;;;; not confined to this file. E.g. there are DEFTRANSFORMs in
+;;;; srctran.lisp for CHAR-UPCASE, CHAR-EQUAL, and CHAR-DOWNCASE, and
+;;;; they assume ASCII. -- WHN 2001-03-25
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The 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!IMPL")
+
+;;; We compile some trivial character operations via inline expansion.
+#!-sb-fluid
+(declaim (inline standard-char-p graphic-char-p alpha-char-p
+ upper-case-p lower-case-p both-case-p alphanumericp
+ char-int))
+(declaim (maybe-inline digit-char-p digit-weight))
+
+(deftype char-code ()
+ `(integer 0 (,char-code-limit)))
+
+(macrolet ((frob (char-names-list)
+ (collect ((results))
+ (dolist (code char-names-list)
+ (destructuring-bind (ccode names) code
+ (dolist (name names)
+ (results (cons name (code-char ccode))))))
+ `(defparameter *char-name-alist* ',(results)
+ #!+sb-doc
+ "This is the alist of (character-name . character) for characters with
+ long names. The first name in this list for a given character is used
+ on typeout and is the preferred form for input."))))
+ (frob ((#x00 ("Null" "^@" "Nul"))
+ (#x01 ("^a" "Soh"))
+ (#x02 ("^b" "Stx"))
+ (#x03 ("^c" "Etx"))
+ (#x04 ("^d" "Eot"))
+ (#x05 ("^e" "Enq"))
+ (#x06 ("^f" "Ack"))
+ (#x07 ("Bell" "^g" "Bel"))
+ (#x08 ("Backspace" "^h" "Bs"))
+ (#x09 ("Tab" "^i" "Ht"))
+ (#x0A ("Newline" "Linefeed" "^j" "Lf" "Nl" ))
+ (#x0B ("Vt" "^k"))
+ (#x0C ("Page" "^l" "Form" "Formfeed" "Ff" "Np"))
+ (#x0D ("Return" "^m" "Cr"))
+ (#x0E ("^n" "So"))
+ (#x0F ("^o" "Si"))
+ (#x10 ("^p" "Dle"))
+ (#x11 ("^q" "Dc1"))
+ (#x12 ("^r" "Dc2"))
+ (#x13 ("^s" "Dc3"))
+ (#x14 ("^t" "Dc4"))
+ (#x15 ("^u" "Nak"))
+ (#x16 ("^v" "Syn"))
+ (#x17 ("^w" "Etb"))
+ (#x18 ("^x" "Can"))
+ (#x19 ("^y" "Em"))
+ (#x1A ("^z" "Sub"))
+ (#x1B ("Escape" "^[" "Altmode" "Esc" "Alt"))
+ (#x1C ("^\\" "Fs"))
+ (#x1D ("^]" "Gs"))
+ (#x1E ("^^" "Rs"))
+ (#x1F ("^_" "Us"))
+ (#x20 ("Space" "Sp"))
+ (#x7f ("Rubout" "Delete" "Del")))))
+\f
+;;;; accessor functions
+
+(defun char-code (char)
+ #!+sb-doc
+ "Returns the integer code of CHAR."
+ (etypecase char
+ (base-char (char-code (truly-the base-char char)))))
+
+(defun char-int (char)
+ #!+sb-doc
+ "Returns the integer code of CHAR. This is the same as char-code, as
+ CMU Common Lisp does not implement character bits or fonts."
+ (char-code char))
+
+(defun code-char (code)
+ #!+sb-doc
+ "Returns the character with the code CODE."
+ (declare (type char-code code))
+ (code-char code))
+
+(defun character (object)
+ #!+sb-doc
+ "Coerces its argument into a character object if possible. Accepts
+ characters, strings and symbols of length 1."
+ (flet ((do-error (control args)
+ (error 'simple-type-error
+ :datum object
+ ;;?? how to express "symbol with name of length 1"?
+ :expected-type '(or character (string 1))
+ :format-control control
+ :format-arguments args)))
+ (typecase object
+ (character object)
+ (string (if (= 1 (length (the string object)))
+ (char object 0)
+ (do-error
+ "String is not of length one: ~S" (list object))))
+ (symbol (if (= 1 (length (symbol-name object)))
+ (schar (symbol-name object) 0)
+ (do-error
+ "Symbol name is not of length one: ~S" (list object))))
+ (t (do-error "~S cannot be coerced to a character." (list object))))))
+
+(defun char-name (char)
+ #!+sb-doc
+ "Given a character object, char-name returns the name for that
+ object (a symbol)."
+ (car (rassoc char *char-name-alist*)))
+
+(defun name-char (name)
+ #!+sb-doc
+ "Given an argument acceptable to string, name-char returns a character
+ object whose name is that symbol, if one exists. Otherwise, () is returned."
+ (cdr (assoc (string name) *char-name-alist* :test #'string-equal)))
+\f
+;;;; predicates
+
+(defun standard-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Standard-char-p returns T if the
+ argument is a standard character -- one of the 95 ASCII printing characters
+ or <return>."
+ (declare (character char))
+ (and (typep char 'base-char)
+ (let ((n (char-code (the base-char char))))
+ (or (< 31 n 127)
+ (= n 10)))))
+
+(defun %standard-char-p (thing)
+ #!+sb-doc
+ "Return T if and only if THING is a standard-char. Differs from
+ standard-char-p in that THING doesn't have to be a character."
+ (and (characterp thing) (standard-char-p thing)))
+
+(defun graphic-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Graphic-char-p returns T if the
+ argument is a printing character (space through ~ in ASCII), otherwise
+ returns ()."
+ (declare (character char))
+ (and (typep char 'base-char)
+ (< 31
+ (char-code (the base-char char))
+ 127)))
+
+(defun alpha-char-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Alpha-char-p returns T if the
+ argument is an alphabetic character, A-Z or a-z; otherwise ()."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 64 m 91) (< 96 m 123))))
+
+(defun upper-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object; upper-case-p returns T if the
+ argument is an upper-case character, () otherwise."
+ (declare (character char))
+ (< 64
+ (char-code char)
+ 91))
+
+(defun lower-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object; lower-case-p returns T if the
+ argument is a lower-case character, () otherwise."
+ (declare (character char))
+ (< 96
+ (char-code char)
+ 123))
+
+(defun both-case-p (char)
+ #!+sb-doc
+ "The argument must be a character object. Both-case-p returns T if the
+ argument is an alphabetic character and if the character exists in
+ both upper and lower case. For ASCII, this is the same as Alpha-char-p."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 64 m 91) (< 96 m 123))))
+
+(defun digit-char-p (char &optional (radix 10.))
+ #!+sb-doc
+ "If char is a digit in the specified radix, returns the fixnum for
+ which that digit stands, else returns NIL. Radix defaults to 10
+ (decimal)."
+ (declare (character char) (type (integer 2 36) radix))
+ (let ((m (- (char-code char) 48)))
+ (declare (fixnum m))
+ (cond ((<= radix 10.)
+ ;; Special-case decimal and smaller radices.
+ (if (and (>= m 0) (< m radix)) m nil))
+ ;; Digits 0 - 9 are used as is, since radix is larger.
+ ((and (>= m 0) (< m 10)) m)
+ ;; Check for upper case A - Z.
+ ((and (>= (setq m (- m 7)) 10) (< m radix)) m)
+ ;; Also check lower case a - z.
+ ((and (>= (setq m (- m 32)) 10) (< m radix)) m)
+ ;; Else, fail.
+ (t nil))))
+
+(defun alphanumericp (char)
+ #!+sb-doc
+ "Given a character-object argument, alphanumericp returns T if the
+ argument is either numeric or alphabetic."
+ (declare (character char))
+ (let ((m (char-code char)))
+ (or (< 47 m 58) (< 64 m 91) (< 96 m 123))))
+
+(defun char= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if all of its arguments are the same character."
+ (do ((clist more-characters (cdr clist)))
+ ((atom clist) T)
+ (unless (eq (car clist) character) (return nil))))
+
+(defun char/= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if no two of its arguments are the same character."
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (do* ((l list (cdr l))) ;inner loop returns T
+ ((atom l) T) ; iff head /= rest.
+ (if (eq head (car l)) (return nil)))
+ (return nil))))
+
+(defun char< (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (< (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char> (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (> (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char<= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-decreasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (<= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+(defun char>= (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-increasing alphabetic order."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (>= (char-int c)
+ (char-int (car list)))
+ (return nil))))
+
+;;; Equal-Char-Code is used by the following functions as a version of char-int
+;;; which loses font, bits, and case info.
+
+(defmacro equal-char-code (character)
+ `(let ((ch (char-code ,character)))
+ (if (< 96 ch 123) (- ch 32) ch)))
+
+(defun char-equal (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if all of its arguments are the same character.
+ Font, bits, and case are ignored."
+ (do ((clist more-characters (cdr clist)))
+ ((atom clist) T)
+ (unless (= (equal-char-code (car clist))
+ (equal-char-code character))
+ (return nil))))
+
+(defun char-not-equal (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if no two of its arguments are the same character.
+ Font, bits, and case are ignored."
+ (do* ((head character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (do* ((l list (cdr l)))
+ ((atom l) T)
+ (if (= (equal-char-code head)
+ (equal-char-code (car l)))
+ (return nil)))
+ (return nil))))
+
+(defun char-lessp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly increasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (< (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-greaterp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly decreasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (> (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-not-greaterp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-decreasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (<= (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+
+(defun char-not-lessp (character &rest more-characters)
+ #!+sb-doc
+ "Returns T if its arguments are in strictly non-increasing alphabetic order.
+ Font, bits, and case are ignored."
+ (do* ((c character (car list))
+ (list more-characters (cdr list)))
+ ((atom list) T)
+ (unless (>= (equal-char-code c)
+ (equal-char-code (car list)))
+ (return nil))))
+\f
+;;;; miscellaneous functions
+
+(defun char-upcase (char)
+ #!+sb-doc
+ "Returns CHAR converted to upper-case if that is possible."
+ (declare (character char))
+ (if (lower-case-p char)
+ (code-char (- (char-code char) 32))
+ char))
+
+(defun char-downcase (char)
+ #!+sb-doc
+ "Returns CHAR converted to lower-case if that is possible."
+ (declare (character char))
+ (if (upper-case-p char)
+ (code-char (+ (char-code char) 32))
+ char))
+
+(defun digit-char (weight &optional (radix 10))
+ #!+sb-doc
+ "All arguments must be integers. Returns a character object that
+ represents a digit of the given weight in the specified radix. Returns
+ NIL if no such character exists. The character will have the specified
+ font attributes."
+ (declare (type (integer 2 36) radix) (type unsigned-byte weight))
+ (and (typep weight 'fixnum)
+ (>= weight 0) (< weight radix) (< weight 36)
+ (code-char (if (< weight 10) (+ 48 weight) (+ 55 weight)))))
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
-(in-package "SB!IMPL")
-
-;;; FIXME: These probably belong in some package other than SB!IMPL.
-;;; Perhaps SB!KERNEL?
-
-(defconstant call-arguments-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of arguments which may be passed
- to a function, including rest args.")
-
-(defconstant lambda-parameters-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of parameters which may be specifed
- in a given lambda list. This is actually the limit on required and optional
- parameters. With &key and &aux you can get more.")
-
-(defconstant multiple-values-limit most-positive-fixnum
- #!+sb-doc
- "The exclusive upper bound on the number of multiple-values that you can
- have.")
-\f
-;;; FIXME: more than one IN-PACKAGE in one file, ick
(in-package "SB!EVAL")
;;; This is defined here so that the printer etc. can call
(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; Grovel an individual case to NUMBER-DISPATCH, augmenting Result with the
-;;; type dispatches and bodies. Result is a tree built of alists representing
-;;; the dispatching off each arg (in order). The leaf is the body to be
-;;; executed in that case.
+;;; Grovel an individual case to NUMBER-DISPATCH, augmenting RESULT
+;;; with the type dispatches and bodies. Result is a tree built of
+;;; alists representing the dispatching off each arg (in order). The
+;;; leaf is the body to be executed in that case.
(defun parse-number-dispatch (vars result types var-types body)
(cond ((null vars)
(unless (null types) (error "More types than vars."))
(t
(< o1 o2)))))
-;;; Return an ETYPECASE form that does the type dispatch, ordering the cases
-;;; for efficiency.
+;;; Return an ETYPECASE form that does the type dispatch, ordering the
+;;; cases for efficiency.
(defun generate-number-dispatch (vars error-tags cases)
(if vars
(let ((var (first vars))
) ; EVAL-WHEN
+;;; This is a vaguely case-like macro that does number cross-product
+;;; dispatches. The Vars are the variables we are dispatching off of.
+;;; The Type paired with each Var is used in the error message when no
+;;; case matches. Each case specifies a Type for each var, and is
+;;; executed when that signature holds. A type may be a list
+;;; (FOREACH Each-Type*), causing that case to be repeatedly
+;;; instantiated for every Each-Type. In the body of each case, any
+;;; list of the form (DISPATCH-TYPE Var-Name) is substituted with the
+;;; type of that var in that instance of the case.
+;;;
+;;; As an alternate to a case spec, there may be a form whose CAR is a
+;;; symbol. In this case, we apply the CAR of the form to the CDR and
+;;; treat the result of the call as a list of cases. This process is
+;;; not applied recursively.
(defmacro number-dispatch (var-specs &body cases)
- #!+sb-doc
- "NUMBER-DISPATCH ({(Var Type)}*) {((Type*) Form*) | (Symbol Arg*)}*
- A vaguely case-like macro that does number cross-product dispatches. The
- Vars are the variables we are dispatching off of. The Type paired with each
- Var is used in the error message when no case matches. Each case specifies a
- Type for each var, and is executed when that signature holds. A type may be
- a list (FOREACH Each-Type*), causing that case to be repeatedly instantiated
- for every Each-Type. In the body of each case, any list of the form
- (DISPATCH-TYPE Var-Name) is substituted with the type of that var in that
- instance of the case.
-
- As an alternate to a case spec, there may be a form whose CAR is a symbol.
- In this case, we apply the CAR of the form to the CDR and treat the result of
- the call as a list of cases. This process is not applied recursively."
(let ((res (list nil))
(vars (mapcar #'car var-specs))
(block (gensym)))
\f
;;;; canonicalization utilities
-;;; If imagpart is 0, return realpart, otherwise make a complex. This is
-;;; used when we know that realpart and imagpart are the same type, but
+;;; If IMAGPART is 0, return REALPART, otherwise make a complex. This is
+;;; used when we know that REALPART and IMAGPART are the same type, but
;;; rational canonicalization might still need to be done.
#!-sb-fluid (declaim (inline canonical-complex))
(defun canonical-complex (realpart imagpart)
(t
(%make-complex realpart imagpart)))))
-;;; Given a numerator and denominator with the GCD already divided out, make
-;;; a canonical rational. We make the denominator positive, and check whether
-;;; it is 1.
+;;; Given a numerator and denominator with the GCD already divided
+;;; out, make a canonical rational. We make the denominator positive,
+;;; and check whether it is 1.
#!-sb-fluid (declaim (inline build-ratio))
(defun build-ratio (num den)
(multiple-value-bind (num den)
(* (maybe-truncate dx g2)
(maybe-truncate dy g1))))))))
-;;; Divide two integers, producing a canonical rational. If a fixnum, we see
-;;; whether they divide evenly before trying the GCD. In the bignum case, we
-;;; don't bother, since bignum division is expensive, and the test is not very
-;;; likely to succeed.
+;;; Divide two integers, producing a canonical rational. If a fixnum,
+;;; we see whether they divide evenly before trying the GCD. In the
+;;; bignum case, we don't bother, since bignum division is expensive,
+;;; and the test is not very likely to succeed.
(defun integer-/-integer (x y)
(if (and (typep x 'fixnum) (typep y 'fixnum))
(multiple-value-bind (quo rem) (truncate x y)
(foreach single-float double-float #!+long-float long-float))
(truncate-float (dispatch-type divisor))))))
-;;; Declare these guys inline to let them get optimized a little. ROUND and
-;;; FROUND are not declared inline since they seem too obscure and too
-;;; big to inline-expand by default. Also, this gives the compiler a chance to
-;;; pick off the unary float case. Similarly, CEILING and FLOOR are only
-;;; maybe-inline for now, so that the power-of-2 CEILING and FLOOR transforms
-;;; get a chance.
+;;; Declare these guys inline to let them get optimized a little.
+;;; ROUND and FROUND are not declared inline since they seem too
+;;; obscure and too big to inline-expand by default. Also, this gives
+;;; the compiler a chance to pick off the unary float case. Similarly,
+;;; CEILING and FLOOR are only maybe-inline for now, so that the
+;;; power-of-2 CEILING and FLOOR transforms get a chance.
#!-sb-fluid (declaim (inline rem mod fceiling ffloor ftruncate))
(declaim (maybe-inline ceiling floor))
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be negative then decrement the quotient and augment the remainder by
-;;; the divisor.
(defun floor (number &optional (divisor 1))
#!+sb-doc
"Returns the greatest integer not greater than number, or number/divisor.
The second returned value is (mod number divisor)."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be negative then decrement the quotient
+ ;; and augment the remainder by the divisor.
(multiple-value-bind (tru rem) (truncate number divisor)
(if (and (not (zerop rem))
(if (minusp divisor)
(values (1- tru) (+ rem divisor))
(values tru rem))))
-;;; If the numbers do not divide exactly and the result of (/ number divisor)
-;;; would be positive then increment the quotient and decrement the remainder
-;;; by the divisor.
(defun ceiling (number &optional (divisor 1))
#!+sb-doc
"Returns the smallest integer not less than number, or number/divisor.
The second returned value is the remainder."
+ ;; If the numbers do not divide exactly and the result of
+ ;; (/ NUMBER DIVISOR) would be positive then increment the quotient
+ ;; and decrement the remainder by the divisor.
(multiple-value-bind (tru rem) (truncate number divisor)
(if (and (not (zerop rem))
(if (minusp divisor)
(values nil nil))
(values nil t)))
(compound-type
- ;; REMOVEME: old version
- #|
- (let ((certain? t))
- (etypecase type
- (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)))))))
- |#
- (let ((types (compound-type-types type)))
- (etypecase type
- (intersection-type (every/type #'ctypep obj types))
- (union-type (any/type #'ctypep obj types)))))
+ (funcall (etypecase type
+ (intersection-type #'every/type)
+ (union-type #'any/type))
+ #'ctypep
+ obj
+ (compound-type-types type)))
(function-type
(values (functionp obj) t))
(unknown-type
;; run time in order to make it easier to build the cross-compiler.
;; If it doesn't work, something else will be needed..
(locally
- ;; KLUDGE: In order to really make it run at run time (instead of
- ;; doing some weird broken thing at cold load time),
- ;; we need to suppress a DEFTRANSFORM.. -- WHN 19991004
+ ;; KLUDGE: In order to really make this run at run time
+ ;; (instead of doing some weird broken thing at cold load
+ ;; time), we need to suppress a DEFTRANSFORM.. -- WHN 19991004
(declare (notinline sb!xc:find-class))
(class-layout (sb!xc:find-class 'null))))
(t (svref *built-in-class-codes* (get-type x)))))
(symbol
(make-member-type :members (list x)))
(number
- (let* ((num (if (complexp x) (realpart x) x))
- (res (make-numeric-type
- :class (etypecase num
- (integer 'integer)
- (rational 'rational)
- (float 'float))
- :format (if (floatp num)
- (float-format-name num)
- nil))))
- (cond ((complexp x)
- (setf (numeric-type-complexp res) :complex)
- (let ((imag (imagpart x)))
- (setf (numeric-type-low res) (min num imag))
- (setf (numeric-type-high res) (max num imag))))
- (t
- (setf (numeric-type-low res) num)
- (setf (numeric-type-high res) num)))
- res))
+ (ctype-of-number x))
(array
(let ((etype (specifier-type (array-element-type x))))
(make-array-type :dimensions (array-dimensions x)
;; compilation of the target.
(let ((package-name "SB-XC"))
(make-package package-name :use nil :nicknames nil)
- (dolist (name '("ARRAY-RANK-LIMIT"
+ (dolist (name '(;; the constants (except for T and NIL which have
+ ;; a specially hacked correspondence between
+ ;; cross-compilation host Lisp and target Lisp)
"ARRAY-DIMENSION-LIMIT"
- "ARRAY-TOTAL-SIZE-LIMIT"
+ "ARRAY-RANK-LIMIT"
+ "ARRAY-TOTAL-SIZE-LIMIT"
+ "BOOLE-1"
+ "BOOLE-2"
+ "BOOLE-AND"
+ "BOOLE-ANDC1"
+ "BOOLE-ANDC2"
+ "BOOLE-C1"
+ "BOOLE-C2"
+ "BOOLE-CLR"
+ "BOOLE-EQV"
+ "BOOLE-IOR"
+ "BOOLE-NAND"
+ "BOOLE-NOR"
+ "BOOLE-ORC1"
+ "BOOLE-ORC2"
+ "BOOLE-SET"
+ "BOOLE-XOR"
+ "CALL-ARGUMENTS-LIMIT"
+ "CHAR-CODE-LIMIT"
+ "DOUBLE-FLOAT-EPSILON"
+ "DOUBLE-FLOAT-NEGATIVE-EPSILON"
+ "INTERNAL-TIME-UNITS-PER-SECOND"
+ "LAMBDA-LIST-KEYWORDS"
+ "LAMBDA-PARAMETERS-LIMIT"
+ "LEAST-NEGATIVE-DOUBLE-FLOAT"
+ "LEAST-NEGATIVE-LONG-FLOAT"
+ "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT"
+ "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT"
+ "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT"
+ "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT"
+ "LEAST-NEGATIVE-SHORT-FLOAT"
+ "LEAST-NEGATIVE-SINGLE-FLOAT"
+ "LEAST-POSITIVE-DOUBLE-FLOAT"
+ "LEAST-POSITIVE-LONG-FLOAT"
+ "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT"
+ "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT"
+ "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT"
+ "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT"
+ "LEAST-POSITIVE-SHORT-FLOAT"
+ "LEAST-POSITIVE-SINGLE-FLOAT"
+ "LONG-FLOAT-EPSILON"
+ "LONG-FLOAT-NEGATIVE-EPSILON"
+ "MOST-NEGATIVE-DOUBLE-FLOAT"
+ "MOST-NEGATIVE-FIXNUM"
+ "MOST-NEGATIVE-LONG-FLOAT"
+ "MOST-NEGATIVE-SHORT-FLOAT"
+ "MOST-NEGATIVE-SINGLE-FLOAT"
+ "MOST-POSITIVE-DOUBLE-FLOAT"
+ "MOST-POSITIVE-FIXNUM"
+ "MOST-POSITIVE-LONG-FLOAT"
+ "MOST-POSITIVE-SHORT-FLOAT"
+ "MOST-POSITIVE-SINGLE-FLOAT"
+ "MULTIPLE-VALUES-LIMIT"
+ "PI"
+ "SHORT-FLOAT-EPSILON"
+ "SHORT-FLOAT-NEGATIVE-EPSILON"
+ "SINGLE-FLOAT-EPSILON"
+ "SINGLE-FLOAT-NEGATIVE-EPSILON"
+
+ ;; everything else which needs a separate
+ ;; existence in xc and target
"BUILT-IN-CLASS"
"CLASS" "CLASS-NAME" "CLASS-OF"
"COMPILE-FILE"
(error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S"
set-difference)))))
\f
-;;;; compiling SBCL sources to create the cross-compiler
+;;;; tools to compile SBCL sources to create the cross-compiler
;;; Execute function FN in an environment appropriate for compiling the
;;; cross-compiler's source code in the cross-compilation host.
(defun in-host-compilation-mode (fn)
- (let ((*features* (cons :sb-xc-host *features*)))
+ (let ((*features* (cons :sb-xc-host *features*))
+ ;; the CROSS-FLOAT-INFINITY-KLUDGE, as documented in
+ ;; base-target-features.lisp-expr:
+ (*shebang-features* (set-difference *shebang-features*
+ '(:sb-propagate-float-type
+ :sb-propagate-fun-type))))
(with-additional-nickname ("SB-XC" "SB!XC")
(funcall fn))))
-(compile 'in-host-compilation-mode)
+;;; FIXME: This COMPILE caused problems in sbcl-0.6.11.26. (bug 93)
+;;;(compile 'in-host-compilation-mode)
;;; Process a file as source code for the cross-compiler, compiling it
;;; (if necessary) in the appropriate environment, then loading it
(load (concatenate 'simple-string *host-obj-prefix* stem *host-obj-suffix*)))
(compile 'host-load-stem)
\f
-;;;; compiling SBCL sources to create object files which will be used
-;;;; to create the target SBCL .core file
+;;;; tools to compile SBCL sources to create object files which will
+;;;; be used to create the target SBCL .core file
;;; Run the cross-compiler on a file in the source directory tree to
;;; produce a corresponding file in the target object directory tree.
(greater (1+ x))
(t (1- x))))
(bound (x)
- (if greater (numeric-type-low x) (numeric-type-high x)))
- (validate (x)
- (if (and (numeric-type-low x) (numeric-type-high x)
- (> (numeric-type-low x) (numeric-type-high x)))
- *empty-type*
- x)))
+ (if greater (numeric-type-low x) (numeric-type-high x))))
(let* ((x-bound (bound x))
(y-bound (exclude (bound y)))
(new-bound (cond ((not x-bound) y-bound)
((not y-bound) x-bound)
(greater (max x-bound y-bound))
- (t (min x-bound y-bound))))
- (res (copy-numeric-type x)))
+ (t (min x-bound y-bound)))))
(if greater
- (setf (numeric-type-low res) new-bound)
- (setf (numeric-type-high res) new-bound))
- (validate res))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Return true if X is a float NUMERIC-TYPE.
(defun float-type-p (x)
;;; Exactly the same as CONSTRAIN-INTEGER-TYPE, but for float numbers.
(defun constrain-float-type (x y greater or-equal)
(declare (type numeric-type x y))
- ;; Unless :PROPAGATE-FLOAT-TYPE is in target features, then
- ;; SB!C::BOUND-VALUE (used in the code below) is not defined, so we
- ;; just return X without trying to calculate additional constraints.
- #!-propagate-float-type (declare (ignore y greater or-equal))
- #!-propagate-float-type x
- #!+propagate-float-type
+ ;; FIXME: The comment here used to say
+ ;; Unless #!+SB-PROPAGATE-FLOAT-TYPE, then SB!C::BOUND-VALUE (used in
+ ;; the code below) is not defined, so we just return X without
+ ;; trying to calculate additional constraints.
+ ;; But as of sbcl-0.6.11.26, SB!C::BOUND-VALUE has been renamed to
+ ;; SB!INT:TYPE-BOUND-NUMBER and is always defined, so probably the
+ ;; conditionalization should go away.
+ #!-sb-propagate-float-type (declare (ignore greater or-equal))
+ (aver (eql (numeric-type-class x) 'float))
+ (aver (eql (numeric-type-class y) 'float))
+ #!-sb-propagate-float-type x
+ #!+sb-propagate-float-type
(labels ((exclude (x)
(cond ((not x) nil)
(or-equal x)
(bound (x)
(if greater (numeric-type-low x) (numeric-type-high x)))
(max-lower-bound (x y)
- ;; Both x and y are not null. Find the max.
- (let ((res (max (bound-value x) (bound-value y))))
+ ;; Both X and Y are not null. Find the max.
+ (let ((res (max (type-bound-number x) (type-bound-number y))))
;; An open lower bound is greater than a close
;; lower bound because the open bound doesn't
;; contain the bound, so choose an open lower
(set-bound res (or (consp x) (consp y)))))
(min-upper-bound (x y)
;; Same as above, but for the min of upper bounds
- ;; Both x and y are not null. Find the min.
- (let ((res (min (bound-value x) (bound-value y))))
+ ;; Both X and Y are not null. Find the min.
+ (let ((res (min (type-bound-number x) (type-bound-number y))))
;; An open upper bound is less than a closed
;; upper bound because the open bound doesn't
;; contain the bound, so choose an open lower
;; bound.
- (set-bound res (or (consp x) (consp y)))))
- (validate (x)
- (let ((x-lo (numeric-type-low x))
- (x-hi (numeric-type-high x)))
- (if (and x-lo x-hi (> (bound-value x-lo) (bound-value x-hi)))
- *empty-type*
- x))))
+ (set-bound res (or (consp x) (consp y))))))
(let* ((x-bound (bound x))
(y-bound (exclude (bound y)))
(new-bound (cond ((not x-bound)
(greater
(max-lower-bound x-bound y-bound))
(t
- (min-upper-bound x-bound y-bound))))
- (res (copy-numeric-type x)))
+ (min-upper-bound x-bound y-bound)))))
(if greater
- (setf (numeric-type-low res) new-bound)
- (setf (numeric-type-high res) new-bound))
- (validate res))))
+ (modified-numeric-type x :low new-bound)
+ (modified-numeric-type x :high new-bound)))))
;;; Given the set of CONSTRAINTS for a variable and the current set of
;;; restrictions from flow analysis IN, set the type for REF
(let ((greater (if not-p (not greater) greater)))
(setq res
(constrain-integer-type res y greater not-p)))))
- #!+constrain-float-type
+ #!+sb-constrain-float-type
((and (float-type-p res) (float-type-p y))
(let ((greater (eq kind '>)))
(let ((greater (if not-p (not greater) greater)))
(let ((ctype (continuation-type cont)))
(multiple-value-bind (int win) (funcall *test-function* ctype type)
(cond ((not win)
- (note-slime "can't tell whether the ~:R argument is a ~S" n
- (type-specifier type))
+ (note-slime "can't tell whether the ~:R argument is a ~S"
+ n (type-specifier type))
nil)
((not int)
- (note-lossage "The ~:R argument is a ~S, not a ~S." n
- (type-specifier ctype)
- (type-specifier type))
+ (note-lossage "The ~:R argument is a ~S, not a ~S."
+ n (type-specifier ctype) (type-specifier type))
nil)
((eq ctype *empty-type*)
(note-slime "The ~:R argument never returns a value." n)
(defstruct (approximate-function-type (:copier nil))
;; the smallest and largest numbers of arguments that this function
;; has been called with.
- (min-args call-arguments-limit :type fixnum)
+ (min-args sb!xc: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.
+ ;; a list of lists of the all the types that have been used in each
+ ;; argument position
(types () :type list)
;; A list of APPROXIMATE-KEY-INFO structures describing all the
;; things that looked like &KEY arguments. There are distinct
;; The position at which this keyword appeared. 0 if it appeared as the
;; first argument, etc.
(position (required-argument) :type fixnum)
- ;; A list of all the argument types that have been used with this keyword.
+ ;; a list of all the argument types that have been used with this keyword
(types nil :type list)
- ;; True if this keyword has appeared only in calls with an obvious
- ;; :allow-other-keys.
+ ;; true if this keyword has appeared only in calls with an obvious
+ ;; :ALLOW-OTHER-KEYS
(allowp nil :type (member t nil)))
;;; Return an APPROXIMATE-FUNCTION-TYPE representing the context of
;; of automatically finding #!+sb-doc in proximity to DEFTRANSFORM
;; to let me scan for places that I made this mistake and didn't
;; catch myself.
- "use inline (unsigned-byte 32) operations"
+ "use inline (UNSIGNED-BYTE 32) operations"
(let ((num-high (numeric-type-high (continuation-type num))))
(when (null num-high)
(give-up-ir1-transform))
'(%scalbn f ex)
'(scale-double-float f ex)))
-;;; toy@rtp.ericsson.se:
-;;;
;;; optimizers for SCALE-FLOAT. If the float has bounds, new bounds
;;; are computed for the result, if possible.
-
-#!+propagate-float-type
+#!+sb-propagate-float-type
(progn
(defun scale-float-derive-type-aux (f ex same-arg)
;; zeros.
(set-bound
(handler-case
- (scale-float (bound-value x) n)
+ (scale-float (type-bound-number x) n)
(floating-point-overflow ()
nil))
(consp x))))
;;; FLOAT function return the correct ranges if the input has some
;;; defined range. Quite useful if we want to convert some type of
;;; bounded integer into a float.
-
(macrolet
((frob (fun type)
(let ((aux-name (symbolicate fun "-DERIVE-TYPE-AUX")))
;;; Derive the result to be float for argument types in the
;;; appropriate domain.
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(dolist (stuff '((asin (real -1.0 1.0))
(acos (real -1.0 1.0))
(acosh (real 1.0))
type)
(specifier-type 'float)))))))
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(defoptimizer (log derive-type) ((x &optional y))
(when (and (csubtypep (continuation-type x)
(specifier-type '(real 0.0)))
(float pi x)
(float 0 x)))
-#!+(or propagate-float-type propagate-fun-type)
+#!+(or sb-propagate-float-type sb-propagate-fun-type)
(progn
;;; The number is of type REAL.
) ; PROGN
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(progn
;;;; optimizers for elementary functions
(float-type (or format 'float)))
(specifier-type `(complex ,float-type))))
-;;; Compute a specifier like '(or float (complex float)), except float
+;;; Compute a specifier like '(OR FLOAT (COMPLEX FLOAT)), except float
;;; should be the right kind of float. Allow bounds for the float
;;; part too.
(defun float-or-complex-float-type (arg &optional lo hi)
;;; Test whether the numeric-type ARG is within in domain specified by
;;; DOMAIN-LOW and DOMAIN-HIGH, consider negative and positive zero to
-;;; be distinct as for the :negative-zero-is-not-zero feature. With
-;;; the :negative-zero-is-not-zero feature this could be handled by
+;;; be distinct as for the :NEGATIVE-ZERO-IS-NOT-ZERO feature. With
+;;; the :NEGATIVE-ZERO-IS-NOT-ZERO feature this could be handled by
;;; the numeric subtype code in type.lisp.
(defun domain-subtypep (arg domain-low domain-high)
(declare (type numeric-type arg)
(type (or real null) domain-low domain-high))
(let* ((arg-lo (numeric-type-low arg))
- (arg-lo-val (bound-value arg-lo))
+ (arg-lo-val (type-bound-number arg-lo))
(arg-hi (numeric-type-high arg))
- (arg-hi-val (bound-value arg-hi)))
+ (arg-hi-val (type-bound-number arg-hi)))
;; Check that the ARG bounds are correctly canonicalized.
(when (and arg-lo (floatp arg-lo-val) (zerop arg-lo-val) (consp arg-lo)
(minusp (float-sign arg-lo-val)))
default-low))
(res-hi (or (bound-func fcn (if increasingp high low))
default-high))
- ;; Result specifier type.
(format (case (numeric-type-class arg)
((integer rational) 'single-float)
(t (numeric-type-format arg))))
;; Y is positive and log X >= 0. The range of exp(y * log(x)) is
;; obviously non-negative. We just have to be careful for
;; infinite bounds (given by nil).
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
('-
;; Y is negative and log x >= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. However, underflow (nil) means 0 is the
;; result.
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-low y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
(t
;; Split the interval in half.
;; Y is positive and log X <= 0. The range of exp(y * log(x)) is
;; obviously [0, 1]. We just have to be careful for infinite bounds
;; (given by nil).
- (let ((lo (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-high y))))
- (hi (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-low y)))))
+ (let ((lo (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-high y))))
+ (hi (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-low y)))))
(list (sb!c::make-interval :low (or lo 0) :high (or hi 1)))))
('-
;; Y is negative and log x <= 0. The range of exp(y * log(x)) is
;; obviously [1, inf].
- (let ((hi (safe-expt (sb!c::bound-value (sb!c::interval-low x))
- (sb!c::bound-value (sb!c::interval-low y))))
- (lo (safe-expt (sb!c::bound-value (sb!c::interval-high x))
- (sb!c::bound-value (sb!c::interval-high y)))))
+ (let ((hi (safe-expt (type-bound-number (sb!c::interval-low x))
+ (type-bound-number (sb!c::interval-low y))))
+ (lo (safe-expt (type-bound-number (sb!c::interval-high x))
+ (type-bound-number (sb!c::interval-high y)))))
(list (sb!c::make-interval :low (or lo 1) :high hi))))
(t
;; Split the interval in half
;; Figure out what the return type should be, given the argument
;; types and bounds and the result type and bounds.
(cond ((csubtypep x-type (specifier-type 'integer))
- ;; An integer to some power. Cases to consider:
+ ;; an integer to some power
(case (numeric-type-class y-type)
(integer
;; Positive integer to an integer power is either an
(let ((lo (or (interval-low bnd) '*))
(hi (or (interval-high bnd) '*)))
(if (and (interval-low y-int)
- (>= (bound-value (interval-low y-int)) 0))
+ (>= (type-bound-number (interval-low y-int)) 0))
(specifier-type `(integer ,lo ,hi))
(specifier-type `(rational ,lo ,hi)))))
(rational
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
(int-lo (if lo
- (floor (bound-value lo))
+ (floor (type-bound-number lo))
'*))
(int-hi (if hi
- (ceiling (bound-value hi))
+ (ceiling (type-bound-number hi))
'*))
(f-lo (if lo
(bound-func #'float lo)
(specifier-type `(or (rational ,int-lo ,int-hi)
(single-float ,f-lo, f-hi)))))
(float
- ;; Positive integer to a float power is a float.
- (let ((res (copy-numeric-type y-type)))
- (setf (numeric-type-low res) (interval-low bnd))
- (setf (numeric-type-high res) (interval-high bnd))
- res))
+ ;; A positive integer to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
(t
- ;; Positive integer to a number is a number (for now).
- (specifier-type 'number)))
- )
+ ;; A positive integer to a number is a number (for now).
+ (specifier-type 'number))))
((csubtypep x-type (specifier-type 'rational))
;; a rational to some power
(case (numeric-type-class y-type)
(integer
- ;; Positive rational to an integer power is always a rational.
+ ;; A positive rational to an integer power is always a rational.
(specifier-type `(rational ,(or (interval-low bnd) '*)
,(or (interval-high bnd) '*))))
(rational
- ;; Positive rational to rational power is either a rational
+ ;; A positive rational to rational power is either a rational
;; or a single-float.
(let* ((lo (interval-low bnd))
(hi (interval-high bnd))
(int-lo (if lo
- (floor (bound-value lo))
+ (floor (type-bound-number lo))
'*))
(int-hi (if hi
- (ceiling (bound-value hi))
+ (ceiling (type-bound-number hi))
'*))
(f-lo (if lo
(bound-func #'float lo)
(specifier-type `(or (rational ,int-lo ,int-hi)
(single-float ,f-lo, f-hi)))))
(float
- ;; Positive rational to a float power is a float.
- (let ((res (copy-numeric-type y-type)))
- (setf (numeric-type-low res) (interval-low bnd))
- (setf (numeric-type-high res) (interval-high bnd))
- res))
+ ;; A positive rational to a float power is a float.
+ (modified-numeric-type y-type
+ :low (interval-low bnd)
+ :high (interval-high bnd)))
(t
- ;; Positive rational to a number is a number (for now).
- (specifier-type 'number)))
- )
+ ;; A positive rational to a number is a number (for now).
+ (specifier-type 'number))))
((csubtypep x-type (specifier-type 'float))
;; a float to some power
(case (numeric-type-class y-type)
((or integer rational)
- ;; Positive float to an integer or rational power is
+ ;; A positive float to an integer or rational power is
;; always a float.
(make-numeric-type
:class 'float
:low (interval-low bnd)
:high (interval-high bnd)))
(float
- ;; Positive float to a float power is a float of the higher type.
+ ;; A positive float to a float power is a float of the
+ ;; higher type.
(make-numeric-type
:class 'float
:format (float-format-max (numeric-type-format x-type)
:low (interval-low bnd)
:high (interval-high bnd)))
(t
- ;; Positive float to a number is a number (for now)
+ ;; A positive float to a number is a number (for now)
(specifier-type 'number))))
(t
;; A number to some power is a number.
(let ((result-type (numeric-contagion y x)))
(cond ((and (numeric-type-real-p x)
(numeric-type-real-p y))
- (let* ((format (case (numeric-type-class result-type)
+ (let* (;; FIXME: This expression for FORMAT seems to
+ ;; appear multiple times, and should be factored out.
+ (format (case (numeric-type-class result-type)
((integer rational) 'single-float)
(t (numeric-type-format result-type))))
(bound-format (or format 'float)))
:complexp :real
:low (numeric-type-low type)
:high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#!+(or sb-propagate-fun-type sb-propagate-float-type)
(defoptimizer (realpart derive-type) ((num))
(one-arg-derive-type num #'realpart-derive-type-aux #'realpart))
(defun imagpart-derive-type-aux (type)
:complexp :real
:low (numeric-type-low type)
:high (numeric-type-high type))))))
-#!+(or propagate-fun-type propagate-float-type)
+#!+(or sb-propagate-fun-type sb-propagate-float-type)
(defoptimizer (imagpart derive-type) ((num))
(one-arg-derive-type num #'imagpart-derive-type-aux #'imagpart))
:complex))))
(specifier-type 'complex)))
-#!+(or propagate-fun-type propagate-float-type)
+#!+(or sb-propagate-fun-type sb-propagate-float-type)
(defoptimizer (complex derive-type) ((re &optional im))
(if im
(two-arg-derive-type re im #'complex-derive-type-aux-2 #'complex)
;;; possible answer. This gets around the problem of doing range
;;; reduction correctly but still provides useful results when the
;;; inputs are union types.
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(progn
(defun trig-derive-type-aux (arg domain fcn
&optional def-lo def-hi (increasingp t))
(defknown lcm (&rest integer) unsigned-byte
(movable foldable flushable explicit-check))
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(defknown exp (number) irrational
(movable foldable flushable explicit-check recursive)
:derive-type #'result-type-float-contagion)
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(defknown exp (number) irrational
(movable foldable flushable explicit-check recursive))
(defknown cis (real) (complex float)
(movable foldable flushable explicit-check))
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(progn
(defknown (sin cos) (number)
(or (float -1.0 1.0) (complex float))
:derive-type #'result-type-float-contagion)
) ; PROGN
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(progn
(defknown (sin cos) (number)
(or (float -1.0 1.0) (complex float))
-;;;; the top-level interfaces to the compiler
+;;;; the top-level interfaces to the compiler, plus some other
+;;;; compiler-related stuff (e.g. CL:CALL-ARGUMENTS-LIMIT) which
+;;;; doesn't obviously belong anywhere else
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
(in-package "SB!C")
+(defconstant sb!xc:call-arguments-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of arguments which may be passed
+ to a function, including &REST args.")
+(defconstant sb!xc:lambda-parameters-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of parameters which may be specifed
+ in a given lambda list. This is actually the limit on required and &OPTIONAL
+ parameters. With &KEY and &AUX you can get more.")
+(defconstant sb!xc:multiple-values-limit most-positive-fixnum
+ #!+sb-doc
+ "The exclusive upper bound on the number of multiple VALUES that you can
+ return.")
+
;;; FIXME: Doesn't this belong somewhere else, like early-c.lisp?
(declaim (special *constants* *free-variables* *component-being-compiled*
*code-vector* *next-location* *result-fixups*
\f
;;;; list hackery
-;;; Translate CxxR into CAR/CDR combos.
-
+;;; Translate CxR into CAR/CDR combos.
(defun source-transform-cxr (form)
(if (or (byte-compiling) (/= (length form) 2))
(values nil t)
,res)))
((zerop i) res)))))
-(do ((i 2 (1+ i))
- (b '(1 0) (cons i b)))
- ((= i 5))
- (dotimes (j (ash 1 i))
- (setf (info :function :source-transform
- (intern (format nil "C~{~:[A~;D~]~}R"
- (mapcar #'(lambda (x) (logbitp x j)) b))))
- #'source-transform-cxr)))
+;;; Make source transforms to turn CxR forms into combinations of CAR
+;;; and CDR. ANSI specifies that everything up to 4 A/D operations is
+;;; defined.
+(/show0 "about to set CxR source transforms")
+(loop for i of-type index from 2 upto 4 do
+ ;; Iterate over BUF = all names CxR where x = an I-element
+ ;; string of #\A or #\D characters.
+ (let ((buf (make-string (+ 2 i))))
+ (setf (aref buf 0) #\C
+ (aref buf (1+ i)) #\R)
+ (dotimes (j (ash 2 i))
+ (declare (type index j))
+ (dotimes (k i)
+ (declare (type index k))
+ (setf (aref buf (1+ k))
+ (if (logbitp k j) #\A #\D)))
+ (setf (info :function :source-transform (intern buf))
+ #'source-transform-cxr))))
+(/show0 "done setting CxR source transforms")
;;; Turn FIRST..FOURTH and REST into the obvious synonym, assuming
;;; whatever is right for them is right for us. FIFTH..TENTH turn into
`(,',fun ,x 1)))))
(frob truncate)
(frob round)
- #!+propagate-float-type
+ #!+sb-propagate-float-type
(frob floor)
- #!+propagate-float-type
+ #!+sb-propagate-float-type
(frob ceiling))
(def-source-transform lognand (x y) `(lognot (logand ,x ,y)))
;;;; numeric-type has everything we want to know. Reason 2 wins for
;;;; now.
-#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
-(progn
-#!+propagate-float-type
+#!+sb-propagate-float-type
(progn
;;; The basic interval type. It can handle open and closed intervals.
(%make-interval :low (normalize-bound low)
:high (normalize-bound high))))
-#!-sb-fluid (declaim (inline bound-value set-bound))
-
-;;; Extract the numeric value of a bound. Return NIL, if X is NIL.
-(defun bound-value (x)
- (if (consp x) (car x) x))
-
;;; Given a number X, create a form suitable as a bound for an
;;; interval. Make the bound open if OPEN-P is T. NIL remains NIL.
+#!-sb-fluid (declaim (inline set-bound))
(defun set-bound (x open-p)
(if (and x open-p) (list x) x))
;; With these traps masked, we might get things like infinity
;; or negative infinity returned. Check for this and return
;; NIL to indicate unbounded.
- (let ((y (funcall f (bound-value x))))
+ (let ((y (funcall f (type-bound-number x))))
(if (and (floatp y)
(float-infinity-p y))
nil
- (set-bound (funcall f (bound-value x)) (consp x)))))))
+ (set-bound (funcall f (type-bound-number x)) (consp x)))))))
;;; Apply a binary operator OP to two bounds X and Y. The result is
;;; NIL if either is NIL. Otherwise bound is computed and the result
(defmacro bound-binop (op x y)
`(and ,x ,y
(with-float-traps-masked (:underflow :overflow :inexact :divide-by-zero)
- (set-bound (,op (bound-value ,x)
- (bound-value ,y))
+ (set-bound (,op (type-bound-number ,x)
+ (type-bound-number ,y))
(or (consp ,x) (consp ,y))))))
;;; Convert a numeric-type object to an interval object.
;;; to closed bounds.
(defun interval-closure (x)
(declare (type interval x))
- (make-interval :low (bound-value (interval-low x))
- :high (bound-value (interval-high x))))
+ (make-interval :low (type-bound-number (interval-low x))
+ :high (type-bound-number (interval-high x))))
(defun signed-zero->= (x y)
(declare (real x y))
(declare (type interval x))
(let ((lo (interval-low x))
(hi (interval-high x)))
- (cond ((and lo (signed-zero->= (bound-value lo) point))
+ (cond ((and lo (signed-zero->= (type-bound-number lo) point))
'+)
- ((and hi (signed-zero->= point (bound-value hi)))
+ ((and hi (signed-zero->= point (type-bound-number hi)))
'-)
(t
nil))))
(>= x y))))
(let ((lo (interval-low x))
(hi (interval-high x)))
- (cond ((and lo (signed->= (bound-value lo) point))
+ (cond ((and lo (signed->= (type-bound-number lo) point))
'+)
- ((and hi (signed->= point (bound-value hi)))
+ ((and hi (signed->= point (type-bound-number hi)))
'-)
(t
nil)))))
(hi (interval-high x)))
(cond ((and lo hi)
;; The interval is bounded
- (if (and (signed-zero-<= (bound-value lo) p)
- (signed-zero-<= p (bound-value hi)))
+ (if (and (signed-zero-<= (type-bound-number lo) p)
+ (signed-zero-<= p (type-bound-number hi)))
;; P is definitely in the closure of the interval.
;; We just need to check the end points now.
- (cond ((signed-zero-= p (bound-value lo))
+ (cond ((signed-zero-= p (type-bound-number lo))
(numberp lo))
- ((signed-zero-= p (bound-value hi))
+ ((signed-zero-= p (type-bound-number hi))
(numberp hi))
(t t))
nil))
(hi
;; Interval with upper bound
- (if (signed-zero-< p (bound-value hi))
+ (if (signed-zero-< p (type-bound-number hi))
t
(and (numberp hi) (signed-zero-= p hi))))
(lo
;; Interval with lower bound
- (if (signed-zero-> p (bound-value lo))
+ (if (signed-zero-> p (type-bound-number lo))
t
(and (numberp lo) (signed-zero-= p lo))))
(t
(flet ((adjacent (lo hi)
;; Check to see whether lo and hi are adjacent. If either is
;; nil, they can't be adjacent.
- (when (and lo hi (= (bound-value lo) (bound-value hi)))
+ (when (and lo hi (= (type-bound-number lo) (type-bound-number hi)))
;; The bounds are equal. They are adjacent if one of
;; them is closed (a number). If both are open (consp),
;; then there is a number that lies between them.
(list p)))
(test-number (p int)
;; Test whether P is in the interval.
- (when (interval-contains-p (bound-value p)
+ (when (interval-contains-p (type-bound-number p)
(interval-closure int))
(let ((lo (interval-low int))
(hi (interval-high int)))
;; Check for endpoints.
- (cond ((and lo (= (bound-value p) (bound-value lo)))
+ (cond ((and lo (= (type-bound-number p) (type-bound-number lo)))
(not (and (consp p) (numberp lo))))
- ((and hi (= (bound-value p) (bound-value hi)))
+ ((and hi (= (type-bound-number p) (type-bound-number hi)))
(not (and (numberp p) (consp hi))))
(t t)))))
(test-lower-bound (p int)
(when (or (interval-intersect-p x y)
(interval-adjacent-p x y))
(flet ((select-bound (x1 x2 min-op max-op)
- (let ((x1-val (bound-value x1))
- (x2-val (bound-value x2)))
+ (let ((x1-val (type-bound-number x1))
+ (x2-val (type-bound-number x2)))
(cond ((and x1 x2)
;; Both bounds are finite. Select the right one.
(cond ((funcall min-op x1-val x2-val)
;; is always a closed bound. But don't replace this
;; with zero; we want the multiplication to produce
;; the correct signed zero, if needed.
- (* (bound-value x) (bound-value y)))
+ (* (type-bound-number x) (type-bound-number y)))
((or (and (floatp x) (float-infinity-p x))
(and (floatp y) (float-infinity-p y)))
;; Infinity times anything is infinity
;; we need to watch out for the sign of the result,
;; to correctly handle signed zeros. We also need
;; to watch out for positive or negative infinity.
- (if (floatp (bound-value x))
+ (if (floatp (type-bound-number x))
(if y-low-p
- (- (float-sign (bound-value x) 0.0))
- (float-sign (bound-value x) 0.0))
+ (- (float-sign (type-bound-number x) 0.0))
+ (float-sign (type-bound-number x) 0.0))
0))
- ((zerop (bound-value y))
+ ((zerop (type-bound-number y))
;; Divide by zero means result is infinity
nil)
((and (numberp x) (zerop x))
;; don't overlap.
(let ((left (interval-high x))
(right (interval-low y)))
- (cond ((> (bound-value left)
- (bound-value right))
- ;; Definitely overlap so result is NIL
+ (cond ((> (type-bound-number left)
+ (type-bound-number right))
+ ;; The intervals definitely overlap, so result is NIL.
nil)
- ((< (bound-value left)
- (bound-value right))
- ;; Definitely don't touch, so result is T
+ ((< (type-bound-number left)
+ (type-bound-number right))
+ ;; The intervals definitely don't touch, so result is T.
t)
(t
;; Limits are equal. Check for open or closed bounds.
;; X >= Y if lower bound of X >= upper bound of Y
(when (and (interval-bounded-p x 'below)
(interval-bounded-p y 'above))
- (>= (bound-value (interval-low x)) (bound-value (interval-high y)))))
+ (>= (type-bound-number (interval-low x))
+ (type-bound-number (interval-high y)))))
;;; Return an interval that is the absolute value of X. Thus, if
;;; X = [-1 10], the result is [0, 10].
(declare (type interval x))
(interval-func #'(lambda (x) (* x x))
(interval-abs x)))
-)) ; end PROGN's
+) ; PROGN
\f
;;;; numeric DERIVE-TYPE methods
:high high))
(numeric-contagion x y))))
-#!+(or propagate-float-type propagate-fun-type)
+#!+(or sb-propagate-float-type sb-propagate-fun-type)
(progn
;;; simple utility to flatten a list
new-args)))))
;;; Convert from the standard type convention for which -0.0 and 0.0
-;;; and equal to an intermediate convention for which they are
+;;; are equal to an intermediate convention for which they are
;;; considered different which is more natural for some of the
;;; optimisers.
#!-negative-zero-is-not-zero
;;; Only convert real float interval delimiters types.
(if (eq (numeric-type-complexp type) :real)
(let* ((lo (numeric-type-low type))
- (lo-val (bound-value lo))
+ (lo-val (type-bound-number lo))
(lo-float-zero-p (and lo (floatp lo-val) (= lo-val 0.0)))
(hi (numeric-type-high type))
- (hi-val (bound-value hi))
+ (hi-val (type-bound-number hi))
(hi-float-zero-p (and hi (floatp hi-val) (= hi-val 0.0))))
(if (or lo-float-zero-p hi-float-zero-p)
(make-numeric-type
;;; Only convert real float interval delimiters types.
(if (eq (numeric-type-complexp type) :real)
(let* ((lo (numeric-type-low type))
- (lo-val (bound-value lo))
+ (lo-val (type-bound-number lo))
(lo-float-zero-p
(and lo (floatp lo-val) (= lo-val 0.0)
(float-sign lo-val)))
(hi (numeric-type-high type))
- (hi-val (bound-value hi))
+ (hi-val (type-bound-number hi))
(hi-float-zero-p
(and hi (floatp hi-val) (= hi-val 0.0)
(float-sign hi-val))))
:high (list (float 0.0 hi-val)))))))
(t
type)))
- ;; Not real float.
+ ;; not real float
type))
;;; Convert back a possible list of numeric types.
(funcall fcn x y))))
(cond ((null result))
((and (floatp result) (float-nan-p result))
- (make-numeric-type
- :class 'float
- :format (type-of result)
- :complexp :real))
+ (make-numeric-type :class 'float
+ :format (type-of result)
+ :complexp :real))
(t
(make-member-type :members (list result))))))
((and (member-type-p x) (numeric-type-p y))
) ; PROGN
\f
-#!-propagate-float-type
+#!-sb-propagate-float-type
(progn
(defoptimizer (+ derive-type) ((x y))
(derive-integer-type
) ; PROGN
-#!+propagate-float-type
+#!+sb-propagate-float-type
(progn
(defun +-derive-type-aux (x y same-arg)
(if (and (numeric-type-real-p x)
(make-numeric-type
:class (if (and (eq (numeric-type-class x) 'integer)
(eq (numeric-type-class y) 'integer))
- ;; The sum of integers is always an integer
+ ;; The sum of integers is always an integer.
'integer
(numeric-type-class result-type))
:format (numeric-type-format result-type)
:low (interval-low result)
:high (interval-high result)))
- ;; General contagion
+ ;; general contagion
(numeric-contagion x y)))
(defoptimizer (+ derive-type) ((x y))
(if (and (numeric-type-real-p x)
(numeric-type-real-p y))
(let ((result
- ;; (* x x) is always positive, so take care to do it
- ;; right.
+ ;; (* X X) is always positive, so take care to do it right.
(if same-arg
(interval-sqr (numeric-type->interval x))
(interval-mul (numeric-type->interval x)
;;; and it's hard to avoid that calculation in here.
#-(and cmu sb-xc-host)
(progn
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
;; Large resulting bounds are easy to generate but are not
;; particularly useful, so an open outer bound is returned for a
:complexp :real)))))))))
*universal-type*))
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(defun ash-derive-type-aux (n-type shift same-arg)
(declare (ignore same-arg))
(flet ((ash-outer (n s)
(ash-outer n-high s-high))))))
*universal-type*)))
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(defoptimizer (ash derive-type) ((n shift))
(two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
) ; PROGN
-#!-propagate-float-type
+#!-sb-propagate-float-type
(macrolet ((frob (fun)
`#'(lambda (type type2)
(declare (ignore type2))
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int (frob lognot))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defoptimizer (lognot derive-type) ((int))
(derive-integer-type int int
(lambda (type type2)
(numeric-type-class type)
(numeric-type-format type))))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defoptimizer (%negate derive-type) ((num))
(flet ((negate-bound (b)
- (set-bound (- (bound-value b)) (consp b))))
+ (and b
+ (set-bound (- (type-bound-number b))
+ (consp b)))))
(one-arg-derive-type num
(lambda (type)
- (let ((lo (numeric-type-low type))
- (hi (numeric-type-high type))
- (result (copy-numeric-type type)))
- (setf (numeric-type-low result)
- (if hi (negate-bound hi) nil))
- (setf (numeric-type-high result)
- (if lo (negate-bound lo) nil))
- result))
+ (modified-numeric-type
+ type
+ :low (negate-bound (numeric-type-high type))
+ :high (negate-bound (numeric-type-low type))))
#'-)))
-#!-propagate-float-type
+#!-sb-propagate-float-type
(defoptimizer (abs derive-type) ((num))
(let ((type (continuation-type num)))
(if (and (numeric-type-p type)
nil)))
(numeric-contagion type type))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defun abs-derive-type-aux (type)
(cond ((eq (numeric-type-complexp type) :complex)
;; The absolute value of a complex number is always a
:high (coerce-numeric-bound
(interval-high abs-bnd) bound-type))))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defoptimizer (abs derive-type) ((num))
(one-arg-derive-type num #'abs-derive-type-aux #'abs))
-#!-propagate-float-type
+#!-sb-propagate-float-type
(defoptimizer (truncate derive-type) ((number divisor))
(let ((number-type (continuation-type number))
(divisor-type (continuation-type divisor))
divisor-low divisor-high))))
*universal-type*)))
-#-sb-xc-host ;(CROSS-FLOAT-INFINITY-KLUDGE, see base-target-features.lisp-expr)
-(progn
-#!+propagate-float-type
+#!+sb-propagate-float-type
(progn
(defun rem-result-type (number-type divisor-type)
(let ((q-aux (symbolicate q-name "-AUX"))
(r-aux (symbolicate r-name "-AUX")))
`(progn
- ;; Compute type of quotient (first) result
+ ;; Compute type of quotient (first) result.
(defun ,q-aux (number-type divisor-type)
(let* ((number-interval
(numeric-type->interval number-type))
divisor-interval))))
(specifier-type `(integer ,(or (interval-low quot) '*)
,(or (interval-high quot) '*)))))
- ;; Compute type of remainder
+ ;; Compute type of remainder.
(defun ,r-aux (number-type divisor-type)
(let* ((divisor-interval
(numeric-type->interval divisor-type))
(values nil nil)))
(when (member result-type '(float single-float double-float
#!+long-float long-float))
- ;; Make sure the limits on the interval have
+ ;; Make sure that the limits on the interval have
;; the right type.
- (setf rem (interval-func #'(lambda (x)
- (coerce x result-type))
+ (setf rem (interval-func (lambda (x)
+ (coerce x result-type))
rem)))
(make-numeric-type :class class
:format format
:low (interval-low rem)
:high (interval-high rem)))))
- ;; The optimizer itself
+ ;; the optimizer itself
(defoptimizer (,name derive-type) ((number divisor))
(flet ((derive-q (n d same-arg)
(declare (ignore same-arg))
(rem (two-arg-derive-type
number divisor #'derive-r #'mod)))
(when (and quot rem)
- (make-values-type :required (list quot rem))))))
- ))))
+ (make-values-type :required (list quot rem))))))))))
;; FIXME: DEF-FROB-OPT, not just FROB-OPT
(frob-opt floor floor-quotient-bound floor-rem-bound)
(let ((q-aux (symbolicate "F" q-name "-AUX"))
(r-aux (symbolicate r-name "-AUX")))
`(progn
- ;; Compute type of quotient (first) result
+ ;; Compute type of quotient (first) result.
(defun ,q-aux (number-type divisor-type)
(let* ((number-interval
(numeric-type->interval number-type))
;; Take the floor of the lower bound. The result is always a
;; closed lower bound.
(setf lo (if lo
- (floor (bound-value lo))
+ (floor (type-bound-number lo))
nil))
- ;; For the upper bound, we need to be careful
+ ;; For the upper bound, we need to be careful.
(setf hi
(cond ((consp hi)
;; An open bound. We need to be careful here because
;; correct sign for the remainder if we can.
(case (interval-range-info div)
(+
- ;; Divisor is always positive.
+ ;; The divisor is always positive.
(let ((rem (interval-abs div)))
(setf (interval-low rem) 0)
(when (and (numberp (interval-high rem))
(setf (interval-high rem) (list (interval-high rem))))
rem))
(-
- ;; Divisor is always negative
+ ;; The divisor is always negative.
(let ((rem (interval-neg (interval-abs div))))
(setf (interval-high rem) 0)
(when (numberp (interval-low rem))
(setf (interval-low rem) (list (interval-low rem))))
rem))
(otherwise
- ;; The divisor can be positive or negative. All bets off.
- ;; The magnitude of remainder is the maximum value of the
- ;; divisor.
- (let ((limit (bound-value (interval-high (interval-abs div)))))
- ;; The bound never reaches the limit, so make the interval open
+ ;; The divisor can be positive or negative. All bets off. The
+ ;; magnitude of remainder is the maximum value of the divisor.
+ (let ((limit (type-bound-number (interval-high (interval-abs div)))))
+ ;; The bound never reaches the limit, so make the interval open.
(make-interval :low (if limit
(list (- limit))
limit)
;; Take the ceiling of the upper bound. The result is always a
;; closed upper bound.
(setf hi (if hi
- (ceiling (bound-value hi))
+ (ceiling (type-bound-number hi))
nil))
- ;; For the lower bound, we need to be careful
+ ;; For the lower bound, we need to be careful.
(setf lo
(cond ((consp lo)
;; An open bound. We need to be careful here because
(defun ceiling-rem-bound (div)
;; The remainder depends only on the divisor. Try to get the
;; correct sign for the remainder if we can.
-
(case (interval-range-info div)
(+
;; Divisor is always positive. The remainder is negative.
(setf (interval-high rem) (list (interval-high rem))))
rem))
(otherwise
- ;; The divisor can be positive or negative. All bets off.
- ;; The magnitude of remainder is the maximum value of the
- ;; divisor.
- (let ((limit (bound-value (interval-high (interval-abs div)))))
- ;; The bound never reaches the limit, so make the interval open
+ ;; The divisor can be positive or negative. All bets off. The
+ ;; magnitude of remainder is the maximum value of the divisor.
+ (let ((limit (type-bound-number (interval-high (interval-abs div)))))
+ ;; The bound never reaches the limit, so make the interval open.
(make-interval :low (if limit
(list (- limit))
limit)
;; it's the union of the two pieces.
(case (interval-range-info quot)
(+
- ;; Just like floor
+ ;; just like FLOOR
(floor-quotient-bound quot))
(-
- ;; Just like ceiling
+ ;; just like CEILING
(ceiling-quotient-bound quot))
(otherwise
;; Split the interval into positive and negative pieces, compute
(floor-quotient-bound pos))))))
(defun truncate-rem-bound (num div)
- ;; This is significantly more complicated than floor or ceiling. We
+ ;; This is significantly more complicated than FLOOR or CEILING. We
;; need both the number and the divisor to determine the range. The
- ;; basic idea is to split the ranges of num and den into positive
+ ;; basic idea is to split the ranges of NUM and DEN into positive
;; and negative pieces and deal with each of the four possibilities
;; in turn.
(case (interval-range-info num)
(destructuring-bind (neg pos) (interval-split 0 num t t)
(interval-merge-pair (truncate-rem-bound neg div)
(truncate-rem-bound pos div))))))
-)) ; end PROGN's
+) ; PROGN
;;; Derive useful information about the range. Returns three values:
;;; - '+ if its positive, '- negative, or nil if it overlaps 0.
(defun integer-truncate-derive-type
(number-low number-high divisor-low divisor-high)
- ;; The result cannot be larger in magnitude than the number, but the sign
- ;; might change. If we can determine the sign of either the number or
- ;; the divisor, we can eliminate some of the cases.
+ ;; The result cannot be larger in magnitude than the number, but the
+ ;; sign might change. If we can determine the sign of either the
+ ;; number or the divisor, we can eliminate some of the cases.
(multiple-value-bind (number-sign number-min number-max)
(numeric-range-info number-low number-high)
(multiple-value-bind (divisor-sign divisor-min divisor-max)
;; anything about the result.
`integer)))))
-#!-propagate-float-type
+#!-sb-propagate-float-type
(defun integer-rem-derive-type
(number-low number-high divisor-low divisor-high)
(if (and divisor-low divisor-high)
- ;; We know the range of the divisor, and the remainder must be smaller
- ;; than the divisor. We can tell the sign of the remainer if we know
- ;; the sign of the number.
+ ;; We know the range of the divisor, and the remainder must be
+ ;; smaller than the divisor. We can tell the sign of the
+ ;; remainer if we know the sign of the number.
(let ((divisor-max (1- (max (abs divisor-low) (abs divisor-high)))))
`(integer ,(if (or (null number-low)
(minusp number-low))
(plusp number-high))
divisor-max
0)))
- ;; The divisor is potentially either very positive or very negative.
- ;; Therefore, the remainer is unbounded, but we might be able to tell
- ;; something about the sign from the number.
+ ;; The divisor is potentially either very positive or very
+ ;; negative. Therefore, the remainer is unbounded, but we might
+ ;; be able to tell something about the sign from the number.
`(integer ,(if (and number-low (not (minusp number-low)))
- ;; The number we are dividing is positive. Therefore,
- ;; the remainder must be positive.
+ ;; The number we are dividing is positive.
+ ;; Therefore, the remainder must be positive.
0
'*)
,(if (and number-high (not (plusp number-high)))
- ;; The number we are dividing is negative. Therefore,
- ;; the remainder must be negative.
+ ;; The number we are dividing is negative.
+ ;; Therefore, the remainder must be negative.
0
'*))))
-#!-propagate-float-type
+#!-sb-propagate-float-type
(defoptimizer (random derive-type) ((bound &optional state))
(let ((type (continuation-type bound)))
(when (numeric-type-p type)
((or (consp high) (zerop high)) high)
(t `(,high))))))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defun random-derive-type-aux (type)
(let ((class (numeric-type-class type))
(high (numeric-type-high type))
((or (consp high) (zerop high)) high)
(t `(,high))))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defoptimizer (random derive-type) ((bound &optional state))
(one-arg-derive-type bound #'random-derive-type-aux nil))
\f
;;;; logical derive-type methods
-;;; Return the maximum number of bits an integer of the supplied type can take
-;;; up, or NIL if it is unbounded. The second (third) value is T if the
-;;; integer can be positive (negative) and NIL if not. Zero counts as
-;;; positive.
+;;; Return the maximum number of bits an integer of the supplied type
+;;; can take up, or NIL if it is unbounded. The second (third) value
+;;; is T if the integer can be positive (negative) and NIL if not.
+;;; Zero counts as positive.
(defun integer-type-length (type)
(if (numeric-type-p type)
(let ((min (numeric-type-low type))
(or (null min) (minusp min))))
(values nil t t)))
-#!-propagate-fun-type
+#!-sb-propagate-fun-type
(progn
+
(defoptimizer (logand derive-type) ((x y))
(multiple-value-bind (x-len x-pos x-neg)
(integer-type-length (continuation-type x))
(cond
((or (and (not x-neg) (not y-neg))
(and (not x-pos) (not y-pos)))
- ;; Either both are negative or both are positive. The result will be
- ;; positive, and as long as the longer.
+ ;; Either both are negative or both are positive. The result
+ ;; will be positive, and as long as the longer.
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
(max x-len y-len)
'*))))
((or (and (not x-pos) (not y-neg))
(and (not y-neg) (not y-pos)))
- ;; Either X is negative and Y is positive of vice-verca. The result
- ;; will be negative.
+ ;; Either X is negative and Y is positive of vice-versa. The
+ ;; result will be negative.
(specifier-type `(integer ,(if (and x-len y-len)
(ash -1 (max x-len y-len))
'*)
-1)))
- ;; We can't tell what the sign of the result is going to be. All we
- ;; know is that we don't create new bits.
+ ;; We can't tell what the sign of the result is going to be.
+ ;; All we know is that we don't create new bits.
((and x-len y-len)
(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
(t
) ; PROGN
-#!+propagate-fun-type
+#!+sb-propagate-fun-type
(progn
+
(defun logand-derive-type-aux (x y &optional same-leaf)
(declare (ignore same-leaf))
(multiple-value-bind (x-len x-pos x-neg) (integer-type-length x)
(if (not x-neg)
;; X must be positive.
(if (not y-neg)
- ;; The must both be positive.
+ ;; They must both be positive.
(cond ((or (null x-len) (null y-len))
(specifier-type 'unsigned-byte))
((or (zerop x-len) (zerop y-len))
((not x-pos)
;; X must be negative.
(if (not y-pos)
- ;; Both are negative. The result is going to be negative and be
- ;; the same length or shorter than the smaller.
+ ;; Both are negative. The result is going to be negative
+ ;; and be the same length or shorter than the smaller.
(if (and x-len y-len)
;; It's bounded.
(specifier-type `(integer ,(ash -1 (min x-len y-len)) -1))
;; It's unbounded.
(specifier-type '(integer * -1)))
- ;; X is negative, but we don't know about Y. The result will be
- ;; negative, but no more negative than X.
+ ;; X is negative, but we don't know about Y. The result
+ ;; will be negative, but no more negative than X.
(specifier-type
`(integer ,(or (numeric-type-low x) '*)
-1))))
(cond
((or (and (not x-neg) (not y-neg))
(and (not x-pos) (not y-pos)))
- ;; Either both are negative or both are positive. The result will be
- ;; positive, and as long as the longer.
+ ;; Either both are negative or both are positive. The result
+ ;; will be positive, and as long as the longer.
(if (and x-len y-len (zerop x-len) (zerop y-len))
(specifier-type '(integer 0 0))
(specifier-type `(unsigned-byte ,(if (and x-len y-len)
'*)))))
((or (and (not x-pos) (not y-neg))
(and (not y-neg) (not y-pos)))
- ;; Either X is negative and Y is positive of vice-verca. The result
- ;; will be negative.
+ ;; Either X is negative and Y is positive of vice-verca. The
+ ;; result will be negative.
(specifier-type `(integer ,(if (and x-len y-len)
(ash -1 (max x-len y-len))
'*)
-1)))
- ;; We can't tell what the sign of the result is going to be. All we
- ;; know is that we don't create new bits.
+ ;; We can't tell what the sign of the result is going to be.
+ ;; All we know is that we don't create new bits.
((and x-len y-len)
(specifier-type `(signed-byte ,(1+ (max x-len y-len)))))
(t
\f
;;;; byte operations
;;;;
-;;;; We try to turn byte operations into simple logical operations. First, we
-;;;; convert byte specifiers into separate size and position arguments passed
-;;;; to internal %FOO functions. We then attempt to transform the %FOO
-;;;; functions into boolean operations when the size and position are constant
-;;;; and the operands are fixnums.
-
-(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to expressions that
- ;; evaluate to the SIZE and POSITION of the byte-specifier form
- ;; SPEC. We may wrap a let around the result of the body to bind
- ;; some variables.
+;;;; We try to turn byte operations into simple logical operations.
+;;;; First, we convert byte specifiers into separate size and position
+;;;; arguments passed to internal %FOO functions. We then attempt to
+;;;; transform the %FOO functions into boolean operations when the
+;;;; size and position are constant and the operands are fixnums.
+
+(macrolet (;; Evaluate body with SIZE-VAR and POS-VAR bound to
+ ;; expressions that evaluate to the SIZE and POSITION of
+ ;; the byte-specifier form SPEC. We may wrap a let around
+ ;; the result of the body to bind some variables.
;;
- ;; If the spec is a BYTE form, then bind the vars to the subforms.
- ;; otherwise, evaluate SPEC and use the BYTE-SIZE and BYTE-POSITION.
- ;; The goal of this transformation is to avoid consing up byte
- ;; specifiers and then immediately throwing them away.
+ ;; If the spec is a BYTE form, then bind the vars to the
+ ;; subforms. otherwise, evaluate SPEC and use the BYTE-SIZE
+ ;; and BYTE-POSITION. The goal of this transformation is to
+ ;; avoid consing up byte specifiers and then immediately
+ ;; throwing them away.
(with-byte-specifier ((size-var pos-var spec) &body body)
(once-only ((spec `(macroexpand ,spec))
(temp '(gensym)))
;;; Note: for %DPB and %DEPOSIT-FIELD, we can't use
;;; (OR (SIGNED-BYTE N) (UNSIGNED-BYTE N))
-;;; as the result type, as that would allow result types
-;;; that cover the range -2^(n-1) .. 1-2^n, instead of allowing result types
-;;; of (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
+;;; as the result type, as that would allow result types that cover
+;;; the range -2^(n-1) .. 1-2^n, instead of allowing result types of
+;;; (UNSIGNED-BYTE N) and result types of (SIGNED-BYTE N).
(deftransform %dpb ((new size posn int)
*
`(- (ash x ,len))
`(ash x ,len))))
-;;; If both arguments and the result are (unsigned-byte 32), try to come up
-;;; with a ``better'' multiplication using multiplier recoding. There are two
-;;; different ways the multiplier can be recoded. The more obvious is to shift
-;;; X by the correct amount for each bit set in Y and to sum the results. But
-;;; if there is a string of bits that are all set, you can add X shifted by
-;;; one more then the bit position of the first set bit and subtract X shifted
-;;; by the bit position of the last set bit. We can't use this second method
-;;; when the high order bit is bit 31 because shifting by 32 doesn't work
-;;; too well.
+;;; If both arguments and the result are (UNSIGNED-BYTE 32), try to
+;;; come up with a ``better'' multiplication using multiplier
+;;; recoding. There are two different ways the multiplier can be
+;;; recoded. The more obvious is to shift X by the correct amount for
+;;; each bit set in Y and to sum the results. But if there is a string
+;;; of bits that are all set, you can add X shifted by one more then
+;;; the bit position of the first set bit and subtract X shifted by
+;;; the bit position of the last set bit. We can't use this second
+;;; method when the high order bit is bit 31 because shifting by 32
+;;; doesn't work too well.
(deftransform * ((x y)
((unsigned-byte 32) (unsigned-byte 32))
(unsigned-byte 32))
(add '(ash x 31))))
(or result 0)))
-;;; If arg is a constant power of two, turn FLOOR into a shift and mask.
-;;; If CEILING, add in (1- (ABS Y)) and then do FLOOR.
+;;; If arg is a constant power of two, turn FLOOR into a shift and
+;;; mask. If CEILING, add in (1- (ABS Y)) and then do FLOOR.
(flet ((frob (y ceil-p)
(unless (constant-continuation-p y)
(give-up-ir1-transform))
\f
;;;; arithmetic and logical identity operation elimination
;;;;
-;;;; Flush calls to various arith functions that convert to the identity
-;;;; function or a constant.
+;;;; Flush calls to various arith functions that convert to the
+;;;; identity function or a constant.
(dolist (stuff '((ash 0 x)
(logand -1 x)
"convert (* x 0) to 0."
0)
-;;; Return T if in an arithmetic op including continuations X and Y, the
-;;; result type is not affected by the type of X. That is, Y is at least as
-;;; contagious as X.
+;;; Return T if in an arithmetic op including continuations X and Y,
+;;; the result type is not affected by the type of X. That is, Y is at
+;;; least as contagious as X.
#+nil
(defun not-more-contagious (x y)
(declare (type continuation x y))
(values (type= (numeric-contagion x y)
(numeric-contagion y y)))))
;;; Patched version by Raymond Toy. dtc: Should be safer although it
-;;; needs more work as valid transforms are missed; some cases are
+;;; XXX needs more work as valid transforms are missed; some cases are
;;; specific to particular transform functions so the use of this
;;; function may need a re-think.
(defun not-more-contagious (x y)
;;; Fold (+ x 0).
;;;
-;;; If y is not constant, not zerop, or is contagious, or a
-;;; positive float +0.0 then give up.
+;;; If y is not constant, not zerop, or is contagious, or a positive
+;;; float +0.0 then give up.
(deftransform + ((x y) (t (constant-argument t)) * :when :both)
"fold zero arg"
(let ((val (continuation-value y)))
;;; Fold (- x 0).
;;;
-;;; If y is not constant, not zerop, or is contagious, or a
-;;; negative float -0.0 then give up.
+;;; If y is not constant, not zerop, or is contagious, or a negative
+;;; float -0.0 then give up.
(deftransform - ((x y) (t (constant-argument t)) * :when :both)
"fold zero arg"
(let ((val (continuation-value y)))
\f
;;;; equality predicate transforms
-;;; Return true if X and Y are continuations whose only use is a reference
-;;; to the same leaf, and the value of the leaf cannot change.
+;;; Return true if X and Y are continuations whose only use is a
+;;; reference to the same leaf, and the value of the leaf cannot
+;;; change.
(defun same-leaf-ref-p (x y)
(declare (type continuation x y))
(let ((x-use (continuation-use x))
(eq (ref-leaf x-use) (ref-leaf y-use))
(constant-reference-p x-use))))
-;;; If X and Y are the same leaf, then the result is true. Otherwise, if
-;;; there is no intersection between the types of the arguments, then the
-;;; result is definitely false.
+;;; If X and Y are the same leaf, then the result is true. Otherwise,
+;;; if there is no intersection between the types of the arguments,
+;;; then the result is definitely false.
(deftransform simple-equality-transform ((x y) * *
:defun-only t
:when :both)
(give-up-ir1-transform))
((or (and (csubtypep x-type (specifier-type 'rational))
(csubtypep y-type (specifier-type 'rational)))
- (and (csubtypep x-type (specifier-type '(complex rational)))
- (csubtypep y-type (specifier-type '(complex rational)))))
- ;; They are both rationals and complexp is the same. Convert
- ;; to EQL.
+ (and (csubtypep x-type
+ (specifier-type '(complex rational)))
+ (csubtypep y-type
+ (specifier-type '(complex rational)))))
+ ;; They are both rationals and complexp is the same.
+ ;; Convert to EQL.
'(eql x y))
(t
(give-up-ir1-transform
(give-up-ir1-transform
"The operands might not be the same type."))))
-;;; If Cont's type is a numeric type, then return the type, otherwise
+;;; If CONT's type is a numeric type, then return the type, otherwise
;;; GIVE-UP-IR1-TRANSFORM.
(defun numeric-type-or-lose (cont)
(declare (type continuation cont))
(unless (numeric-type-p res) (give-up-ir1-transform))
res))
-;;; See whether we can statically determine (< X Y) using type information.
-;;; If X's high bound is < Y's low, then X < Y. Similarly, if X's low is >=
-;;; to Y's high, the X >= Y (so return NIL). If not, at least make sure any
-;;; constant arg is second.
+;;; See whether we can statically determine (< X Y) using type
+;;; information. If X's high bound is < Y's low, then X < Y.
+;;; Similarly, if X's low is >= to Y's high, the X >= Y (so return
+;;; NIL). If not, at least make sure any constant arg is second.
;;;
-;;; KLUDGE: Why should constant argument be second? It would be nice to find
-;;; out and explain. -- WHN 19990917
-#!-propagate-float-type
+;;; FIXME: Why should constant argument be second? It would be nice to
+;;; find out and explain.
+#!-sb-propagate-float-type
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
'nil
(y-lo (numeric-type-low y-type))
(y-hi (numeric-type-high y-type)))
(cond ((and x-hi y-lo (< x-hi y-lo))
- 't)
+ t)
((and y-hi x-lo (>= x-lo y-hi))
- 'nil)
+ nil)
((and (constant-continuation-p first)
(not (constant-continuation-p second)))
`(,inverse y x))
(t
(give-up-ir1-transform))))))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(defun ir1-transform-< (x y first second inverse)
(if (same-leaf-ref-p x y)
'nil
(let ((xi (numeric-type->interval (numeric-type-or-lose x)))
(yi (numeric-type->interval (numeric-type-or-lose y))))
(cond ((interval-< xi yi)
- 't)
+ t)
((interval->= xi yi)
- 'nil)
+ nil)
((and (constant-continuation-p first)
(not (constant-continuation-p second)))
`(,inverse y x))
(deftransform > ((x y) (integer integer) * :when :both)
(ir1-transform-< y x x y '<))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(deftransform < ((x y) (float float) * :when :both)
(ir1-transform-< x y x y '>))
-#!+propagate-float-type
+#!+sb-propagate-float-type
(deftransform > ((x y) (float float) * :when :both)
(ir1-transform-< y x x y '<))
\f
(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
-(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
-(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
+(def-source-transform char-equal (&rest args)
+ (multi-compare 'char-equal args nil))
+(def-source-transform char-lessp (&rest args)
+ (multi-compare 'char-lessp args nil))
(def-source-transform char-greaterp (&rest args)
(multi-compare 'char-greaterp args nil))
(def-source-transform char-not-greaterp (&rest args)
(multi-compare 'char-greaterp args t))
-(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
+(def-source-transform char-not-lessp (&rest args)
+ (multi-compare 'char-lessp args t))
;;; This function does source transformation of N-arg inequality
;;; functions such as /=. This is similar to Multi-Compare in the <3
(def-source-transform /= (&rest args) (multi-not-equal '= args))
(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
-(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
+(def-source-transform char-not-equal (&rest args)
+ (multi-not-equal 'char-equal args))
;;; Expand MAX and MIN into the obvious comparisons.
(def-source-transform max (arg &rest more-args)
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))
+\f
+;;;; debuggers' little helpers
+
+;;; for debugging when transforms are behaving mysteriously,
+;;; e.g. when debugging a problem with an ASH transform
+;;; (defun foo (&optional s)
+;;; (sb-c::/report-continuation s "S outside WHEN")
+;;; (when (and (integerp s) (> s 3))
+;;; (sb-c::/report-continuation s "S inside WHEN")
+;;; (let ((bound (ash 1 (1- s))))
+;;; (sb-c::/report-continuation bound "BOUND")
+;;; (let ((x (- bound))
+;;; (y (1- bound)))
+;;; (sb-c::/report-continuation x "X")
+;;; (sb-c::/report-continuation x "Y"))
+;;; `(integer ,(- bound) ,(1- bound)))))
+;;; (The DEFTRANSFORM doesn't do anything but report at compile time,
+;;; and the function doesn't do anything at all.)
+#!+sb-show
+(progn
+ (defknown /report-continuation (t t) null)
+ (deftransform /report-continuation ((x message) (t t))
+ (format t "~%/in /REPORT-CONTINUATION~%")
+ (format t "/(CONTINUATION-TYPE X)=~S~%" (continuation-type x))
+ (when (constant-continuation-p x)
+ (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x)))
+ (format t "/MESSAGE=~S~%" (continuation-value message))
+ (give-up-ir1-transform "not a real transform"))
+ (defun /report-continuation (&rest rest)
+ (declare (ignore rest))))
return (ptrans_boxed(thing, header, 0));
case 0:
{
- /* Substructure: special case for the compact-info-envs, where
+ /* Substructure: special case for the COMPACT-INFO-ENVs, where
* the instance may have a point to the dynamic space placed
* into it (e.g. the cache-name slot), but the lists and arrays
* at the time of a purify can be moved to the RO space. */
("code/float" :not-host)
("code/irrat" :not-host)
- ("code/char" :not-host)
+ ("code/char")
+ ("code/target-char" :not-host)
("code/target-misc" :not-host)
("code/misc")
;;; 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.25"
+"0.6.11.26"
projects / sbcl.git / commitdiff