common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

0.6.11.26:

Browse source 
restored CMU CL's :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE
		functionality
	changed design of CROSS-FLOAT-INFINITY-KLUDGE
	renamed :PROPAGATE-FLOAT-TYPE and :PROPAGATE-FUN-TYPE
		features to :SB-PROPAGATE-FLOAT-TYPE and
		:SB-PROPAGATE-FUN-TYPE
	renamed :CONSTRAIN-FLOAT-TYPE to :SB-CONSTRAIN-FLOAT-TYPE too
	clarified TYPE-ERROR :TYPE in DEFUN SANE-PACKAGE
	tweaked DEFCONSTANT handling so that CMU CL can handle the
		DEFCONSTANT/DEFTYPE interaction in bit-bash.lisp
	created SB-XC versions of various CL constants (e.g.
		LEAST-POSITIVE-SINGLE-FLOAT) so that cross-compilation
		of their DEFCONSTANT forms works more cleanly
	reviewed uses of various CL constants and added SB!XC:
		prefixes in compiled-on-host code: CALL-ARGUMENTS-LIMIT,
		CHAR-CODE-LIMIT
	split char.lisp into char.lisp and target-char.lisp so that
		there'd be a suitable place to define CHAR-CODE-LIMIT
	rewrote SOURCE-TRANSFORM-CXR stuff to avoid FORMAT call at
		cold init time
	suppressed bogus default DEFSTRUCT-generated COPY-READTABLE
	hunting PROPAGATE-FOO-TYPE bug in compilation of OUTPUT-GSPACE..
	..made MAKE-NUMERIC-TYPE enforce closed-bound invariant for
		NUMERIC-TYPE-CLASS='INTEGER
	..made MODIFIED-NUMERIC-TYPE to enforce NUMERIC-TYPE-CLASS
		invariants; made slots read-only; rewrote
		modify-NUMERIC-TYPE code to use MODIFIED-NUMERIC-TYPE
	..moved FLET VALIDATE logic from CONSTRAIN-INTEGER-TYPE
		and CONSTRAIN-FLOAT-TYPE to MAKE-NUMERIC-TYPE.
	..Now COPY-NUMERIC-TYPE can go away.
	..renamed BOUND-VALUE to SB!INT:TYPE-BOUND-NUMBER
	factored out CTYPE-OF-NUMBER code
	cross-type.lisp is type system code, so do it in SB!KERNEL.
This commit is contained in:
William Harold Newman 2001-03-26 20:55:55 +00:00
parent ce62508ec1
commit 334af30b26
36 changed files with 1208 additions and 1017 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
BUGS
View file

@ -833,7 +833,7 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
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.)
@ -845,6 +845,24 @@ Error in function C::GET-LAMBDA-TO-COMPILE:
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

2
CREDITS
View file

@ -453,7 +453,7 @@ checking on various tricky cases of standard functions (e.g. MAP with
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.

2
NEWS
View file

@ -690,7 +690,7 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11:
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

67
base-target-features.lisp-expr
View file

@ -78,6 +78,31 @@
;; 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.
@ -148,41 +173,18 @@
; :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
@ -235,9 +237,6 @@
;; 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):
;;

16
make-host-2.sh
View file

