From 2c6b90e36a7c0377cd79625eb6c94d580f98cb93 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 15 Apr 2001 16:42:05 +0000 Subject: [PATCH] 0.6.11.37: MNA 2001-04-13 CHECK-TYPE/STORE-VALUE patch replaced CHECK-TYPE calls with lighter-weight stuff rewrote CHECK-TYPE-VAR with lighter-weight stuff redid STREAM-ASSOCIATED-WITH-FILE-P renamed PARSE-OPERANDS to !PARSE-VOP-OPERANDS, and GROVEL-OPERANDS to !GROVEL-VOP-OPERANDS, and PARSE-OPERAND-TYPES to !PARSE-VOP-OPERAND-TYPES (and queued up various FOO -> !FOO renamings for after Alpha port is merged) made INVALID-METHOD-ERROR and METHOD-COMBINATION-ERROR stop screwing around with DEFVARs added *DEBUG-BEGINNER-HELP-P* --- NEWS | 43 +++--- package-data-list.lisp-expr | 5 +- src/code/coerce.lisp | 8 +- src/code/cold-error.lisp | 2 +- src/code/debug-int.lisp | 68 +++++----- src/code/debug.lisp | 35 +++-- src/code/defbangstruct.lisp | 8 +- src/code/early-extensions.lisp | 26 +++- src/code/fop.lisp | 2 +- src/code/late-target-error.lisp | 3 +- src/code/load.lisp | 12 +- src/code/loop.lisp | 52 ++++---- src/code/macros.lisp | 30 ++--- src/code/print.lisp | 1 - src/code/run-program.lisp | 2 +- src/code/seq.lisp | 3 +- src/code/serve-event.lisp | 8 +- src/code/sort.lisp | 10 +- src/code/stream.lisp | 64 +++++---- src/code/sysmacs.lisp | 14 +- src/code/target-package.lisp | 2 +- src/code/toplevel.lisp | 4 +- src/code/typedefs.lisp | 2 +- src/compiler/assem.lisp | 9 +- src/compiler/debug.lisp | 27 ++-- src/compiler/generic/genesis.lisp | 4 +- src/compiler/meta-vmdef.lisp | 264 +++++++++++++++++-------------------- src/compiler/x86/type-vops.lisp | 8 +- src/pcl/combin.lisp | 66 ++-------- src/pcl/defcombin.lisp | 23 ++-- version.lisp-expr | 2 +- 31 files changed, 391 insertions(+), 416 deletions(-) diff --git a/NEWS b/NEWS index 72937c0..ac3c486 100644 --- a/NEWS +++ b/NEWS @@ -692,10 +692,9 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11: 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 @@ -705,20 +704,34 @@ changes in sbcl-0.6.12 relative to sbcl-0.6.11: 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 + . + 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. diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 098a02c..88fead7 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -334,7 +334,8 @@ 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*" @@ -669,7 +670,7 @@ retained, possibly temporariliy, because it might be used internally." "ONCE-ONLY" "DEFENUM" "DEFPRINTER" - "AVER" + "AVER" "AVER-TYPE" "ENFORCE-TYPE" ;; ..and DEFTYPEs.. "INDEX" diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index e257fd7..7b8a2fc 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -136,15 +136,14 @@ ;;; 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 @@ -256,8 +255,7 @@ :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 diff --git a/src/code/cold-error.lisp b/src/code/cold-error.lisp index 869cdbb..b2089e0 100644 --- a/src/code/cold-error.lisp +++ b/src/code/cold-error.lisp @@ -150,7 +150,7 @@ (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." diff --git a/src/code/debug-int.lisp b/src/code/debug-int.lisp index f610a0c..5e35ad2 100644 --- a/src/code/debug-int.lisp +++ b/src/code/debug-int.lisp @@ -446,7 +446,7 @@ ;;; 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))) @@ -2437,13 +2437,13 @@ 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) @@ -2643,13 +2643,13 @@ (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) @@ -2950,7 +2950,7 @@ (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 @@ -2961,7 +2961,7 @@ ;;; 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) @@ -2973,14 +2973,16 @@ (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))))) @@ -3004,21 +3006,21 @@ ;;; 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)) @@ -3046,13 +3048,13 @@ (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. @@ -3084,17 +3086,15 @@ ;;;; 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))) diff --git a/src/code/debug.lisp b/src/code/debug.lisp index 9f71712..c81ea49 100644 --- a/src/code/debug.lisp +++ b/src/code/debug.lisp @@ -37,15 +37,22 @@ ;;; 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 @@ -673,15 +680,17 @@ reset to ~S." ;; that file, and right to send them to *DEBUG-IO*. (*error-output* *debug-io*)) (unless (typep condition 'step-condition) - (format *debug-io* - "~%~@~2%" - '*debug-condition*) - (show-restarts *debug-restarts* *debug-io*) - (terpri *debug-io*)) + (when *debug-beginner-help-p* + (format *debug-io* + "~%~@~2%" + '*debug-condition* + '*debug-beginner-help-p*)) + (show-restarts *debug-restarts* *debug-io*)) (internal-debug)))))) (defun show-restarts (restarts s) diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp index fecf0f8..7516e29 100644 --- a/src/code/defbangstruct.lisp +++ b/src/code/defbangstruct.lisp @@ -71,7 +71,7 @@ (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 @@ -146,10 +146,10 @@ #+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) @@ -160,7 +160,7 @@ (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) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index e93074c..7a49785 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -378,19 +378,31 @@ (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 "~@" expr-as-string)) + (error "~@" 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, diff --git a/src/code/fop.lisp b/src/code/fop.lisp index 3d1df11..e8c3a37 100644 --- a/src/code/fop.lisp +++ b/src/code/fop.lisp @@ -65,7 +65,7 @@ ;;; 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)) diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index 4a89b6b..fc31a55 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -592,7 +592,8 @@ (:report (lambda (condition stream) (format stream - "~@." + "~@" (condition-function-name condition) (type-error-datum condition) (type-error-expected-type condition))))) diff --git a/src/code/load.lisp b/src/code/load.lisp index 06d18b8..756dcc0 100644 --- a/src/code/load.lisp +++ b/src/code/load.lisp @@ -190,14 +190,12 @@ ;;;; 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 @@ -215,11 +213,11 @@ (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))) diff --git a/src/code/loop.lisp b/src/code/loop.lisp index ba7450e..3ac743c 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -6,12 +6,13 @@ ;;;; 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 @@ -340,21 +341,21 @@ code to be loaded. (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)))) @@ -366,7 +367,7 @@ code to be loaded. (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) @@ -1586,8 +1587,9 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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) @@ -1865,10 +1867,10 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. ||# (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-)) @@ -1997,11 +1999,11 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (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 diff --git a/src/code/macros.lisp b/src/code/macros.lisp index c55f1b9..2bf63a6 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -56,37 +56,25 @@ ;;; ;;; 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))))) ;;;; DEFCONSTANT diff --git a/src/code/print.lisp b/src/code/print.lisp index 22281e5..40ec188 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -275,7 +275,6 @@ ;;;; 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." diff --git a/src/code/run-program.lisp b/src/code/run-program.lisp index c30fffd..8ae7caa 100644 --- a/src/code/run-program.lisp +++ b/src/code/run-program.lisp @@ -391,7 +391,7 @@ (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)) diff --git a/src/code/seq.lisp b/src/code/seq.lisp index ae5782a..ed14624 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -607,8 +607,7 @@ 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 diff --git a/src/code/serve-event.lisp b/src/code/serve-event.lisp index 299d4f7..9ad0e36 100644 --- a/src/code/serve-event.lisp +++ b/src/code/serve-event.lisp @@ -42,14 +42,14 @@ #!+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)) |# diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 443f83e..7a140fa 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -411,8 +411,8 @@ (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) @@ -422,12 +422,12 @@ (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)) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index b09bacf..6422ecc 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -201,7 +201,7 @@ ;;;; 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)) @@ -214,25 +214,42 @@ (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 + "~@" + :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)) ;;;; input functions @@ -798,21 +815,16 @@ (: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 diff --git a/src/code/sysmacs.lisp b/src/code/sysmacs.lisp index f112680..34bcb94 100644 --- a/src/code/sysmacs.lisp +++ b/src/code/sysmacs.lisp @@ -67,13 +67,13 @@ "Executes the forms in the body without doing a garbage collection." `(without-interrupts ,@body)) -;;; 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? @@ -82,7 +82,7 @@ `(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 @@ -96,7 +96,7 @@ `(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 @@ -106,9 +106,9 @@ :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 diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index c8f6756..3759f74 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -277,7 +277,7 @@ ;;; 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*))) diff --git a/src/code/toplevel.lisp b/src/code/toplevel.lisp index 47a1efe..43bbe68 100644 --- a/src/code/toplevel.lisp +++ b/src/code/toplevel.lisp @@ -491,7 +491,7 @@ (handler-case (progn (format *error-output* - "~@~2%" + "~@~2%" (type-of condition) condition) ;; Flush *ERROR-OUTPUT* even before the BACKTRACE, so that @@ -503,7 +503,7 @@ (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") diff --git a/src/code/typedefs.lisp b/src/code/typedefs.lisp index 3d0c69f..bcbfece 100644 --- a/src/code/typedefs.lisp +++ b/src/code/typedefs.lisp @@ -27,7 +27,7 @@ ;;; 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. ;; diff --git a/src/compiler/assem.lisp b/src/compiler/assem.lisp index 65caaec..83c2157 100644 --- a/src/compiler/assem.lisp +++ b/src/compiler/assem.lisp @@ -709,14 +709,7 @@ p ;; the branch has two dependents and one of them dpends on ;;; 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)) diff --git a/src/compiler/debug.lisp b/src/compiler/debug.lisp index 371777f..2458152 100644 --- a/src/compiler/debug.lisp +++ b/src/compiler/debug.lisp @@ -316,9 +316,9 @@ |# -;;; 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) @@ -499,13 +499,20 @@ (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) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index b5d6fe6..cd5b7b0 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -1758,7 +1758,7 @@ ;;; (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 @@ -1771,7 +1771,7 @@ (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)) diff --git a/src/compiler/meta-vmdef.lisp b/src/compiler/meta-vmdef.lisp index 714cdf9..c21db65 100644 --- a/src/compiler/meta-vmdef.lisp +++ b/src/compiler/meta-vmdef.lisp @@ -20,21 +20,17 @@ ;;;; 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 - 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 @@ -43,7 +39,7 @@ (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) @@ -87,54 +83,48 @@ (/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)) @@ -142,9 +132,9 @@ (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 @@ -210,18 +200,17 @@ (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) @@ -283,8 +272,7 @@ ;;; 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 @@ -888,7 +876,7 @@ ;;; 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) @@ -935,21 +923,21 @@ (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) @@ -1003,13 +991,13 @@ (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) @@ -1044,12 +1032,12 @@ (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)) @@ -1093,10 +1081,10 @@ (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 @@ -1216,9 +1204,9 @@ ;;;; 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) @@ -1343,7 +1331,7 @@ ;;; 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) @@ -1655,11 +1643,11 @@ ;;; 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 @@ -1670,7 +1658,7 @@ (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) @@ -1717,11 +1705,11 @@ (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) @@ -1733,20 +1721,21 @@ ,@(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))) @@ -1788,22 +1777,23 @@ `((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))) @@ -1842,13 +1832,14 @@ ;;;; 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)) @@ -1875,30 +1866,25 @@ (,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)) @@ -1931,11 +1917,9 @@ (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 diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 77eb831..d00cd22 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -255,7 +255,7 @@ (: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) @@ -617,9 +617,9 @@ 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) diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 925be97..1c600ff 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -341,10 +341,11 @@ (make-method ,main-effective-method))) main-effective-method)))))) -;;;; 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 @@ -357,52 +358,13 @@ 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 "~@" + 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 "~@" + format-control + format-arguments)) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index 9306b5b..dac7e10 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -32,15 +32,12 @@ ;;;; 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) @@ -109,10 +106,10 @@ ((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 diff --git a/version.lisp-expr b/version.lisp-expr index f32bc69..5938907 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -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.36" +"0.6.11.37" -- 1.7.10.4