From: Christophe Rhodes Date: Fri, 30 May 2003 10:44:10 +0000 (+0000) Subject: 0.8.0.19: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c5df202d52732a0dea8dc3558954a729073b7970;p=sbcl.git 0.8.0.19: No-one's complained, so merge CSR patch "Type checking on global variables" (sbcl-devel 2003-05-27) ... fix SB-XC:PROCLAIM to queue up TYPE and FTYPE proclamations when the system isn't initialized, and then reproclaim them later; ... fix EVAL to punt to the compiler if there's a type proclamation for FOO in (SETQ FOO ...); ... proclaim the types of the various CL:*FOO* variables, according to the CLHS; ... fix two instances of undefined behaviour in the test suite. :-) --- diff --git a/NEWS b/NEWS index fdd18c9..fb780f3 100644 --- a/NEWS +++ b/NEWS @@ -1772,6 +1772,10 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: * minor incompatible change: some nonsensical specialized lambda lists (used in DEFMETHOD) which were previously ignored now signal errors. + * minor incompatible change: the system is now aware of the types of + variables in the COMMON-LISP package, and will signal errors for + most violations of these type constraints (where previously they + were silently accepted). * changes in type checking closed the following bugs: ** type checking of unused values (192b, 194d, 203); ** template selection based on unsafe type assertions (192c, 236); diff --git a/build-order.lisp-expr b/build-order.lisp-expr index ed67fe2..7157f6a 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -649,6 +649,10 @@ ;; DEFVAR or DEFPARAMETER. ("src/code/cl-specials") + ;; FIXME: here? earlier? can probably be as late as possible. Also + ;; maybe call it FORCE-DELAYED-PROCLAIMS? + ("src/compiler/late-proclaim") + ;; fundamental target macros (e.g. CL:DO and CL:DEFUN) and support ;; for them ("src/code/defboot") diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 63ba1ba..2429763 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1393,6 +1393,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "!PACKAGE-COLD-INIT" "SIGNAL-COLD-INIT-OR-REINIT" "!POLICY-COLD-INIT-OR-RESANIFY" "!VM-TYPE-COLD-INIT" "!BACKQ-COLD-INIT" "!SHARPM-COLD-INIT" + "!EARLY-PROCLAIM-COLD-INIT" "!LATE-PROCLAIM-COLD-INIT" "!CLASS-FINALIZE" "GC-REINIT" ;; Note: These are out of lexicographical order because in CMU CL diff --git a/src/code/cl-specials.lisp b/src/code/cl-specials.lisp index ec7494a..7b51118 100644 --- a/src/code/cl-specials.lisp +++ b/src/code/cl-specials.lisp @@ -66,3 +66,70 @@ cl:/ cl:// cl:///)) + +(sb!xc:proclaim '(type t cl:+ cl:++ cl:+++ cl:- cl:* cl:** cl:***)) + +;;; generalized booleans +(sb!xc:proclaim '(type t cl:*compile-print* cl:*compile-verbose* + cl:*load-print* cl:*load-verbose* + cl:*print-array* cl:*print-radix* + cl:*print-circle* cl:*print-escape* + cl:*print-gensym* cl:*print-pretty* + cl:*print-readably* cl:*read-eval* + cl:*read-suppress*)) + +(sb!xc:proclaim '(type sb!pretty::pprint-dispatch-table + cl:*print-pprint-dispatch*)) + +(sb!xc:proclaim '(type readtable cl:*readtable*)) + +(sb!xc:proclaim '(type (integer 2 36) cl:*print-base* cl:*read-base*)) + +(sb!xc:proclaim '(type (member :upcase :downcase :capitalize) cl:*print-case*)) + +(sb!xc:proclaim '(type (member cl:single-float cl:double-float + cl:short-float cl:long-float) cl:*read-default-float-format*)) + +(sb!xc:proclaim '(type list cl:/ cl:// cl:/// cl:*features* cl:*modules*)) + +(sb!xc:proclaim '(type sb!kernel:type-specifier cl:*break-on-signals*)) + +(sb!xc:proclaim '(type package cl:*package*)) + +(sb!xc:proclaim '(type random-state cl:*random-state*)) + +;; KLUDGE: some of these are more specific than just STREAM. However, +;; (a) we can't express that portably, and (b) we probably violate +;; these requirements somewhere as of sbcl-0.8.0. (and maybe we break +;; even this in Gray streams or simple-streams? apparently not, +;; currently) +(sb!xc:proclaim '(type stream + cl:*standard-input* + cl:*error-output* + cl:*standard-output* + cl:*trace-output* + cl:*debug-io* + cl:*query-io* + cl:*terminal-io*)) + +;;; FIXME: make an SB!INT:FUNCTION-DESIGNATOR type for these +(sb!xc:proclaim '(type (or function symbol cons) + cl:*debugger-hook* + cl:*macroexpand-hook*)) + +(sb!xc:proclaim '(type unsigned-byte cl:*gensym-counter*)) + +(sb!xc:proclaim '(type (or unsigned-byte null) + cl:*print-length* + cl:*print-level* + cl:*print-lines* + cl:*print-miser-width* + cl:*print-right-margin*)) + +(sb!xc:proclaim '(type pathname cl:*default-pathname-defaults*)) + +(sb!xc:proclaim '(type (or pathname null) + cl:*load-pathname* + cl:*load-truename* + cl:*compile-file-pathname* + cl:*compile-file-truename*)) diff --git a/src/code/cold-init.lisp b/src/code/cold-init.lisp index acf20fb..cb4c684 100644 --- a/src/code/cold-init.lisp +++ b/src/code/cold-init.lisp @@ -142,6 +142,8 @@ (show-and-call !policy-cold-init-or-resanify) (/show0 "back from !POLICY-COLD-INIT-OR-RESANIFY") + (show-and-call !early-proclaim-cold-init) + ;; KLUDGE: Why are fixups mixed up with toplevel forms? Couldn't ;; fixups be done separately? Wouldn't that be clearer and better? ;; -- WHN 19991204 @@ -202,6 +204,9 @@ ;; DEFTYPEs are. (setf *type-system-initialized* t) + ;; run the PROCLAIMs. + (show-and-call !late-proclaim-cold-init) + (show-and-call os-cold-init-or-reinit) (show-and-call stream-cold-init-or-reset) diff --git a/src/code/eval.lisp b/src/code/eval.lisp index b81bd7c..4c350e4 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -21,8 +21,7 @@ ;; evaluations/compilations, though [e.g. the ignored variable in ;; (DEFUN FOO (X) 1)]. -- CSR, 2003-05-13 (let ((fun (sb!c:compile-in-lexenv (gensym "EVAL-TMPFUN-") - `(lambda () - ,expr) + `(lambda () ,expr) lexenv))) (funcall fun))) @@ -122,13 +121,12 @@ (set (first args) (eval (second args))))) (let ((symbol (first name))) (case (info :variable :kind symbol) - ;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE* - ;; test here, and removed the - ;; *TOPLEVEL-AUTO-DECLARE* variable; the code - ;; should now act as though that variable is - ;; NIL. This should be tested.. (:special) - (t (return (%eval original-exp lexenv)))))))) + (t (return (%eval original-exp lexenv)))) + (unless (type= (info :variable :type symbol) + *universal-type*) + ;; let the compiler deal with type checking + (return (%eval original-exp lexenv))))))) ((progn) (eval-progn-body (rest exp) lexenv)) ((eval-when) diff --git a/src/code/print.lisp b/src/code/print.lisp index a6539ee..48889e5 100644 --- a/src/code/print.lisp +++ b/src/code/print.lisp @@ -66,9 +66,10 @@ is less than this, then print using ``miser-style'' output. Miser style conditional newlines are turned on, and all indentations are turned off. If NIL, never use miser mode.") -(defvar *print-pprint-dispatch* nil - #!+sb-doc - "the pprint-dispatch-table that controls how to pretty-print objects") +(defvar *print-pprint-dispatch*) +#!+sb-doc +(setf (fdocumentation '*print-pprint-dispatch* 'variable) + "the pprint-dispatch-table that controls how to pretty-print objects") (defmacro with-standard-io-syntax (&body body) #!+sb-doc diff --git a/src/compiler/late-proclaim.lisp b/src/compiler/late-proclaim.lisp new file mode 100644 index 0000000..7578040 --- /dev/null +++ b/src/compiler/late-proclaim.lisp @@ -0,0 +1,27 @@ +;;;; late happenning functionality for PROCLAIM. We run through +;;;; queued-up type and ftype proclaims that were made before the type +;;;; system was initialized, and (since it is now initalized) +;;;; reproclaim them. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!C") + +(!begin-collecting-cold-init-forms) + +(!cold-init-forms (aver *type-system-initialized*)) +(!cold-init-forms (mapcar #'sb!xc:proclaim *queued-proclaims*)) +;;; We only need this once, then it's set up for good. We keep it +;;; around in the cross-compiler mostly so that we can inspect its +;;; value. +#-sb-xc-host +(!cold-init-forms (makunbound '*queued-proclaims*)) + +(!defun-from-collected-cold-init-forms !late-proclaim-cold-init) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index a7d1ff7..89af8fb 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -80,6 +80,10 @@ (t decl-spec))))) +(!begin-collecting-cold-init-forms) +(!cold-init-forms (defvar *queued-proclaims* nil)) +(!defun-from-collected-cold-init-forms !early-proclaim-cold-init) + (defun sb!xc:proclaim (raw-form) #+sb-xc (/show0 "entering PROCLAIM, RAW-FORM=..") #+sb-xc (/hexstr raw-form) @@ -96,50 +100,40 @@ (clear-info :variable :constant-value name) (setf (info :variable :kind name) :special))) (type - (when *type-system-initialized* - (let ((type (specifier-type (first args)))) - (dolist (name (rest args)) - (unless (symbolp name) - (error "can't declare TYPE of a non-symbol: ~S" name)) - (when (eq (info :variable :where-from name) :declared) - (let ((old-type (info :variable :type name))) - (when (type/= type old-type) - (style-warn "The new TYPE proclamation~% ~S~@ - for ~S does not match the old TYPE~@ - proclamation ~S" - type name old-type)))) - (setf (info :variable :type name) type) - (setf (info :variable :where-from name) :declared))))) + (if *type-system-initialized* + (let ((type (specifier-type (first args)))) + (dolist (name (rest args)) + (unless (symbolp name) + (error "can't declare TYPE of a non-symbol: ~S" name)) + (when (eq (info :variable :where-from name) :declared) + (let ((old-type (info :variable :type name))) + (when (type/= type old-type) + (style-warn "The new TYPE proclamation~% ~S~@ + for ~S does not match the old TYPE~@ + proclamation ~S" + type name old-type)))) + (setf (info :variable :type name) type) + (setf (info :variable :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (ftype - ;; FIXME: Since currently *TYPE-SYSTEM-INITIALIZED* is not set - ;; until many toplevel forms have run, this condition on - ;; PROCLAIM (FTYPE ..) (and on PROCLAIM (TYPE ..), above) means - ;; that valid PROCLAIMs in cold code could get lost. Probably - ;; the cleanest way to deal with this would be to initialize - ;; the type system completely in special cold init forms, - ;; before any ordinary toplevel forms run. Failing that, we - ;; could queue up PROCLAIMs to be done after the type system is - ;; initialized. Failing that, we could at least issue a warning - ;; when we have to ignore a PROCLAIM because the type system is - ;; uninitialized. - (when *type-system-initialized* - (let ((ctype (specifier-type (first args)))) - (unless (csubtypep ctype (specifier-type 'function)) - (error "not a function type: ~S" (first args))) - (dolist (name (rest args)) - - ;; KLUDGE: Something like the commented-out TYPE/= - ;; check here would be nice, but it has been - ;; commented out because TYPE/= doesn't support - ;; function types. It could probably be made to do - ;; so, but it might take some time, since function - ;; types involve values types, which aren't - ;; supported, and since the SUBTYPEP operator for - ;; FUNCTION types is rather broken, e.g. - ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL) - ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T - ;; -- WHN 20000229 - #| + (if *type-system-initialized* + (let ((ctype (specifier-type (first args)))) + (unless (csubtypep ctype (specifier-type 'function)) + (error "not a function type: ~S" (first args))) + (dolist (name (rest args)) + + ;; KLUDGE: Something like the commented-out TYPE/= + ;; check here would be nice, but it has been + ;; commented out because TYPE/= doesn't support + ;; function types. It could probably be made to do + ;; so, but it might take some time, since function + ;; types involve values types, which aren't + ;; supported, and since the SUBTYPEP operator for + ;; FUNCTION types is rather broken, e.g. + ;; (SUBTYPEP '(FUNCTION (T BOOLEAN) NIL) + ;; '(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T + ;; -- WHN 20000229 + #| (when (eq (info :function :where-from name) :declared) (let ((old-type (info :function :type name))) (when (type/= ctype old-type) @@ -149,20 +143,21 @@ for ~S does not match old FTYPE proclamation~@ ~S" (list ctype name old-type))))) - |# + |# - ;; Now references to this function shouldn't be warned - ;; about as undefined, since even if we haven't seen a - ;; definition yet, we know one is planned. - ;; - ;; Other consequences of we-know-you're-a-function-now - ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. - (proclaim-as-fun-name name) - (note-name-defined name :function) + ;; Now references to this function shouldn't be warned + ;; about as undefined, since even if we haven't seen a + ;; definition yet, we know one is planned. + ;; + ;; Other consequences of we-know-you're-a-function-now + ;; are appropriate too, e.g. any MACRO-FUNCTION goes away. + (proclaim-as-fun-name name) + (note-name-defined name :function) - ;; the actual type declaration - (setf (info :function :type name) ctype - (info :function :where-from name) :declared))))) + ;; the actual type declaration + (setf (info :function :type name) ctype + (info :function :where-from name) :declared))) + (push raw-form *queued-proclaims*))) (freeze-type (dolist (type args) (let ((class (specifier-type type))) diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 841bf9a..5691e98 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -326,8 +326,8 @@ (loop for (fun warns-p) in '(((lambda (&optional *x*) *x*) t) ((lambda (&optional *x* &rest y) (values *x* y)) t) - ((lambda (&optional *print-base*) (values *print-base*)) nil) - ((lambda (&optional *print-base* &rest y) (values *print-base* y)) nil) + ((lambda (&optional *print-length*) (values *print-length*)) nil) + ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil) ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil) ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil)) for real-warns-p = (nth-value 1 (compile nil fun)) diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 68420b1..f7f3d14 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -48,10 +48,10 @@ ;;; This was a bug in SBCL until 0.6.12.40 (originally reported as a ;;; CMU CL bug by Erik Naggum on comp.lang.lisp). -(loop for *print-base* from 2 to 36 +(loop for base from 2 to 36 with *print-radix* = t - do - (assert (string= "#*101" (format nil "~S" #*101)))) + do (let ((*print-base* base)) + (assert (string= "#*101" (format nil "~S" #*101))))) ;;; bug in sbcl-0.7.1.25, reported by DB sbcl-devel 2002-02-25 (assert (string= "0.5" (format nil "~2D" 0.5))) diff --git a/version.lisp-expr b/version.lisp-expr index 8e3fefc..225ebae 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.0.18" +"0.8.0.19"