** 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
(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*))
;; 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
(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))
(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
(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)
;;; 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)
;;
(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*
;;; 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.
(when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
(values-specifier-type-cache-clear))
(values))
+
\f
(!defun-from-collected-cold-init-forms !early-type-cold-init)
(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
(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.
(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))))
(!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)
(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)))))
\f
;;;; utilities shared between cross-compiler and target system
(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)))))
;;; 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)
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
(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))
;;; SBCL-only special forms
(define-walker-template sb!ext:truly-the (nil quote eval))
+(define-walker-template named-lambda walk-named-lambda)
\f
(defvar *walk-form-expand-macros-p* nil)
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)
`(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)
;;; 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))))
\f
;;; Oops. In part of the (CATCH ..) implementation of DEBUG-RETURN,
;;; it was possible to confuse the type deriver of the compiler
:external-format '#:nonsense)))
(assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
:external-format '#:nonsense)))
+
+(assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
(error "Walker didn't do lexical variables of a closure properly."))))
""))
\f
+;; old PCL hung up on it
+(defmethod #:foo ()
+ (defun #:bar ()))
+\f
(quit :unix-status 104)
;;; 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"
projects / sbcl.git / commitdiff