From: Alexey Dejneka Date: Tue, 27 May 2003 08:35:52 +0000 (+0000) Subject: 0.8.0.6: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9489abab7f981b8eea2aec8a883f2eb48d4cb138;p=sbcl.git 0.8.0.6: * Walker knows about NAMED-LAMBDA; * implemented short form of VALUES type specifier. --- diff --git a/NEWS b/NEWS index c2928fa..de94c74 100644 --- a/NEWS +++ b/NEWS @@ -1774,6 +1774,7 @@ changes in sbcl-0.8.1 relative to sbcl-0.8.0: ** template selection based on unsafe type assertions (192c, 236); ** type checking in branches (194bc). * VALUES declaration is disabled. + * a short form of VALUES type specifier has ANSI meaning. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/src/code/alien-type.lisp b/src/code/alien-type.lisp index b76b3e9..86b7121 100644 --- a/src/code/alien-type.lisp +++ b/src/code/alien-type.lisp @@ -60,7 +60,7 @@ (if alien-type (let ((lisp-rep-type (compute-lisp-rep-type alien-type))) (if lisp-rep-type - (specifier-type lisp-rep-type) + (single-value-specifier-type lisp-rep-type) (%make-alien-type-type alien-type))) *universal-type*)) diff --git a/src/code/cross-type.lisp b/src/code/cross-type.lisp index 75bb1aa..557f6db 100644 --- a/src/code/cross-type.lisp +++ b/src/code/cross-type.lisp @@ -184,7 +184,7 @@ ;; we don't continue doing it after we someday patch ;; SBCL's type system so that * is no longer a type, we ;; make this assertion. -- WHN 2001-08-08 - (aver (typep (specifier-type '*) 'named-type)) + (aver (typep (values-specifier-type '*) 'named-type)) (values t t)) (;; Many simple types are guaranteed to correspond exactly ;; between any host ANSI Common Lisp and the target diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 10ac973..3a9a289 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -86,9 +86,10 @@ (defun args-types (lambda-list-like-thing) (multiple-value-bind - (required optional restp rest keyp keys allowp auxp aux) + (required optional restp rest keyp keys allowp auxp aux + morep more-context more-count llk-p) (parse-lambda-list-like-thing lambda-list-like-thing) - (declare (ignore aux)) + (declare (ignore aux morep more-context more-count)) (when auxp (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing)) (let ((required (mapcar #'single-value-specifier-type required)) @@ -110,7 +111,7 @@ (key-info)))) (multiple-value-bind (required optional rest) (canonicalize-args-type-args required optional rest) - (values required optional rest keyp keywords allowp))))) + (values required optional rest keyp keywords allowp llk-p))))) (defstruct (values-type (:include args-type @@ -145,16 +146,19 @@ (if argsp (if (eq args '*) *wild-type* - (multiple-value-bind (required optional rest keyp keywords allowp) + (multiple-value-bind (required optional rest keyp keywords allowp + llk-p) (args-types args) (declare (ignore keywords)) (when keyp (error "&KEY appeared in a VALUES type specifier ~S." `(values ,@args))) - (make-values-type :required required - :optional optional - :rest rest - :allowp allowp))) + (if llk-p + (make-values-type :required required + :optional optional + :rest rest + :allowp allowp) + (make-short-values-type required)))) (multiple-value-bind (required optional rest) (canonicalize-args-type-args required optional rest) (cond ((and (null required) @@ -436,17 +440,8 @@ ;;; A CONS-TYPE is used to represent a CONS type. (defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons))) (:constructor - ;; ANSI says that for CAR and CDR subtype - ;; specifiers '* is equivalent to T. In order - ;; to avoid special cases in SUBTYPEP and - ;; possibly elsewhere, we slam all CONS-TYPE - ;; objects into canonical form w.r.t. this - ;; equivalence at creation time. - %make-cons-type (car-raw-type - cdr-raw-type - &aux - (car-type (type-*-to-t car-raw-type)) - (cdr-type (type-*-to-t cdr-raw-type)))) + %make-cons-type (car-type + cdr-type)) (:copier nil)) ;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types) ;; @@ -454,6 +449,8 @@ (car-type (missing-arg) :type ctype :read-only t) (cdr-type (missing-arg) :type ctype :read-only t)) (defun make-cons-type (car-type cdr-type) + (aver (not (or (eq car-type *wild-type*) + (eq cdr-type *wild-type*)))) (if (or (eq car-type *empty-type*) (eq cdr-type *empty-type*)) *empty-type* @@ -517,15 +514,17 @@ ;;; never return a VALUES type. (defun specifier-type (x) (let ((res (values-specifier-type x))) - (when (values-type-p res) + (when (or (values-type-p res) + ;; bootstrap magic :-( + (and (named-type-p res) + (eq (named-type-name res) '*))) (error "VALUES type illegal in this context:~% ~S" x)) res)) (defun single-value-specifier-type (x) - (let ((res (specifier-type x))) - (if (eq res *wild-type*) - *universal-type* - res))) + (if (eq x '*) + *universal-type* + (specifier-type x))) ;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother ;;; returning a second value. @@ -547,5 +546,6 @@ (when (boundp 'sb!kernel::*values-specifier-type-cache-vector*) (values-specifier-type-cache-clear)) (values)) + (!defun-from-collected-cold-init-forms !early-type-cold-init) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index f7c6050..da44cd4 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -150,7 +150,13 @@ (error "SUBTYPEP is illegal on this type:~% ~S" (type-specifier type2))) (!define-type-method (values :unparse) (type) - (cons 'values (unparse-args-types type))) + (cons 'values + (let ((unparsed (unparse-args-types type))) + (if (or (values-type-optional type) + (values-type-rest type) + (values-type-allowp type)) + unparsed + (nconc unparsed '(&optional)))))) ;;; Return true if LIST1 and LIST2 have the same elements in the same ;;; positions according to TYPE=. We return NIL, NIL if there is an @@ -287,7 +293,7 @@ (type= (constant-type-type type1) (constant-type-type type2))) (!def-type-translator constant-arg (type) - (make-constant-type :type (specifier-type type))) + (make-constant-type :type (single-value-specifier-type type))) ;;; Return the lambda-list-like type specification corresponding ;;; to an ARGS-TYPE. @@ -972,10 +978,11 @@ (defvar *empty-type*) (defvar *universal-type*) (defvar *universal-fun-type*) + (!cold-init-forms (macrolet ((frob (name var) `(progn - (setq ,var (make-named-type :name ',name)) + (setq ,var (make-named-type :name ',name)) (setf (info :type :kind ',name) #+sb-xc-host :defined #-sb-xc-host :primitive) (setf (info :type :builtin ',name) ,var)))) @@ -2661,8 +2668,8 @@ (!define-type-class cons) (!def-type-translator cons (&optional (car-type-spec '*) (cdr-type-spec '*)) - (let ((car-type (specifier-type car-type-spec)) - (cdr-type (specifier-type cdr-type-spec))) + (let ((car-type (single-value-specifier-type car-type-spec)) + (cdr-type (single-value-specifier-type cdr-type-spec))) (make-cons-type car-type cdr-type))) (!define-type-method (cons :unparse) (type) @@ -2788,14 +2795,18 @@ (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :complexp :maybe - :element-type (specifier-type element-type)))) + :element-type (if (eq element-type '*) + *wild-type* + (specifier-type element-type))))) (!def-type-translator simple-array (&optional (element-type '*) (dimensions '*)) (specialize-array-type (make-array-type :dimensions (canonical-array-dimensions dimensions) :complexp nil - :element-type (specifier-type element-type)))) + :element-type (if (eq element-type '*) + *wild-type* + (specifier-type element-type))))) ;;;; utilities shared between cross-compiler and target system diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index f006f7d..487b619 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -639,7 +639,7 @@ (let ((type (continuation-value type))) (unless (alien-fun-type-p type) (error "Something is broken.")) - (specifier-type + (values-specifier-type (compute-alien-rep-type (alien-fun-type-result-type type))))) diff --git a/src/compiler/parse-lambda-list.lisp b/src/compiler/parse-lambda-list.lisp index a8e1283..78b4379 100644 --- a/src/compiler/parse-lambda-list.lisp +++ b/src/compiler/parse-lambda-list.lisp @@ -26,16 +26,21 @@ ;;; 9. a list of the &AUX specifiers; ;;; 10. true if a &MORE arg was specified; ;;; 11. the &MORE context var; -;;; 12. the &MORE count var. +;;; 12. the &MORE count var; +;;; 13. true if any lambda list keyword is present (only for +;;; PARSE-LAMBDA-LIST-LIKE-THING). ;;; ;;; The top level lambda list syntax is checked for validity, but the ;;; arg specifiers are just passed through untouched. If something is ;;; wrong, we use COMPILER-ERROR, aborting compilation to the last ;;; recovery point. -(declaim (ftype (function (list) - (values list list boolean t boolean list boolean - boolean list boolean t t)) - parse-lambda-list-like-thing +(declaim (ftype (sfunction (list) + (values list list boolean t boolean list boolean + boolean list boolean t t boolean)) + parse-lambda-list-like-thing)) +(declaim (ftype (sfunction (list) + (values list list boolean t boolean list boolean + boolean list boolean t t)) parse-lambda-list)) (defun parse-lambda-list-like-thing (list) (collect ((required) @@ -122,9 +127,10 @@ arg))))) (when (eq state :rest) (compiler-error "&REST without rest variable")) - + (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) - morep more-context more-count)))) + morep more-context more-count + (neq state :required))))) ;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument ;;; really *is* a lambda list, not just a "lambda-list-like thing", so diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 168d354..2ec8bc6 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -272,10 +272,8 @@ (defun source-transform-cons-typep (object type) (let* ((car-type (cons-type-car-type type)) (cdr-type (cons-type-cdr-type type))) - (let ((car-test-p (not (or (type= car-type *wild-type*) - (type= car-type (specifier-type t))))) - (cdr-test-p (not (or (type= cdr-type *wild-type*) - (type= cdr-type (specifier-type t)))))) + (let ((car-test-p (not (type= car-type *universal-type*))) + (cdr-test-p (not (type= cdr-type *universal-type*)))) (if (and (not car-test-p) (not cdr-test-p)) `(consp ,object) (once-only ((n-obj object)) diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index 39beb2e..2dbeb0c 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -397,6 +397,7 @@ ;;; SBCL-only special forms (define-walker-template sb!ext:truly-the (nil quote eval)) +(define-walker-template named-lambda walk-named-lambda) (defvar *walk-form-expand-macros-p* nil) @@ -815,6 +816,20 @@ walked-arglist walked-body)))) +(defun walk-named-lambda (form context old-env) + (walker-environment-bind (new-env old-env) + (let* ((name (second form)) + (arglist (third form)) + (body (cdddr form)) + (walked-arglist (walk-arglist arglist context new-env)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* form + (car form) + name + walked-arglist + walked-body)))) + (defun walk-setq (form context env) (if (cdddr form) (let* ((expanded (let ((rforms nil) diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 4f44164..9435118 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -589,9 +589,9 @@ `(lambda (f) (declare (optimize (speed 2) (safety ,policy1))) (multiple-value-list - (the (values (integer 2 3) t) + (the (values (integer 2 3) t &optional) (locally (declare (optimize (safety ,policy2))) - (the (values t (single-float 2f0 3f0)) + (the (values t (single-float 2f0 3f0) &optional) (funcall f))))))) (lambda () (values x y))) (type-error (error) @@ -725,10 +725,14 @@ ;;; COERCE got its own DEFOPTIMIZER which has to reimplement most of ;;; SPECIFIER-TYPE-NTH-ARG. For a while, an illegal type would throw ;;; you into the debugger on compilation. -(defun coerce-defopt (x) +(defun coerce-defopt1 (x) ;; illegal, but should be compilable. (coerce x '(values t))) -(assert (null (ignore-errors (coerce-defopt 3)))) +(defun coerce-defopt2 (x) + ;; illegal, but should be compilable. + (coerce x '(values t &optional))) +(assert (null (ignore-errors (coerce-defopt1 3)))) +(assert (null (ignore-errors (coerce-defopt2 3)))) ;;; Oops. In part of the (CATCH ..) implementation of DEBUG-RETURN, ;;; it was possible to confuse the type deriver of the compiler diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index b1b913c..841bf9a 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -400,3 +400,5 @@ :external-format '#:nonsense))) (assert (raises-error? (funcall (eval #'load) "assertoid.lisp" :external-format '#:nonsense))) + +(assert (= (the (values integer symbol) (values 1 'foo 13)) 1)) diff --git a/tests/walk.impure.lisp b/tests/walk.impure.lisp index c44c1ae..693000b 100644 --- a/tests/walk.impure.lisp +++ b/tests/walk.impure.lisp @@ -950,4 +950,8 @@ Form: NIL Context: EVAL; bound: NIL (error "Walker didn't do lexical variables of a closure properly.")))) "")) +;; old PCL hung up on it +(defmethod #:foo () + (defun #:bar ())) + (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 0d65b01..0e77a48 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.5" +"0.8.0.6"