From: Christophe Rhodes Date: Fri, 2 May 2003 14:56:38 +0000 (+0000) Subject: 0.8alpha.0.4: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=4d8378af498b544256340e09919758e1f88029ac;p=sbcl.git 0.8alpha.0.4: Canonicalize FUNCTION and VALUES types ... MAKE-FUN-TYPE and MAKE-VALUES-TYPE wrappers ... remove MAKE-VALUES-TYPE cache on grounds of it confusing me ... FUN-TYPE-NARGS needs to check to see if WILD-ARGS is set [e.g. for LIST, defined as (FUNCTION (&REST T) LIST), canonicalized to (FUNCTION * LIST)] Ensure that FUN-TYPES and subtypes of FUNCTION aren't treated as disjoint ... new type methods for FUNCTION :COMPLEX-{INTERSECT,UN}ION Make the MAP/%MAP transform arglist look the same as their DEFKNOWN ... not actually sure if this is necessary any more, but at one point I got very strange errors without it. Handle this one with slight care. I'm not 100% convined that it's bulletproof, though it passes tests and builds itself without complaint. --- diff --git a/NEWS b/NEWS index f7346ab..df97684 100644 --- a/NEWS +++ b/NEWS @@ -1708,6 +1708,15 @@ changes in sbcl-0.8alpha.0 relative to sbcl-0.7.14 MAKE-INSTANCE. ** :ALLOW-OTHER-KEYS NIL is now accepted in an initarg list. +changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0 + * SB-MOP:DIRECT-SLOT-DEFINITION-CLASS and + SB-MOP:EFFECTIVE-SLOT-DEFINITION-CLASS now have the + specified-by-AMOP lambda list of (CLASS &REST INITARGS). + * fixed some bugs revealed by Paul Dietz' test suite: + ** the GENERIC-FUNCTION type is no longer disjoint from FUNCTION + types. + + planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles down, maybe in 0.7.x, maybe later, it might impact TRACE. They both diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index b904176..6065f6b 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -67,23 +67,107 @@ ;; true if other &KEY arguments are allowed (allowp nil :type boolean)) +(defun canonicalize-args-type-args (required optional rest) + (when rest + (let ((last-distinct-optional (position rest optional + :from-end t + :test-not #'type=))) + (setf optional + (when last-distinct-optional + (subseq optional 0 (1+ last-distinct-optional)))))) + (values required optional rest)) + +(defun args-types (lambda-list-like-thing) + (multiple-value-bind + (required optional restp rest keyp keys allowp auxp aux) + (parse-lambda-list-like-thing lambda-list-like-thing) + (declare (ignore aux)) + (when auxp + (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing)) + (let ((required (mapcar #'single-value-specifier-type required)) + (optional (mapcar #'single-value-specifier-type optional)) + (rest (when restp (single-value-specifier-type rest))) + (keywords + (collect ((key-info)) + (dolist (key keys) + (unless (proper-list-of-length-p key 2) + (error "Keyword type description is not a two-list: ~S." key)) + (let ((kwd (first key))) + (when (find kwd (key-info) :key #'key-info-name) + (error "~@" + kwd lambda-list-like-thing)) + (key-info + (make-key-info + :name kwd + :type (single-value-specifier-type (second key)))))) + (key-info)))) + (multiple-value-bind (required optional rest) + (canonicalize-args-type-args required optional rest) + (values required optional rest keyp keywords allowp))))) + (defstruct (values-type (:include args-type (class-info (type-class-or-lose 'values))) (:constructor %make-values-type) (:copier nil))) -(define-cached-synonym make-values-type) + +(defun make-values-type (&rest initargs + &key (args nil argsp) &allow-other-keys) + (if argsp + (if (eq args '*) + *wild-type* + (multiple-value-bind (required optional rest keyp keywords allowp) + (args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + *wild-type* + (%make-values-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp)))) + (apply #'%make-values-type initargs))) (!define-type-class values) ;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes (defstruct (fun-type (:include args-type - (class-info (type-class-or-lose 'function)))) + (class-info (type-class-or-lose 'function))) + (:constructor %make-fun-type)) ;; true if the arguments are unrestrictive, i.e. * (wild-args nil :type boolean) ;; type describing the return values. This is a values type ;; when multiple values were specified for the return. (returns (missing-arg) :type ctype)) +(defun make-fun-type (&rest initargs + &key (args nil argsp) returns &allow-other-keys) + (if argsp + (if (eq args '*) + (if (eq returns *wild-type*) + (specifier-type 'function) + (%make-fun-type :wild-args t :returns returns)) + (multiple-value-bind (required optional rest keyp keywords allowp) + (args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + (if (eq returns *wild-type*) + (specifier-type 'function) + (%make-fun-type :wild-args t :returns returns)) + (%make-fun-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp + :returns returns)))) + ;; FIXME: are we really sure that we won't make something that + ;; looks like a completely wild function here? + (apply #'%make-fun-type initargs))) ;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG ;;; "type specifier", which is only meaningful in function argument diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index c8c76ea..452db2a 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -265,6 +265,18 @@ (declare (ignore type1 type2)) (specifier-type 'function)) +;;; The union or intersection of a subclass of FUNCTION with a +;;; FUNCTION type is somewhat complicated. +(!define-type-method (function :complex-intersection2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type2) + ((csubtypep type1 (specifier-type 'function)) nil) + (t :call-other-method))) +(!define-type-method (function :complex-union2) (type1 type2) + (cond + ((type= type1 (specifier-type 'function)) type1) + (t nil))) + ;;; ### Not very real, but good enough for redefining transforms ;;; according to type: (!define-type-method (function :simple-=) (type1 type2) @@ -281,37 +293,6 @@ (!def-type-translator constant-arg (type) (make-constant-type :type (specifier-type type))) -;;; Given a LAMBDA-LIST-like values type specification and an ARGS-TYPE -;;; structure, fill in the slots in the structure accordingly. This is -;;; used for both FUNCTION and VALUES types. -(declaim (ftype (function (list args-type) (values)) parse-args-types)) -(defun parse-args-types (lambda-list result) - (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) - (parse-lambda-list-like-thing lambda-list) - (declare (ignore aux)) ; since we require AUXP=NIL - (when auxp - (error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list)) - (setf (args-type-required result) - (mapcar #'single-value-specifier-type required)) - (setf (args-type-optional result) - (mapcar #'single-value-specifier-type optional)) - (setf (args-type-rest result) - (if restp (single-value-specifier-type rest) nil)) - (setf (args-type-keyp result) keyp) - (collect ((key-info)) - (dolist (key keys) - (unless (proper-list-of-length-p key 2) - (error "Keyword type description is not a two-list: ~S." key)) - (let ((kwd (first key))) - (when (find kwd (key-info) :key #'key-info-name) - (error "~@" - kwd lambda-list)) - (key-info (make-key-info :name kwd - :type (single-value-specifier-type (second key)))))) - (setf (args-type-keywords result) (key-info))) - (setf (args-type-allowp result) allowp) - (values))) - ;;; Return the lambda-list-like type specification corresponding ;;; to an ARGS-TYPE. (declaim (ftype (function (args-type) list) unparse-args-types)) @@ -342,16 +323,10 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-fun-type :returns (values-specifier-type result)))) - (if (eq args '*) - (setf (fun-type-wild-args res) t) - (parse-args-types args res)) - res)) + (make-fun-type :args args :returns (values-specifier-type result))) (!def-type-translator values (&rest values) - (let ((res (%make-values-type))) - (parse-args-types values res) - res)) + (make-values-type :args values)) ;;;; VALUES types interfaces ;;;; @@ -381,7 +356,7 @@ ;;; type, return NIL, NIL. (defun fun-type-nargs (type) (declare (type ctype type)) - (if (fun-type-p type) + (if (and (fun-type-p type) (not (fun-type-wild-args type))) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -716,14 +691,14 @@ (flet ((1way (x y) (!invoke-type-method :simple-intersection2 :complex-intersection2 x y - :default :no-type-method-found))) + :default :call-other-method))) (declare (inline 1way)) (let ((xy (1way type1 type2))) - (or (and (not (eql xy :no-type-method-found)) xy) + (or (and (not (eql xy :call-other-method)) xy) (let ((yx (1way type2 type1))) - (or (and (not (eql yx :no-type-method-found)) yx) - (cond ((and (eql xy :no-type-method-found) - (eql yx :no-type-method-found)) + (or (and (not (eql yx :call-other-method)) yx) + (cond ((and (eql xy :call-other-method) + (eql yx :call-other-method)) *empty-type*) (t (aver (and (not xy) (not yx))) ; else handled above diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index acaef21..b640f51 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -75,8 +75,8 @@ ;;; MAP is %MAP plus a check to make sure that any length specified in ;;; the result type matches the actual result. We also wrap it in a ;;; TRULY-THE for the most specific type we can determine. -(deftransform map ((result-type-arg fun &rest seqs) * * :node node) - (let* ((seq-names (make-gensym-list (length seqs))) +(deftransform map ((result-type-arg fun seq &rest seqs) * * :node node) + (let* ((seq-names (make-gensym-list (1+ (length seqs)))) (bare `(%map result-type-arg fun ,@seq-names)) (constant-result-type-arg-p (constant-continuation-p result-type-arg)) ;; what we know about the type of the result. (Note that the @@ -180,9 +180,9 @@ ;;; handle that case more efficiently, but it's left as an exercise to ;;; the reader, because the code is complicated enough already and I ;;; don't happen to need that functionality right now. -- WHN 20000410 -(deftransform %map ((result-type fun &rest seqs) * * :policy (>= speed space)) +(deftransform %map ((result-type fun seq &rest seqs) * * + :policy (>= speed space)) "open code" - (unless seqs (abort-ir1-transform "no sequence args")) (unless (constant-continuation-p result-type) (give-up-ir1-transform "RESULT-TYPE argument not constant")) (labels ( ;; 1-valued SUBTYPEP, fails unless second value of SUBTYPEP is true @@ -202,24 +202,25 @@ (t (give-up-ir1-transform "can't determine result type"))))) - (cond ((and result-type-value (= 1 (length seqs))) + (cond ((and result-type-value (null seqs)) ;; The consing arity-1 cases can be implemented ;; reasonably efficiently as function calls, and the cost ;; of consing should be significantly larger than ;; function call overhead, so we always compile these ;; cases as full calls regardless of speed-versus-space ;; optimization policy. - (cond ((subtypep 'list result-type-value) - '(apply #'%map-to-list-arity-1 fun seqs)) + (cond ((subtypep result-type-value 'list) + '(%map-to-list-arity-1 fun seq)) ( ;; (This one can be inefficient due to COERCE, but ;; the current open-coded implementation has the ;; same problem.) (subtypep result-type-value 'vector) - `(coerce (apply #'%map-to-simple-vector-arity-1 fun seqs) + `(coerce (%map-to-simple-vector-arity-1 fun seq) ',result-type-value)) (t (bug "impossible (?) sequence type")))) (t - (let* ((seq-args (make-gensym-list (length seqs)))) + (let* ((seqs (cons seq seqs)) + (seq-args (make-gensym-list (length seqs)))) (multiple-value-bind (push-dacc result) (ecase result-supertype (null (values nil nil)) diff --git a/tests/type.pure.lisp b/tests/type.pure.lisp index 557b327..b97a0e9 100644 --- a/tests/type.pure.lisp +++ b/tests/type.pure.lisp @@ -169,7 +169,6 @@ (subtypep '(function) '(function (t &rest t)))) '(nil t))) -#+nil (assert (and (subtypep 'function '(function)) (subtypep '(function) 'function))) diff --git a/version.lisp-expr b/version.lisp-expr index de64dda..b9a1adb 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.8alpha.0.3" +"0.8alpha.0.4"