@ -64,22 +64,6 @@ $SBCL_XC_HOST <<-'EOF' || exit 1
(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

43
package-data-list.lisp-expr
View file

@ -57,7 +57,7 @@
"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"
@ -99,7 +99,7 @@
"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
@ -160,7 +160,7 @@
"*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"
@ -307,7 +307,7 @@
: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"))
@ -343,7 +343,7 @@ debugger interface mixed with various low-level implementation stuff
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*"
@ -516,7 +516,7 @@ like *STACK-TOP-HINT*"
;; 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
@ -539,10 +539,10 @@ like *STACK-TOP-HINT*"
;; 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
@ -677,13 +677,14 @@ retained, possibly temporariliy, because it might be used internally."
;; 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"
@ -807,7 +808,7 @@ retained, possibly temporariliy, because it might be used internally."
"+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"
@ -859,7 +860,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
"%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"
@ -939,8 +940,8 @@ is a good idea, but see SB-SYS for blurring of boundaries."
"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"
@ -1009,7 +1010,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
"%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"
@ -1221,7 +1222,7 @@ is a good idea, but see SB-SYS for blurring of boundaries."
"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"
@ -1230,9 +1231,9 @@ is a good idea, but see SB-SYS for blurring of boundaries."
"!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*"
@ -1475,7 +1476,7 @@ no guarantees of interface stability."
"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"

45
src/code/bit-bash.lisp
View file

@ -198,18 +198,18 @@
(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)
@ -221,17 +221,18 @@
(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
@ -244,10 +245,10 @@
(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)))))
@ -259,8 +260,8 @@
(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))
@ -270,8 +271,8 @@
((<= 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)))

380
src/code/char.lisp
View file

@ -1,13 +1,5 @@
;;;; 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.
@ -20,372 +12,6 @@
(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")))))
;;;; 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)))
;;;; 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))))
;;;; 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)))))

2
src/code/cold-init.lisp
View file

@ -42,7 +42,7 @@
;;; 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)

23
src/code/cross-type.lisp
View file

@ -9,7 +9,7 @@
;;;; 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)
@ -306,7 +306,7 @@
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)
@ -334,24 +334,7 @@
(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)

14
src/code/defbangstruct.lisp
View file

@ -4,7 +4,10 @@
;;;; 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.
@ -271,14 +274,17 @@
(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)))
;;;; 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))

4
src/code/defstruct.lisp
View file

@ -165,8 +165,8 @@
;;;; 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

2
src/code/deftypes-for-target.lisp
View file

@ -131,7 +131,7 @@
'(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 * (*))))

13
src/code/early-extensions.lisp
View file

@ -391,6 +391,19 @@
(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))
;;;; utilities for two-VALUES predicates

92
src/code/early-type.lisp
View file

@ -14,13 +14,6 @@
;;; 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))
;;; Return the type structure corresponding to a type specifier. We
;;; pick off structure types as a special case.
@ -184,8 +177,8 @@
;;; 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)
;;
@ -195,23 +188,92 @@
;; 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.

2
src/code/filesys.lisp
View file

@ -985,7 +985,7 @@
(/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)))

46
src/code/late-type.lisp
View file

@ -1017,28 +1017,6 @@
;;;; 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)
@ -1313,9 +1291,7 @@
(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.
@ -2157,6 +2133,26 @@
:element-type (specifier-type element-type)
:complexp nil)))
;;;; 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))))
(!defun-from-collected-cold-init-forms !late-type-cold-init)
(/show0 "late-type.lisp end of file")

61
src/code/macros.lisp
View file

@ -103,7 +103,7 @@
;;; 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
@ -128,7 +128,64 @@
(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)

11
src/code/primordial-extensions.lisp
View file

@ -108,8 +108,6 @@
(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
@ -160,10 +158,13 @@
;; 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.

3
src/code/print.lisp
View file

@ -612,7 +612,8 @@
;;; 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*))

14
src/code/readtable.lisp
View file

@ -12,7 +12,7 @@
(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.
@ -31,7 +31,11 @@
(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."
@ -47,7 +51,7 @@
;; 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)
@ -58,8 +62,8 @@
;; 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)

389
src/code/target-char.lisp Normal file
View file

@ -0,0 +1,389 @@
;;;; 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")))))
;;;; 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)))
;;;; 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))))
;;;; 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)))))

22
src/code/target-eval.lisp
View file

@ -7,28 +7,6 @@
;;;; 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.")
;;; 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

82
src/code/target-numbers.lisp
View file

