half a dozen bug fixes in pretty-printing and the debugger, and
half a dozen others elsewhere
* fixed bug 13: Floating point infinities are now supported again.
-* fixed bug 45a: Various internal functions required to support
- 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.)
+ They might still be a little bit flaky, but thanks to bug reports
+ from Nathan Froyd and CMU CL patches from Raymond Toy they're not
+ as flaky as they were.
* The --noprogrammer command line option is now supported. (Its
behavior is slightly different in detail from what the old man
page claimed it would do, but it's still appropriate under the
handle many floating point and complex operations much less
inefficiently. (Thus e.g. you can implement a complex FFT
without consing!)
-* improved support for type intersection and union, fixing bug 12
- (e.g., now (SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T) and some other
- more obscure bugs as well
+* The compiler now detects type mismatches between DECLAIM FTYPE
+ and DEFUN better, and implements CHECK-TYPE more correctly, and
+ SBCL builds under CMU CL again despite its non-ANSI EVAL-WHEN,
+ thanks to patches from Martin Atzmueller.
* various fixes to make the cross-compiler more portable to
ANSI-conforming-but-different cross-compilation hosts (notably
Lispworks for Windows, following bug reports from Arthur Lemmens)
-* a new workaround to make the cross-compiler portable to CMU CL
- again despite its non-ANSI EVAL-WHEN, thanks to Martin Atzmueller
-* The compiler now detects type mismatches between DECLAIM FTYPE
- and DEFUN better, thanks to patches from Martin Atzmueller.
-* A bug in READ-SEQUENCE for CONCATENATED-STREAM has been fixed
- thanks to Pierre Mai's CMU CL patch.
-* new fasl file format version number (because of changes in byte
- code opcodes and in internal representation of (OR ..) types)
+* A bug in READ-SEQUENCE for CONCATENATED-STREAM, and a gross
+ ANSI noncompliance in DEFMACRO &KEY argument parsing, have been
+ fixed thanks to Pierre Mai's CMU CL patches.
+* fixes to keep the system from overflowing internal counters when
+ it tries to use i/o buffers larger than 16M bytes
+* fixed bug 45a: Various internal functions required to support
+ 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.)
+* improved support for type intersection and union, fixing bug 12
+ (e.g., now (SUBTYPEP 'KEYWORD 'SYMBOL)=>T,T) and some other
+ more obscure bugs as well
+* Christophe Rhodes has made some debian packages of sbcl at
+ <http://www-jcsu.jesus.cam.ac.uk/ftp/pub/debian/lisp>.
+ From his sbcl-devel e-mail of 2001-04-08 they're not completely
+ stable, but are nonetheless usable. When he's ready, I'd be happy
+ to add them to the SourceForge "File Releases" section. (And if
+ anyone wants to do RPMs or *BSD packages, they'd be welcome too.)
+* new fasl file format version number (because of changes in
+ internal representation of (OR ..) types to accommodate the new
+ support for (AND ..) types, among other things)
planned incompatible changes in 0.7.x:
* The debugger prompt sequence now goes "5]", "5[2]", "5[3]", etc.
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*"
+ :export ("*AUTO-EVAL-IN-FRAME*" "*DEBUG-BEGINNER-HELP-P*"
+ "*DEBUG-CONDITION*"
"*DEBUG-PRINT-LENGTH*" "*DEBUG-PRINT-LEVEL*"
"*DEBUG-READTABLE*" "*DEBUG-HELP-STRING*"
"*FLUSH-DEBUG-ERRORS*" "*IN-THE-DEBUGGER*"
"ONCE-ONLY"
"DEFENUM"
"DEFPRINTER"
- "AVER"
+ "AVER" "AVER-TYPE" "ENFORCE-TYPE"
;; ..and DEFTYPEs..
"INDEX"
;;; old working version
(defun coerce (object output-type-spec)
#!+sb-doc
- "Coerces the Object to an object of type Output-Type-Spec."
+ "Coerce the Object to an object of type Output-Type-Spec."
(flet ((coerce-error ()
(/show0 "entering COERCE-ERROR")
(error 'simple-type-error
:format-control "~S can't be converted to type ~S."
:format-arguments (list object output-type-spec)))
(check-result (result)
- #!+high-security
- (check-type-var result output-type-spec)
+ #!+high-security (aver (typep result output-type-spec))
result))
(let ((type (specifier-type output-type-spec)))
(cond
:format-control "~S can't be converted to type ~S."
:format-arguments (list object output-type-spec)))
(check-result (result)
- #!+high-security
- (check-type-var result output-type-spec)
+ #!+high-security (aver (typep result output-type-spec))
result))
(let ((type (specifier-type output-type-spec)))
(cond
(sb!kernel:infinite-error-protect
(let ((condition (coerce-to-condition datum arguments
'simple-warning 'warn)))
- (check-type condition warning "a warning condition")
+ (enforce-type condition warning)
(restart-case (signal condition)
(muffle-warning ()
:report "Skip warning."
;;; lists of DEBUG-BLOCKs. Then look up our argument IR1-BLOCK to find
;;; its DEBUG-BLOCK since we know we have it now.
(defun make-interpreted-debug-block (ir1-block)
- (check-type ir1-block sb!c::cblock)
+ (declare (type sb!c::cblock ir1-block))
(let ((res (gethash ir1-block *ir1-block-debug-block*)))
(or res
(let ((lambda (sb!c::block-home-lambda ir1-block)))
invalid. This is SETF'able."
(etypecase debug-var
(compiled-debug-var
- (check-type frame compiled-frame)
+ (aver (typep frame 'compiled-frame))
(let ((res (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p res)
(sb!c:value-cell-ref res)
res)))
(interpreted-debug-var
- (check-type frame interpreted-frame)
+ (aver (typep frame 'interpreted-frame))
(sb!eval::leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-var-ir1-var debug-var)
(defun %set-debug-var-value (debug-var frame value)
(etypecase debug-var
(compiled-debug-var
- (check-type frame compiled-frame)
+ (aver (typep frame 'compiled-frame))
(let ((current-value (access-compiled-debug-var-slot debug-var frame)))
(if (indirect-value-cell-p current-value)
(sb!c:value-cell-set current-value value)
(set-compiled-debug-var-slot debug-var frame value))))
(interpreted-debug-var
- (check-type frame interpreted-frame)
+ (aver (typep frame 'interpreted-frame))
(sb!eval::set-leaf-value-lambda-var
(interpreted-code-location-ir1-node (frame-code-location frame))
(interpreted-debug-var-ir1-var debug-var)
(compiled-debug-var
(compiled-debug-var-validity debug-var basic-code-location))
(interpreted-debug-var
- (check-type basic-code-location interpreted-code-location)
+ (aver (typep basic-code-location 'interpreted-code-location))
(let ((validp (rassoc (interpreted-debug-var-ir1-var debug-var)
(sb!c::lexenv-variables
(sb!c::node-lexenv
;;; This is the method for DEBUG-VAR-VALIDITY for COMPILED-DEBUG-VARs.
;;; For safety, make sure basic-code-location is what we think.
(defun compiled-debug-var-validity (debug-var basic-code-location)
- (check-type basic-code-location compiled-code-location)
+ (declare (type compiled-code-location basic-code-location))
(cond ((debug-var-alive-p debug-var)
(let ((debug-fun (code-location-debug-function basic-code-location)))
(if (>= (compiled-code-location-pc basic-code-location)
(t
(let ((pos (position debug-var
(debug-function-debug-vars
- (code-location-debug-function basic-code-location)))))
+ (code-location-debug-function
+ basic-code-location)))))
(unless pos
(error 'unknown-debug-var
:debug-var debug-var
:debug-function
(code-location-debug-function basic-code-location)))
;; There must be live-set info since basic-code-location is known.
- (if (zerop (sbit (compiled-code-location-live-set basic-code-location)
+ (if (zerop (sbit (compiled-code-location-live-set
+ basic-code-location)
pos))
:invalid
:valid)))))
;;; Given the DEFUN, 3 gets you the LET, 1 gets you the bindings, 0
;;; gets the first binding, and 1 gets the AREF form.
-;;; Temporary buffer used to build form-number => source-path translation in
-;;; FORM-NUMBER-TRANSLATIONS.
+;;; temporary buffer used to build form-number => source-path translation in
+;;; FORM-NUMBER-TRANSLATIONS
(defvar *form-number-temp* (make-array 10 :fill-pointer 0 :adjustable t))
-;;; Table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS.
+;;; table used to detect CAR circularities in FORM-NUMBER-TRANSLATIONS
(defvar *form-number-circularity-table* (make-hash-table :test 'eq))
+;;; This returns a table mapping form numbers to source-paths. A source-path
+;;; indicates a descent into the top-level-form form, going directly to the
+;;; subform corressponding to the form number.
+;;;
;;; The vector elements are in the same format as the compiler's
-;;; NODE-SOUCE-PATH; that is, the first element is the form number and the last
-;;; is the top-level-form number.
+;;; NODE-SOURCE-PATH; that is, the first element is the form number and
+;;; the last is the top-level-form number.
(defun form-number-translations (form tlf-number)
- #!+sb-doc
- "This returns a table mapping form numbers to source-paths. A source-path
- indicates a descent into the top-level-form form, going directly to the
- subform corressponding to the form number."
(clrhash *form-number-circularity-table*)
(setf (fill-pointer *form-number-temp*) 0)
(sub-translate-form-numbers form (list tlf-number))
(frob)
(setq trail (cdr trail)))))))
+;;; FORM is a top-level form, and path is a source-path into it. This
+;;; returns the form indicated by the source-path. Context is the
+;;; number of enclosing forms to return instead of directly returning
+;;; the source-path form. When context is non-zero, the form returned
+;;; contains a marker, #:****HERE****, immediately before the form
+;;; indicated by path.
(defun source-path-context (form path context)
- #!+sb-doc
- "Form is a top-level form, and path is a source-path into it. This returns
- the form indicated by the source-path. Context is the number of enclosing
- forms to return instead of directly returning the source-path form. When
- context is non-zero, the form returned contains a marker, #:****HERE****,
- immediately before the form indicated by path."
(declare (type unsigned-byte context))
;; Get to the form indicated by path or the enclosing form indicated
;; by context and path.
\f
;;;; PREPROCESS-FOR-EVAL and EVAL-IN-FRAME
-;;; Create a SYMBOL-MACROLET for each variable valid at the location which
-;;; accesses that variable from the frame argument.
+;;; Return a function of one argument that evaluates form in the
+;;; lexical context of the basic-code-location loc.
+;;; PREPROCESS-FOR-EVAL signals a no-debug-vars condition when the
+;;; loc's debug-function has no debug-var information available. The
+;;; returned function takes the frame to get values from as its
+;;; argument, and it returns the values of form. The returned function
+;;; signals the following conditions: invalid-value,
+;;; ambiguous-variable-name, and frame-function-mismatch.
(defun preprocess-for-eval (form loc)
- #!+sb-doc
- "Return a function of one argument that evaluates form in the lexical
- context of the basic-code-location loc. PREPROCESS-FOR-EVAL signals a
- no-debug-vars condition when the loc's debug-function has no
- debug-var information available. The returned function takes the frame
- to get values from as its argument, and it returns the values of form.
- The returned function signals the following conditions: invalid-value,
- ambiguous-variable-name, and frame-function-mismatch"
(declare (type code-location loc))
(let ((n-frame (gensym))
(fun (code-location-debug-function loc)))
;;; nestedness inside debugger command loops
(defvar *debug-command-level* 0)
-(defvar *stack-top-hint* nil
- #!+sb-doc
- "If this is bound before the debugger is invoked, it is used as the stack
- top by the debugger.")
+;;; If this is bound before the debugger is invoked, it is used as the
+;;; stack top by the debugger.
+(defvar *stack-top-hint* nil)
+
(defvar *stack-top* nil)
(defvar *real-stack-top* nil)
(defvar *current-frame* nil)
+;;; Beginner-oriented help messages are important because you end up
+;;; in the debugger whenever something bad happens, or if you try to
+;;; get out of the system with Ctrl-C or (EXIT) or EXIT or whatever.
+;;; But after memorizing them the wasted screen space gets annoying..
+(defvar *debug-beginner-help-p* t
+ "Should the debugger display beginner-oriented help messages?")
+
(defun debug-prompt (stream)
;; old behavior, will probably go away in sbcl-0.7.x
;; that file, and right to send them to *DEBUG-IO*.
(*error-output* *debug-io*))
(unless (typep condition 'step-condition)
- (format *debug-io*
- "~%~@<Within the debugger, you can type HELP for help. At ~
- any command prompt (within the debugger or not) you can ~
- type (SB-EXT:QUIT) to terminate the SBCL executable. ~
- The condition which caused the debugger to be entered ~
- is bound to ~S.~:@>~2%"
- '*debug-condition*)
- (show-restarts *debug-restarts* *debug-io*)
- (terpri *debug-io*))
+ (when *debug-beginner-help-p*
+ (format *debug-io*
+ "~%~@<Within the debugger, you can type HELP for help. ~
+ At any command prompt (within the debugger or not) you ~
+ can type (SB-EXT:QUIT) to terminate the SBCL ~
+ executable. The condition which caused the debugger to ~
+ be entered is bound to ~S. You can suppress this ~
+ message by clearing ~S.~:@>~2%"
+ '*debug-condition*
+ '*debug-beginner-help-p*))
+ (show-restarts *debug-restarts* *debug-io*))
(internal-debug))))))
(defun show-restarts (restarts s)
(defun (setf def!struct-type-make-load-form-fun) (new-value type)
(when #+sb-xc-host t #-sb-xc-host *type-system-initialized*
(aver (subtypep type 'structure!object))
- (check-type new-value def!struct-type-make-load-form-fun))
+ (aver (typep new-value 'def!struct-type-make-load-form-fun)))
(setf (gethash type *def!struct-type-make-load-form-fun*) new-value)))
;;; the simplest, most vanilla MAKE-LOAD-FORM function for DEF!STRUCT
#+sb-xc-host
(progn
(defun %instance-length (instance)
- (check-type instance structure!object)
+ (aver (typep instance 'structure!object))
(layout-length (class-layout (sb!xc:find-class (type-of instance)))))
(defun %instance-ref (instance index)
- (check-type instance structure!object)
+ (aver (typep instance 'structure!object))
(let* ((class (sb!xc:find-class (type-of instance)))
(layout (class-layout class)))
(if (zerop index)
(declare (type symbol accessor))
(funcall accessor instance)))))
(defun %instance-set (instance index new-value)
- (check-type instance structure!object)
+ (aver (typep instance 'structure!object))
(let* ((class (sb!xc:find-class (type-of instance)))
(layout (class-layout class)))
(if (zerop index)
(lambda (x y)
(funcall fun y x)))
-;;; like CL:ASSERT, but lighter-weight
+;;; like CL:ASSERT and CL:CHECK-TYPE, but lighter-weight
;;;
-;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT
-;;; in SBCL. The CL:ASSERT restarts and whatnot expand into a
-;;; significant amount of code when you multiply them by 400, so
-;;; replacing them with this should reduce the size of the system
-;;; by enough to be worthwhile.)
+;;; (As of sbcl-0.6.11.20, we were using some 400 calls to CL:ASSERT.
+;;; The CL:ASSERT restarts and whatnot expand into a significant
+;;; amount of code when you multiply them by 400, so replacing them
+;;; with this should reduce the size of the system by enough to be
+;;; worthwhile. ENFORCE-TYPE is much less common, but might still be
+;;; worthwhile, and since I don't really like CERROR stuff deep in the
+;;; guts of complex systems anyway, I replaced it too.)
(defmacro aver (expr)
`(unless ,expr
(%failed-aver ,(let ((*package* (find-package :keyword)))
(format nil "~S" expr)))))
(defun %failed-aver (expr-as-string)
- (error "~@<failed AVER: ~2I~_~S~:>" expr-as-string))
+ (error "~@<internal error, failed AVER: ~2I~_~S~:>" expr-as-string))
+(defmacro enforce-type (value type)
+ (once-only ((value value))
+ `(unless (typep ,value ',type)
+ (%failed-aver-type ,value ',type))))
+(defun %failed-enforce-type (value type)
+ (error 'simple-type-error
+ :value value
+ :expected-type type
+ :format-string "~@<~S ~_is not a ~_~S~:>"
+ :format-arguments (list value type)))
;;; 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,
;;; know both the 1-byte-arg and the 4-byte-arg fop names. -- WHN 19990902
(defmacro define-cloned-fops ((name code &optional (pushp t))
(small-name small-code) &rest forms)
- (check-type pushp (member nil t :nope))
+ (aver (member pushp '(nil t :nope)))
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
(define-fop (,name ,code ,pushp) ,@forms))
(:report
(lambda (condition stream)
(format stream
- "~@<TYPE-ERROR in ~S: ~2I~:_~S is not of type ~S~:>."
+ "~@<TYPE-ERROR in ~S: ~
+ ~2I~_The value ~4I~:_~S ~2I~_is not of type ~4I~_~S.~:>"
(condition-function-name condition)
(type-error-datum condition)
(type-error-expected-type condition)))))
\f
;;;; the fop stack
-;;; (This is in a simple-vector, but it grows down, since it is
+;;; (This is in a SIMPLE-VECTOR, but it grows down, since it is
;;; somewhat cheaper to test for overflow that way.)
-(defvar *fop-stack* (make-array 100)
- #!+sb-doc
- "The fop stack (we only need one!).")
+(defvar *fop-stack* (make-array 100))
(declaim (simple-vector *fop-stack*))
-;;; the index of the most recently pushed item on the fop-stack
+;;; the index of the most recently pushed item on the fop stack
(defvar *fop-stack-pointer* 100)
;;; the current index into the fop stack when we last recursively
(setq *fop-stack-pointer* size)
(setq *fop-stack* new-stack)))
-;;; Cache information about the fop-stack in local variables. Define a
+;;; Cache information about the fop stack in local variables. Define a
;;; local macro to pop from the stack. Push the result of evaluation
;;; if specified.
(defmacro with-fop-stack (pushp &body forms)
- (check-type pushp (member nil t :nope))
+ (aver (member pushp '(nil t :nope)))
(let ((n-stack (gensym))
(n-index (gensym))
(n-res (gensym)))
;;;; This code was modified by William Harold Newman beginning
;;;; 19981106, originally to conform to the new SBCL bootstrap package
;;;; system and then subsequently to address other cross-compiling
-;;;; bootstrap issues. Whether or not it then supported all the
-;;;; environments implied by the reader conditionals in the source
-;;;; code (e.g. #!+CLOE-RUNTIME) before that modification, it sure
-;;;; doesn't now: it might be appropriate for CMU-CL-derived systems
-;;;; in general but only claims to be appropriate for the particular
-;;;; branch I was working on.
+;;;; bootstrap issues, SBCLification (e.g. DECLARE used to check
+;;;; argument types), and other maintenance. Whether or not it then
+;;;; supported all the environments implied by the reader conditionals
+;;;; in the source code (e.g. #!+CLOE-RUNTIME) before that
+;;;; modification, it sure doesn't now. It might perhaps, by blind
+;;;; luck, be appropriate for some other CMU-CL-derived system, but
+;;;; really it only attempts to be appropriate for SBCL.
;;;; This software is derived from software originally released by the
;;;; Massachusetts Institute of Technology and Symbolics, Inc. Copyright and
(defstruct (loop-universe
(:copier nil)
(:predicate nil))
- keywords ; hash table, value = (fn-name . extra-data)
- iteration-keywords ; hash table, value = (fn-name . extra-data)
- for-keywords ; hash table, value = (fn-name . extra-data)
- path-keywords ; hash table, value = (fn-name . extra-data)
- type-symbols ; hash table of type SYMBOLS, test EQ,
- ; value = CL type specifier
- type-keywords ; hash table of type STRINGS, test EQUAL,
- ; value = CL type spec
- ansi ; NIL, T, or :EXTENDED
+ keywords ; hash table, value = (fn-name . extra-data)
+ iteration-keywords ; hash table, value = (fn-name . extra-data)
+ for-keywords ; hash table, value = (fn-name . extra-data)
+ path-keywords ; hash table, value = (fn-name . extra-data)
+ type-symbols ; hash table of type SYMBOLS, test EQ,
+ ; value = CL type specifier
+ type-keywords ; hash table of type STRINGS, test EQUAL,
+ ; value = CL type spec
+ ansi ; NIL, T, or :EXTENDED
implicit-for-required) ; see loop-hack-iteration
(sb!int:def!method print-object ((u loop-universe) stream)
(let ((string (case (loop-universe-ansi u)
- ((nil) "Non-ANSI")
+ ((nil) "non-ANSI")
((t) "ANSI")
- (:extended "Extended-ANSI")
+ (:extended "extended-ANSI")
(t (loop-universe-ansi u)))))
(print-unreadable-object (u stream :type t)
(write-string string stream))))
(defun make-standard-loop-universe (&key keywords for-keywords
iteration-keywords path-keywords
type-keywords type-symbols ansi)
- (check-type ansi (member nil t :extended))
+ (declare (type (member nil t :extended) ansi))
(flet ((maketable (entries)
(let* ((size (length entries))
(ht (make-hash-table :size (if (< size 10) 10 size)
(defun add-loop-path (names function universe
&key preposition-groups inclusive-permitted user-data)
- (unless (listp names) (setq names (list names)))
- (check-type universe loop-universe)
+ (declare (type loop-universe universe))
+ (unless (listp names)
+ (setq names (list names)))
(let ((ht (loop-universe-path-keywords universe))
(lp (make-loop-path
:names (mapcar #'symbol-name names)
||#
(defun loop-hash-table-iteration-path (variable data-type prep-phrases
- &key which)
- (check-type which (member hash-key hash-value))
+ &key (which (required-argument)))
+ (declare (type (member :hash-key :hash-value) which))
(cond ((or (cdr prep-phrases) (not (member (caar prep-phrases) '(:in :of))))
- (loop-error "Too many prepositions!"))
+ (loop-error "too many prepositions!"))
((null prep-phrases)
(loop-error "missing OF or IN in ~S iteration path")))
(let ((ht-var (loop-gentemp 'loop-hashtab-))
(add-loop-path '(hash-key hash-keys) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
- :user-data '(:which hash-key))
+ :user-data '(:which :hash-key))
(add-loop-path '(hash-value hash-values) 'loop-hash-table-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
- :user-data '(:which hash-value))
+ :user-data '(:which :hash-value))
(add-loop-path '(symbol symbols) 'loop-package-symbols-iteration-path w
:preposition-groups '((:of :in))
:inclusive-permitted nil
;;;
;;; FIXME: In reality, this restart cruft is needed hardly anywhere in
;;; the system. Write NEED and NEED-TYPE to replace ASSERT and
-;;; CHECK-TYPE inside the system.
+;;; CHECK-TYPE inside the system. (CL:CHECK-TYPE must still be
+;;; defined, since it's specified by ANSI and it is sometimes nice for
+;;; whipping up little things. But as far as I can tell it's not
+;;; usually very helpful deep inside the guts of a complex system like
+;;; SBCL.)
;;;
;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses
;;; the macro RESTART-CASE, which isn't defined until a later file.
(defmacro-mundanely check-type (place type &optional type-string)
#!+sb-doc
- "Signals a restartable error of type TYPE-ERROR if the value of PLACE is
+ "Signal a restartable error of type TYPE-ERROR if the value of PLACE is
not of the specified type. If an error is signalled and the restart is
- used to return, the
- return if the
- STORE-VALUE is invoked. It will store into PLACE and start over."
+ used to return, this can only return if the STORE-VALUE restart is
+ invoked. In that case it will store into PLACE and start over."
(let ((place-value (gensym)))
- `(do ((,place-value ,place))
+ `(do ((,place-value ,place ,place))
((typep ,place-value ',type))
(setf ,place
(check-type-error ',place ,place-value ',type ,type-string)))))
-
-#!+high-security-support
-(defmacro-mundanely check-type-var (place type-var &optional type-string)
- #!+sb-doc
- "Signals an error of type TYPE-ERROR if the contents of PLACE are not of the
- specified type to which the TYPE-VAR evaluates. If an error is signaled,
- this can only return if STORE-VALUE is invoked. It will store into PLACE
- and start over."
- (let ((place-value (gensym))
- (type-value (gensym)))
- `(do ((,place-value ,place)
- (,type-value ,type-var))
- ((typep ,place-value ,type-value))
- (setf ,place
- (check-type-error ',place ,place-value ,type-value ,type-string)))))
\f
;;;; DEFCONSTANT
;;;; WHITESPACE-CHAR-P
;;; This is used in other files, but is defined in this one for some reason.
-
(defun whitespace-char-p (char)
#!+sb-doc
"Determines whether or not the character is considered whitespace."
(vec-bytes (* #-alpha 4 #+alpha 8 (+ (length string-list) 2))))
(declare (fixnum string-bytes vec-bytes))
(dolist (s string-list)
- (check-type s simple-string)
+ (enforce-type s simple-string)
(incf string-bytes (round-bytes-to-words (1+ (length s)))))
;; Now allocate the memory and fill it in.
(let* ((total-bytes (+ string-bytes vec-bytes))
bit-vector simple-bit-vector base-string
simple-base-string) ; FIXME: unifying principle here?
(let ((result (apply #'concat-to-simple* output-type-spec sequences)))
- #!+high-security
- (check-type-var result output-type-spec)
+ #!+high-security (aver (typep result output-type-spec))
result))
(list (apply #'concat-to-list* sequences))
(t
#!+sb-doc
"Return the handler function in Object-Set for the operation specified by
Message-ID, if none, NIL is returned."
- (check-type object-set object-set)
- (check-type message-id fixnum)
+ (enforce-type object-set object-set)
+ (enforce-type message-id fixnum)
(values (gethash message-id (object-set-table object-set))))
;;; The setf inverse for Object-Set-Operation.
(defun %set-object-set-operation (object-set message-id new-value)
- (check-type object-set object-set)
- (check-type message-id fixnum)
+ (enforce-type object-set object-set)
+ (enforce-type message-id fixnum)
(setf (gethash message-id (object-set-table object-set)) new-value))
|#
(defun merge (result-type sequence1 sequence2 predicate &key key)
#!+sb-doc
- "The sequences Sequence1 and Sequence2 are destructively merged into
- a sequence of type Result-Type using the Predicate to order the elements."
+ "The sequences SEQUENCE1 and SEQUENCE2 are destructively merged into
+ a sequence of type RESULT-TYPE using PREDICATE to order the elements."
(if (eq result-type 'list)
(let ((result (merge-lists* (coerce sequence1 'list)
(coerce sequence2 'list)
(vector-2 (coerce sequence2 'vector))
(length-1 (length vector-1))
(length-2 (length vector-2))
- (result (make-sequence-of-type result-type (+ length-1 length-2))))
+ (result (make-sequence-of-type result-type
+ (+ length-1 length-2))))
(declare (vector vector-1 vector-2)
(fixnum length-1 length-2))
- #!+high-security
- (check-type-var result result-type)
+ #!+high-security (aver (typep result result-type))
(if (and (simple-vector-p result)
(simple-vector-p vector-1)
(simple-vector-p vector-2))
\f
;;;; file position and file length
-;;; Call the misc method with the :file-position operation.
+;;; Call the MISC method with the :FILE-POSITION operation.
(defun file-position (stream &optional position)
(declare (type stream stream))
(declare (type (or index (member nil :start :end)) position))
(when res
(- res (- +in-buffer-length+ (lisp-stream-in-index stream))))))))
-;;; declaration test functions
-
-#!+high-security
-(defun stream-associated-with-file (stream)
- #!+sb-doc
- "Tests if the stream is associated with a file"
- (or (typep stream 'file-stream)
- (and (synonym-stream-p stream)
- (typep (symbol-value (synonym-stream-symbol stream))
- 'file-stream))))
-
-;;; Like File-Position, only use :file-length.
+;;; This is a literal translation of the ANSI glossary entry "stream
+;;; associated with a file".
+;;;
+;;; KLUDGE: Note that since Unix famously thinks "everything is a
+;;; file", and in particular stdin, stdout, and stderr are files, we
+;;; end up with this test being satisfied for weird things like
+;;; *STANDARD-OUTPUT* (to a tty). That seems unlikely to be what the
+;;; ANSI spec really had in mind, especially since this is used as a
+;;; qualification for operations like FILE-LENGTH (so that ANSI was
+;;; probably thinking of something like what Unix calls block devices)
+;;; but I can't see any better way to do it. -- WHN 2001-04-14
+(defun stream-associated-with-file-p (x)
+ "Test for the ANSI concept \"stream associated with a file\"."
+ (or (typep x 'file-stream)
+ (and (synonym-stream-p x)
+ (stream-associated-with-file-p (symbol-value
+ (synonym-stream-symbol x))))))
+
+(defun stream-must-be-associated-with-file (stream)
+ (declare (type stream stream))
+ (unless (stream-associated-with-file-p stream)
+ (error 'simple-type-error
+ ;; KLUDGE: The ANSI spec for FILE-LENGTH specifically says
+ ;; this should be TYPE-ERROR. But what then can we use for
+ ;; EXPECTED-TYPE? This SATISFIES type (with a nonstandard
+ ;; private predicate function..) is ugly and confusing, but
+ ;; I can't see any other way. -- WHN 2001-04-14
+ :expected-type '(satisfies stream-associated-with-file-p)
+ :format-string
+ "~@<The stream ~2I~_~S ~I~_isn't associated with a file.~:>"
+ :format-arguments (list stream))))
+
+;;; like FILE-POSITION, only using :FILE-LENGTH
(defun file-length (stream)
(declare (type (or file-stream synonym-stream) stream))
-
- #!+high-security
- (check-type-var stream '(satisfies stream-associated-with-file)
- "a stream associated with a file")
-
+ (stream-must-be-associated-with-file stream)
(funcall (lisp-stream-misc stream) stream :file-length))
\f
;;;; input functions
(:copier nil))
(input-stream (required-argument) :type stream :read-only t)
(output-stream (required-argument) :type stream :read-only t))
-(def!method print-object ((x two-way-stream) stream)
- (print-unreadable-object (x stream :type t :identity t)
- (format stream
- ":INPUT-STREAM ~S :OUTPUT-STREAM ~S"
- (two-way-stream-input-stream x)
- (two-way-stream-output-stream x))))
+(defprinter (two-way-stream) input-stream output-stream)
#!-high-security-support
(setf (fdocumentation 'make-two-way-stream 'function)
- "Returns a bidirectional stream which gets its input from Input-Stream and
+ "Return a bidirectional stream which gets its input from Input-Stream and
sends its output to Output-Stream.")
#!+high-security-support
(defun make-two-way-stream (input-stream output-stream)
#!+sb-doc
- "Returns a bidirectional stream which gets its input from Input-Stream and
+ "Return a bidirectional stream which gets its input from Input-Stream and
sends its output to Output-Stream."
;; FIXME: This idiom of the-real-stream-of-a-possibly-synonym-stream
;; should be encapsulated in a function, and used here and most of
"Executes the forms in the body without doing a garbage collection."
`(without-interrupts ,@body))
\f
-;;; Eof-Or-Lose is a useful macro that handles EOF.
+;;; EOF-OR-LOSE is a useful macro that handles EOF.
(defmacro eof-or-lose (stream eof-error-p eof-value)
`(if ,eof-error-p
(error 'end-of-file :stream ,stream)
,eof-value))
-;;; These macros handle the special cases of t and nil for input and
+;;; These macros handle the special cases of T and NIL for input and
;;; output streams.
;;;
;;; FIXME: Shouldn't these be functions instead of macros?
`(let ((,svar ,stream))
(cond ((null ,svar) *standard-input*)
((eq ,svar t) *terminal-io*)
- (T ,@(if check-type `((check-type ,svar ,check-type)))
+ (T ,@(when check-type `((enforce-type ,svar ,check-type)))
#!+high-security
(unless (input-stream-p ,svar)
(error 'simple-type-error
`(let ((,svar ,stream))
(cond ((null ,svar) *standard-output*)
((eq ,svar t) *terminal-io*)
- (T ,@(if check-type `((check-type ,svar ,check-type)))
+ (T ,@(when check-type `((check-type ,svar ,check-type)))
#!+high-security
(unless (output-stream-p ,svar)
(error 'simple-type-error
:format-arguments ,(list svar)))
,svar)))))
-;;; With-Mumble-Stream calls the function in the given Slot of the
-;;; Stream with the Args for lisp-streams, or the Function with the
-;;; Args for fundamental-streams.
+;;; WITH-mumble-STREAM calls the function in the given SLOT of the
+;;; STREAM with the ARGS for LISP-STREAMs, or the FUNCTION with the
+;;; ARGS for FUNDAMENTAL-STREAMs.
(defmacro with-in-stream (stream (slot &rest args) &optional stream-dispatch)
`(let ((stream (in-synonym-of ,stream)))
,(if stream-dispatch
;;; If there is a conflict then give the user a chance to do
;;; something about it.
(defun enter-new-nicknames (package nicknames)
- (check-type nicknames list)
+ (declare (type list nicknames))
(dolist (n nicknames)
(let* ((n (package-namify n))
(found (gethash n *package-names*)))
(handler-case
(progn
(format *error-output*
- "~@<unhandled CONDITION (of type ~S): ~2I~_~A~:>~2%"
+ "~@<unhandled condition (of type ~S): ~2I~_~A~:>~2%"
(type-of condition)
condition)
;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that
(sb!debug:backtrace 128 *error-output*)
(finish-output *error-output*)
(format *error-output*
- "~%unhandled CONDITION in --noprogrammer mode, quitting~%")
+ "~%unhandled condition in --noprogrammer mode, quitting~%")
(failure-quit))
(condition ()
(%primitive print "Argh! error within --noprogrammer error handling")
;;; Define the translation from a type-specifier to a type structure for
;;; some particular type. Syntax is identical to DEFTYPE.
(defmacro !def-type-translator (name arglist &body body)
- (check-type name symbol)
+ (declare (type symbol name))
;; FIXME: Now that the T%CL hack is ancient history and we just use CL
;; instead, we can probably return to using PARSE-DEFMACRO here.
;;
;;; necessary.
(defun emit-byte (segment byte)
(declare (type segment segment))
- ;; We could use DECLARE instead of CHECK-TYPE here, but (1) CMU CL's
- ;; inspired decision to treat DECLARE as ASSERT by default has not
- ;; been copied by other compilers, and this code runs in the
- ;; cross-compilation host Common Lisp, not just CMU CL, and (2)
- ;; classic CMU CL allowed more things here than this, and I haven't
- ;; tried to proof-read all the calls to EMIT-BYTE to ensure that
- ;; they're passing appropriate. -- WHN 19990323
- (check-type byte possibly-signed-assembly-unit)
+ (declare (type possibly-signed-assembly-unit byte))
(vector-push-extend (logand byte assembly-unit-mask)
(segment-buffer segment))
(incf (segment-current-posn segment))
|#
-;;; Check a block for consistency at the general flow-graph level, and call
-;;; Check-Node-Consistency on each node to locally check for semantic
-;;; consistency.
+;;; Check a block for consistency at the general flow-graph level, and
+;;; call CHECK-NODE-CONSISTENCY on each node to locally check for
+;;; semantic consistency.
(declaim (ftype (function (cblock) (values)) check-block-consistency))
(defun check-block-consistency (block)
(combination-p node)))
(barf "flushed arg not in local call: ~S" node))
(t
- (let ((fun (ref-leaf (continuation-use
- (basic-combination-fun node))))
- (pos (position arg (basic-combination-args node))))
- (check-type pos fixnum) ; to suppress warning -- WHN 19990311
- (when (leaf-refs (elt (lambda-vars fun) pos))
- (barf "flushed arg for referenced var in ~S" node))))))
-
+ (locally
+ ;; KLUDGE: In sbcl-0.6.11.37, the compiler doesn't like
+ ;; (DECLARE (TYPE INDEX POS)) after the inline expansion of
+ ;; POSITION. It compiles it correctly, but it issues a type
+ ;; mismatch warning because it can't eliminate the
+ ;; possibility that control will flow through the
+ ;; NIL-returning branch. So we punt here. -- WHN 2001-04-15
+ (declare (notinline position))
+ (let ((fun (ref-leaf (continuation-use
+ (basic-combination-fun node))))
+ (pos (position arg (basic-combination-args node))))
+ (declare (type index pos))
+ (when (leaf-refs (elt (lambda-vars fun) pos))
+ (barf "flushed arg for referenced var in ~S" node)))))))
(let ((dest (continuation-dest (node-cont node))))
(when (and (return-p dest)
(eq (basic-combination-kind node) :local)
;;; (2) stores its definition in the *COLD-FOP-FUNCTIONS* vector,
;;; instead of storing in the *FOP-FUNCTIONS* vector.
(defmacro define-cold-fop ((name &optional (pushp t)) &rest forms)
- (check-type pushp (member nil t :nope))
+ (aver (member pushp '(nil t :nope)))
(let ((code (get name 'fop-code))
(fname (symbolicate "COLD-" name)))
(unless code
(setf (svref *cold-fop-functions* ,code) #',fname))))
(defmacro clone-cold-fop ((name &optional (pushp t)) (small-name) &rest forms)
- (check-type pushp (member nil t :nope))
+ (aver (member pushp '(nil t :nope)))
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
(define-cold-fop (,name ,pushp) ,@forms))
\f
;;;; storage class and storage base definition
-;;; Enter the basic structure at meta-compile time, and then fill in the
-;;; missing slots at load time.
+;;; Define a storage base having the specified NAME. KIND may be :FINITE,
+;;; :UNBOUNDED or :NON-PACKED. The following keywords are legal:
+;;; :SIZE specifies the number of locations in a :FINITE SB or
+;;; the initial size of an :UNBOUNDED SB.
+;;;
+;;; We enter the basic structure at meta-compile time, and then fill
+;;; in the missing slots at load time.
(defmacro define-storage-base (name kind &key size)
- #!+sb-doc
- "Define-Storage-Base Name Kind {Key Value}*
- Define a storage base having the specified Name. Kind may be :Finite,
- :Unbounded or :Non-Packed. The following keywords are legal:
- :Size <Size>
- Specify the number of locations in a :Finite SB or the initial size of a
- :Unbounded SB."
-
- ;; FIXME: Replace with DECLARE.
- (check-type name symbol)
- (check-type kind (member :finite :unbounded :non-packed))
+ (declare (type symbol name))
+ (declare (type (member :finite :unbounded :non-packed) kind))
;; SIZE is either mandatory or forbidden.
(ecase kind
(error "A size specification is meaningless in a ~S SB." kind)))
((:finite :unbounded)
(unless size (error "Size is not specified in a ~S SB." kind))
- (check-type size unsigned-byte)))
+ (aver (typep size 'unsigned-byte))))
(let ((res (if (eq kind :non-packed)
(make-sb :name name :kind kind)
(/show0 "finished with DEFINE-STORAGE-BASE expansion")
',name)))
+;;; Define a storage class Name that uses the named Storage-Base. Number is a
+;;; small, non-negative integer that is used as an alias. The following
+;;; keywords are defined:
+;;;
+;;; :Element-Size Size
+;;; The size of objects in this SC in whatever units the SB uses. This
+;;; defaults to 1.
+;;;
+;;; :Alignment Size
+;;; The alignment restrictions for this SC. TNs will only be allocated at
+;;; offsets that are an even multiple of this number. Defaults to 1.
+;;;
+;;; :Locations (Location*)
+;;; If the SB is :Finite, then this is a list of the offsets within the SB
+;;; that are in this SC.
+;;;
+;;; :Reserve-Locations (Location*)
+;;; A subset of the Locations that the register allocator should try to
+;;; reserve for operand loading (instead of to hold variable values.)
+;;;
+;;; :Save-P {T | NIL}
+;;; If T, then values stored in this SC must be saved in one of the
+;;; non-save-p :Alternate-SCs across calls.
+;;;
+;;; :Alternate-SCs (SC*)
+;;; Indicates other SCs that can be used to hold values from this SC across
+;;; calls or when storage in this SC is exhausted. The SCs should be
+;;; specified in order of decreasing \"goodness\". There must be at least
+;;; one SC in an unbounded SB, unless this SC is only used for restricted or
+;;; wired TNs.
+;;;
+;;; :Constant-SCs (SC*)
+;;; A list of the names of all the constant SCs that can be loaded into this
+;;; SC by a move function.
(defmacro define-storage-class (name number sb-name &key (element-size '1)
(alignment '1) locations reserve-locations
save-p alternate-scs constant-scs)
- #!+sb-doc
- "Define-Storage-Class Name Number Storage-Base {Key Value}*
- Define a storage class Name that uses the named Storage-Base. Number is a
- small, non-negative integer that is used as an alias. The following
- keywords are defined:
-
- :Element-Size Size
- The size of objects in this SC in whatever units the SB uses. This
- defaults to 1.
-
- :Alignment Size
- The alignment restrictions for this SC. TNs will only be allocated at
- offsets that are an even multiple of this number. Defaults to 1.
-
- :Locations (Location*)
- If the SB is :Finite, then this is a list of the offsets within the SB
- that are in this SC.
-
- :Reserve-Locations (Location*)
- A subset of the Locations that the register allocator should try to
- reserve for operand loading (instead of to hold variable values.)
-
- :Save-P {T | NIL}
- If T, then values stored in this SC must be saved in one of the
- non-save-p :Alternate-SCs across calls.
-
- :Alternate-SCs (SC*)
- Indicates other SCs that can be used to hold values from this SC across
- calls or when storage in this SC is exhausted. The SCs should be
- specified in order of decreasing \"goodness\". There must be at least
- one SC in an unbounded SB, unless this SC is only used for restricted or
- wired TNs.
-
- :Constant-SCs (SC*)
- A list of the names of all the constant SCs that can be loaded into this
- SC by a move function."
-
- (check-type name symbol)
- (check-type number sc-number)
- (check-type sb-name symbol)
- (check-type locations list)
- (check-type reserve-locations list)
- (check-type save-p boolean)
- (check-type alternate-scs list)
- (check-type constant-scs list)
+ (declare (type symbol name))
+ (declare (type sc-number number))
+ (declare (type symbol sb-name))
+ (declare (type list locations reserve-locations alternate-scs constant-scs))
+ (declare (type boolean save-p))
(unless (= (logcount alignment) 1)
(error "alignment not a power of two: ~D" alignment))
(if (eq (sb-kind sb) :finite)
(let ((size (sb-size sb))
(element-size (eval element-size)))
- (check-type element-size unsigned-byte)
+ (declare (type unsigned-byte element-size))
(dolist (el locations)
- (check-type el unsigned-byte)
+ (declare (type unsigned-byte el))
(unless (<= 1 (+ el element-size) size)
(error "SC element ~D out of bounds for ~S" el sb))))
(when locations
(let ((,to-sc-var (meta-sc-or-lose to)))
,@body))))))
+;;; Define the function NAME and note it as the function used for
+;;; moving operands from the From-SCs to the To-SCs. Cost is the cost
+;;; of this move operation. The function is called with three
+;;; arguments: the VOP (for context), and the source and destination
+;;; TNs. An ASSEMBLE form is wrapped around the body. All uses of
+;;; DEFINE-MOVE-FUNCTION should be compiled before any uses of
+;;; DEFINE-VOP.
(defmacro define-move-function ((name cost) lambda-list scs &body body)
- #!+sb-doc
- "Define-Move-Function (Name Cost) lambda-list ({(From-SC*) (To-SC*)}*) form*
- Define the function Name and note it as the function used for moving operands
- from the From-SCs to the To-SCs. Cost is the cost of this move operation.
- The function is called with three arguments: the VOP (for context), and the
- source and destination TNs. An ASSEMBLE form is wrapped around the body.
- All uses of DEFINE-MOVE-FUNCTION should be compiled before any uses of
- DEFINE-VOP."
+ (declare (type index cost))
(when (or (oddp (length scs)) (null scs))
(error "malformed SCs spec: ~S" scs))
- (check-type cost index)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(do-sc-pairs (from-sc to-sc ',scs)
;;; class that values of this type may be allocated in. TYPE is the
;;; type descriptor for the Lisp type that is equivalent to this type.
(defmacro !def-primitive-type (name scs &key (type name))
- (check-type name symbol)
- (check-type scs list)
+ (declare (type symbol name) (type list scs))
(let ((scns (mapcar #'meta-sc-number-or-lose scs))
(get-type `(specifier-type ',type)))
`(progn
;;; operands, and a single OPERAND-PARSE describing any more operand.
;;; If we are inheriting a VOP, we default attributes to the inherited
;;; operand of the same name.
-(defun parse-operands (parse specs kind)
+(defun !parse-vop-operands (parse specs kind)
(declare (list specs)
(type (member :argument :result) kind))
(let ((num -1)
(let ((value (second key)))
(case (first key)
(:scs
- (check-type value list)
+ (aver (typep value 'list))
(setf (operand-parse-scs res) (remove-duplicates value)))
(:load-tn
- (check-type value symbol)
+ (aver (typep value 'symbol))
(setf (operand-parse-load-tn res) value))
(:load-if
(setf (operand-parse-load res) value))
(:more
- (check-type value boolean)
+ (aver (typep value 'boolean))
(setf (operand-parse-kind res)
(if (eq kind :argument) :more-argument :more-result))
(setf (operand-parse-load res) nil)
(setq more res))
(:target
- (check-type value symbol)
+ (aver (typep value 'symbol))
(setf (operand-parse-target res) value))
(:from
(unless (eq kind :result)
(vop-spec-arg opt 'symbol 1 nil)))
(:offset
(let ((offset (eval (second opt))))
- (check-type offset unsigned-byte)
+ (aver (typep offset 'unsigned-byte))
(setf (operand-parse-offset res) offset)))
(:from
(setf (operand-parse-born res) (parse-time-spec (second opt))))
(:to
(setf (operand-parse-dies res) (parse-time-spec (second opt))))
- ;; Backward compatibility...
+ ;; backward compatibility...
(:scs
(let ((scs (vop-spec-arg opt 'list 1 nil)))
(unless (= (length scs) 1)
(case (first spec)
(:args
(multiple-value-bind (fixed more)
- (parse-operands parse (rest spec) :argument)
+ (!parse-vop-operands parse (rest spec) :argument)
(setf (vop-parse-args parse) fixed)
(setf (vop-parse-more-args parse) more)))
(:results
(multiple-value-bind (fixed more)
- (parse-operands parse (rest spec) :result)
+ (!parse-vop-operands parse (rest spec) :result)
(setf (vop-parse-results parse) fixed)
(setf (vop-parse-more-results parse) more))
(setf (vop-parse-conditional-p parse) nil))
(setf (vop-parse-note parse) (vop-spec-arg spec '(or string null))))
(:arg-types
(setf (vop-parse-arg-types parse)
- (parse-operand-types (rest spec) t)))
+ (!parse-vop-operand-types (rest spec) t)))
(:result-types
(setf (vop-parse-result-types parse)
- (parse-operand-types (rest spec) nil)))
+ (!parse-vop-operand-types (rest spec) nil)))
(:translate
(setf (vop-parse-translate parse) (rest spec)))
(:guard
\f
;;;; operand checking and stuff
-;;; Given a list of arg/result restrictions, check for valid syntax and
-;;; convert to canonical form.
-(defun parse-operand-types (specs args-p)
+;;; Given a list of arg/result restrictions, check for valid syntax
+;;; and convert to canonical form.
+(defun !parse-vop-operand-types (specs args-p)
(declare (list specs))
(labels ((parse-operand-type (spec)
(cond ((eq spec '*) spec)
;;; Compute stuff that can only be computed after we are done parsing
;;; everying. We set the VOP-Parse-Operands, and do various error checks.
-(defun grovel-operands (parse)
+(defun !grovel-vop-operands (parse)
(declare (type vop-parse parse))
(setf (vop-parse-operands parse)
;;; Indicates if and how the more args should be moved into a
;;; different frame.
(def!macro define-vop ((name &optional inherits) &rest specs)
+ (declare (type symbol name))
;; Parse the syntax into a VOP-PARSE structure, and then expand into
;; code that creates the appropriate VOP-INFO structure at load time.
;; We implement inheritance by copying the VOP-PARSE structure for
;; the inherited structure.
- (check-type name symbol)
(let* ((inherited-parse (when inherits
(vop-parse-or-lose inherits)))
(parse (if inherits
(setf (vop-parse-inherits parse) inherits)
(parse-define-vop parse specs)
- (grovel-operands parse)
+ (!grovel-vop-operands parse)
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(values (forms) (binds) n-head))))
+;;; Emit-Template Node Block Template Args Results [Info]
+;;;
+;;; Call the emit function for Template, linking the result in at the
+;;; end of Block.
(defmacro emit-template (node block template args results &optional info)
- #!+sb-doc
- "Emit-Template Node Block Template Args Results [Info]
- Call the emit function for Template, linking the result in at the end of
- Block."
(let ((n-first (gensym))
(n-last (gensym)))
(once-only ((n-node node)
,@(when info `(,info)))
(insert-vop-sequence ,n-first ,n-last ,n-block nil)))))
+;;; VOP Name Node Block Arg* Info* Result*
+;;;
+;;; Emit the VOP (or other template) Name at the end of the IR2-Block
+;;; Block, using Node for the source context. The interpretation of
+;;; the remaining arguments depends on the number of operands of
+;;; various kinds that are declared in the template definition. VOP
+;;; cannot be used for templates that have more-args or more-results,
+;;; since the number of arguments and results is indeterminate for
+;;; these templates. Use VOP* instead.
+;;;
+;;; Args and Results are the TNs that are to be referenced by the
+;;; template as arguments and results. If the template has
+;;; codegen-info arguments, then the appropriate number of Info forms
+;;; following the Arguments are used for codegen info.
(defmacro vop (name node block &rest operands)
- #!+sb-doc
- "VOP Name Node Block Arg* Info* Result*
- Emit the VOP (or other template) Name at the end of the IR2-Block Block,
- using Node for the source context. The interpretation of the remaining
- arguments depends on the number of operands of various kinds that are
- declared in the template definition. VOP cannot be used for templates that
- have more-args or more-results, since the number of arguments and results is
- indeterminate for these templates. Use VOP* instead.
-
- Args and Results are the TNs that are to be referenced by the template
- as arguments and results. If the template has codegen-info arguments, then
- the appropriate number of Info forms following the Arguments are used for
- codegen info."
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
(result-count (length (vop-parse-results parse)))
`((list ,@(ivars)))))
(values)))))))
+;;; VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
+;;;
+;;; This is like VOP, but allows for emission of templates with
+;;; arbitrary numbers of arguments, and for emission of templates
+;;; using already-created TN-Ref lists.
+;;;
+;;; The Arguments and Results are TNs to be referenced as the first
+;;; arguments and results to the template. More-Args and More-Results
+;;; are heads of TN-Ref lists that are added onto the end of the
+;;; TN-Refs for the explicitly supplied operand TNs. The TN-Refs for
+;;; the more operands must have the TN and Write-P slots correctly
+;;; initialized.
+;;;
+;;; As with VOP, the Info forms are evaluated and passed as codegen
+;;; info arguments.
(defmacro vop* (name node block args results &rest info)
- #!+sb-doc
- "VOP* Name Node Block (Arg* More-Args) (Result* More-Results) Info*
- Like VOP, but allows for emission of templates with arbitrary numbers of
- arguments, and for emission of templates using already-created TN-Ref lists.
-
- The Arguments and Results are TNs to be referenced as the first arguments
- and results to the template. More-Args and More-Results are heads of TN-Ref
- lists that are added onto the end of the TN-Refs for the explicitly supplied
- operand TNs. The TN-Refs for the more operands must have the TN and Write-P
- slots correctly initialized.
-
- As with VOP, the Info forms are evaluated and passed as codegen info
- arguments."
- (check-type args cons)
- (check-type results cons)
+ (declare (type cons args results))
(let* ((parse (vop-parse-or-lose name))
(arg-count (length (vop-parse-args parse)))
(result-count (length (vop-parse-results parse)))
\f
;;;; miscellaneous macros
+;;; SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
+;;;
+;;; Case off of TN's SC. The first clause containing TN's SC is
+;;; evaluated, returning the values of the last form. A clause
+;;; beginning with T specifies a default. If it appears, it must be
+;;; last. If no default is specified, and no clause matches, then an
+;;; error is signalled.
(def!macro sc-case (tn &rest forms)
- #!+sb-doc
- "SC-Case TN {({(SC-Name*) | SC-Name | T} Form*)}*
- Case off of TN's SC. The first clause containing TN's SC is evaluated,
- returning the values of the last form. A clause beginning with T specifies a
- default. If it appears, it must be last. If no default is specified, and no
- clause matches, then an error is signalled."
(let ((n-sc (gensym))
(n-tn (gensym)))
(collect ((clauses))
(,n-sc (sc-number (tn-sc ,n-tn))))
(cond ,@(clauses))))))
+;;; Return true if TNs SC is any of the named SCs, false otherwise.
(defmacro sc-is (tn &rest scs)
- #!+sb-doc
- "SC-Is TN SC*
- Returns true if TNs SC is any of the named SCs, false otherwise."
(once-only ((n-sc `(sc-number (tn-sc ,tn))))
`(or ,@(mapcar #'(lambda (x)
`(eql ,n-sc ,(meta-sc-number-or-lose x)))
scs))))
+;;; Iterate over the IR2 blocks in component, in emission order.
(defmacro do-ir2-blocks ((block-var component &optional result)
&body forms)
- #!+sb-doc
- "Do-IR2-Blocks (Block-Var Component [Result]) Form*
- Iterate over the IR2 blocks in component, in emission order."
`(do ((,block-var (block-info (component-head ,component))
(ir2-block-next ,block-var)))
((null ,block-var) ,result)
,@forms))
+;;; Iterate over all the TNs live at some point, with the live set
+;;; represented by a local conflicts bit-vector and the IR2-Block
+;;; containing the location.
(defmacro do-live-tns ((tn-var live block &optional result) &body body)
- #!+sb-doc
- "DO-LIVE-TNS (TN-Var Live Block [Result]) Form*
- Iterate over all the TNs live at some point, with the live set represented by
- a local conflicts bit-vector and the IR2-Block containing the location."
(let ((n-conf (gensym))
(n-bod (gensym))
(i (gensym))
(when (and ,tn-var (not (eq ,tn-var :more)))
(,n-bod ,tn-var)))))))))))
+;;; Iterate over all the IR2 blocks in the environment Env, in emit order.
(defmacro do-environment-ir2-blocks ((block-var env &optional result)
&body body)
- #!+sb-doc
- "DO-ENVIRONMENT-IR2-BLOCKS (Block-Var Env [Result]) Form*
- Iterate over all the IR2 blocks in the environment Env, in emit order."
(once-only ((n-env env))
(once-only ((n-first `(node-block
(lambda-bind
(:info target not-p)
(:policy :fast-safe))
-;;; Simpler VOP that don't need a temporary register.
+;;; simpler VOP that don't need a temporary register
(define-vop (simple-check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)
YEP
(move result value)))
-;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
-;;; bignum with exactly one positive digit, or a bignum with exactly two digits
-;;; and the second digit all zeros.
+;;; An (unsigned-byte 32) can be represented with either a positive
+;;; fixnum, a bignum with exactly one positive digit, or a bignum with
+;;; exactly two digits and the second digit all zeros.
(define-vop (unsigned-byte-32-p type-predicate)
(:translate unsigned-byte-32-p)
(make-method ,main-effective-method)))
main-effective-method))))))
\f
-;;;; the STANDARD method combination type. This is coded by hand (rather than
-;;;; with define-method-combination) for bootstrapping and efficiency reasons.
-;;;; Note that the definition of the find-method-combination-method appears in
-;;;; the file defcombin.lisp. This is because EQL methods can't appear in the
+;;;; the STANDARD method combination type. This is coded by hand
+;;;; (rather than with DEFINE-METHOD-COMBINATION) for bootstrapping
+;;;; and efficiency reasons. Note that the definition of the
+;;;; FIND-METHOD-COMBINATION-METHOD appears in the file
+;;;; defcombin.lisp. This is because EQL methods can't appear in the
;;;; bootstrap.
;;;;
;;;; The DEFCLASS for the METHOD-COMBINATION and
combin
applicable-methods))
-;;; FIXME: As of sbcl-0.6.10, the bindings of *INVALID-METHOD-ERROR*
-;;; and *METHOD-COMBINATION-ERROR* are never changed, even within the
-;;; dynamic scope of method combination functions.
-(defvar *invalid-method-error*
- #'(lambda (&rest args)
- (declare (ignore args))
- (error
- "INVALID-METHOD-ERROR was called outside the dynamic scope~%~
- of a method combination function (inside the body of~%~
- DEFINE-METHOD-COMBINATION or a method on the generic~%~
- function COMPUTE-EFFECTIVE-METHOD).")))
-(defvar *method-combination-error*
- #'(lambda (&rest args)
- (declare (ignore args))
- (error
- "METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
- of a method combination function (inside the body of~%~
- DEFINE-METHOD-COMBINATION or a method on the generic~%~
- function COMPUTE-EFFECTIVE-METHOD).")))
+(defun invalid-method-error (method format-control &rest format-arguments)
+ (error "~@<invalid method error for ~2I_~S ~I~_method: ~2I~_~?~:>"
+ method
+ format-control
+ format-arguments))
-;(defmethod compute-effective-method :around ;issue with magic
-; ((generic-function generic-function) ;generic functions
-; (method-combination method-combination)
-; applicable-methods)
-; (declare (ignore applicable-methods))
-; (flet ((real-invalid-method-error (method format-string &rest args)
-; (declare (ignore method))
-; (apply #'error format-string args))
-; (real-method-combination-error (format-string &rest args)
-; (apply #'error format-string args)))
-; (let ((*invalid-method-error* #'real-invalid-method-error)
-; (*method-combination-error* #'real-method-combination-error))
-; (call-next-method))))
-
-(defun invalid-method-error (&rest args)
- (apply *invalid-method-error* args))
-
-(defun method-combination-error (&rest args)
- (apply *method-combination-error* args))
-
-;This definition now appears in defcombin.lisp.
-;
-;(defmethod find-method-combination ((generic-function generic-function)
-; (type (eql 'standard))
-; options)
-; (when options
-; (method-combination-error
-; "The method combination type STANDARD accepts no options."))
-; *standard-method-combination*)
+(defun method-combination-error (format-control &rest format-arguments)
+ (error "~@<method combination error in CLOS dispatch: ~2I~_~?~:>"
+ format-control
+ format-arguments))
\f
;;;; standard method combination
-;;; The STANDARD method combination type is implemented directly by the class
-;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does
-;;; standard method combination directly and is defined by hand in the file
-;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this
-;;; file for bootstrapping reasons.
-;;;
-;;; A commented out copy of this definition appears in combin.lisp.
-;;; If you change this definition here, be sure to change it there
-;;; also.
+;;; The STANDARD method combination type is implemented directly by
+;;; the class STANDARD-METHOD-COMBINATION. The method on
+;;; COMPUTE-EFFECTIVE-METHOD does standard method combination directly
+;;; and is defined by hand in the file combin.lisp. The method for
+;;; FIND-METHOD-COMBINATION must appear in this file for bootstrapping
+;;; reasons.
(defmethod find-method-combination ((generic-function generic-function)
(type (eql 'standard))
options)
((equal options '(:most-specific-last)))
(t
(method-combination-error
- "Illegal options to a short method combination type.~%~
- The method combination type ~S accepts one option which~%~
- must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
- type)))
+ "Illegal options to a short method combination type.~%~
+ The method combination type ~S accepts one option which~%~
+ must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
+ type)))
(make-instance 'short-method-combination
:type type
:options options
;;; 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.36"
+"0.6.11.37"
projects / sbcl.git / commitdiff