@ -15,10 +15,10 @@
(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."))
@ -60,8 +60,8 @@
(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))
@ -78,21 +78,21 @@
) ; 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)))
@ -165,8 +165,8 @@
;;;; 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)
@ -185,9 +185,9 @@
(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)
@ -460,10 +460,10 @@
(* (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)
@ -601,22 +601,22 @@
(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)
@ -625,13 +625,13 @@
(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)

53
src/code/target-type.lisp
View file

@ -57,28 +57,12 @@
(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
@ -128,9 +112,9 @@
;; 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)))))
@ -186,24 +170,7 @@
(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)

67
src/cold/defun-load-or-cload-xcompiler.lisp
View file

@ -22,9 +22,72 @@
;; 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"

16
src/cold/shared.lisp
View file

@ -283,15 +283,21 @@
(error "found unexpected flag(s) in *STEMS-AND-FLAGS*: ~S"
set-difference)))))
;;;; 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
@ -317,8 +323,8 @@
(load (concatenate 'simple-string *host-obj-prefix* stem *host-obj-suffix*)))
(compile 'host-load-stem)
;;;; 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.

59
src/compiler/constraint.lisp
View file

@ -245,23 +245,16 @@
(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)
@ -273,12 +266,18 @@
;;; 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)
@ -293,8 +292,8 @@
(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
@ -302,19 +301,13 @@
(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)
@ -324,12 +317,10 @@
(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
@ -370,7 +361,7 @@
(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)))

21
src/compiler/ctype.lisp
View file

@ -195,13 +195,12 @@
(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)
@ -326,10 +325,10 @@
(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
@ -345,10 +344,10 @@
;; 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

124
src/compiler/float-tran.lisp
View file

@ -63,7 +63,7 @@
;; 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))
@ -178,12 +178,9 @@
'(%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)
@ -194,7 +191,7 @@
;; zeros.
(set-bound
(handler-case
(scale-float (bound-value x) n)
(scale-float (type-bound-number x) n)
(floating-point-overflow ()
nil))
(consp x))))
@ -225,7 +222,6 @@
;;; 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")))
@ -294,7 +290,7 @@
;;; 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))
@ -310,7 +306,7 @@
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)))
@ -470,7 +466,7 @@
(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.
@ -489,7 +485,7 @@
) ; PROGN
#!+propagate-fun-type
#!+sb-propagate-fun-type
(progn
;;;; optimizers for elementary functions
@ -507,7 +503,7 @@
(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)
@ -523,16 +519,16 @@
;;; 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)))
@ -603,7 +599,6 @@
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))))
@ -677,19 +672,19 @@
;; 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.
@ -708,18 +703,18 @@
;; 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
@ -758,7 +753,7 @@
;; 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
@ -766,7 +761,7 @@
(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
@ -775,10 +770,10 @@
(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)
@ -789,32 +784,30 @@
(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)
@ -825,20 +818,18 @@
(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
@ -846,7 +837,8 @@
: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)
@ -854,7 +846,7 @@
: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.
@ -921,7 +913,9 @@
(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)))
@ -1026,7 +1020,7 @@
: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)
@ -1050,7 +1044,7 @@
: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))
@ -1092,7 +1086,7 @@
: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)
@ -1175,7 +1169,7 @@
;;; 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))

8
src/compiler/fndb.lisp
View file

@ -249,12 +249,12 @@
(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))
@ -272,7 +272,7 @@
(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))
@ -289,7 +289,7 @@
: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))

18
src/compiler/main.lisp
View file

@ -1,4 +1,6 @@
;;;; 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.
@ -11,6 +13,20 @@
(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*

497
src/compiler/srctran.lisp
View file

File diff suppressed because it is too large Load diff

2
src/runtime/purify.c
View file

@ -575,7 +575,7 @@ static lispobj ptrans_instance(lispobj thing, lispobj header, boolean constant)
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. */

3
stems-and-flags.lisp-expr
View file

@ -213,7 +213,8 @@
("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")

2
version.lisp-expr
View file

@ -15,4 +15,4 @@
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
"0.6.11.25"
"0.6.11.26"