X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-type.lisp;h=1563ca5ebbdafd91bd0d7772d72595e104b7ae91;hb=e0814eee6f6dea52db010b45a330100f2fe65832;hp=2af355cda828c101d03e9f5f707fcfcfaf2cb9c0;hpb=e9618f8ea11045b8616a49338966eac44d9c92e6;p=sbcl.git diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index 2af355c..1563ca5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -131,10 +131,10 @@ ;;; the description of a &KEY argument (defstruct (key-info #-sb-xc-host (:pure t) (:copier nil)) - ;; the key (not necessarily a keyword in ANSI) - (name (required-argument) :type symbol) + ;; the key (not necessarily a keyword in ANSI Common Lisp) + (name (missing-arg) :type symbol) ;; the type of the argument value - (type (required-argument) :type ctype)) + (type (missing-arg) :type ctype)) (!define-type-method (values :simple-subtypep :complex-subtypep-arg1) (type1 type2) @@ -192,18 +192,18 @@ ;;; a flag that we can bind to cause complex function types to be ;;; unparsed as FUNCTION. This is useful when we want a type that we ;;; can pass to TYPEP. -(defvar *unparse-function-type-simplify*) -(!cold-init-forms (setq *unparse-function-type-simplify* nil)) +(defvar *unparse-fun-type-simplify*) +(!cold-init-forms (setq *unparse-fun-type-simplify* nil)) (!define-type-method (function :unparse) (type) - (if *unparse-function-type-simplify* + (if *unparse-fun-type-simplify* 'function (list 'function - (if (function-type-wild-args type) + (if (fun-type-wild-args type) '* (unparse-args-types type)) (type-specifier - (function-type-returns type))))) + (fun-type-returns type))))) ;;; Since all function types are equivalent to FUNCTION, they are all ;;; subtypes of each other. @@ -294,10 +294,9 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (let ((res (make-function-type - :returns (values-specifier-type result)))) + (let ((res (make-fun-type :returns (values-specifier-type result)))) (if (eq args '*) - (setf (function-type-wild-args res) t) + (setf (fun-type-wild-args res) t) (parse-args-types args res)) res)) @@ -332,9 +331,9 @@ ;;; Return the minimum number of arguments that a function can be ;;; called with, and the maximum number or NIL. If not a function ;;; type, return NIL, NIL. -(defun function-type-nargs (type) +(defun fun-type-nargs (type) (declare (type ctype type)) - (if (function-type-p type) + (if (fun-type-p type) (let ((fixed (length (args-type-required type)))) (if (or (args-type-rest type) (args-type-keyp type) @@ -382,12 +381,12 @@ (defun fixed-values-op (types1 types2 rest2 operation) (declare (list types1 types2) (type ctype rest2) (type function operation)) (let ((exact t)) - (values (mapcar #'(lambda (t1 t2) - (multiple-value-bind (res win) - (funcall operation t1 t2) - (unless win - (setq exact nil)) - res)) + (values (mapcar (lambda (t1 t2) + (multiple-value-bind (res win) + (funcall operation t1 t2) + (unless win + (setq exact nil)) + res)) types1 (append types2 (make-list (- (length types1) (length types2)) @@ -875,7 +874,7 @@ (defvar *wild-type*) (defvar *empty-type*) (defvar *universal-type*) -(defvar *universal-function-type*) +(defvar *universal-fun-type*) (!cold-init-forms (macrolet ((frob (name var) `(progn @@ -891,8 +890,8 @@ (frob * *wild-type*) (frob nil *empty-type*) (frob t *universal-type*)) - (setf *universal-function-type* - (make-function-type :wild-args t + (setf *universal-fun-type* + (make-fun-type :wild-args t :returns *wild-type*))) (!define-type-method (named :simple-=) (type1 type2) @@ -1715,8 +1714,8 @@ ;; See whether dimensions are compatible. (cond ((not (or (eq dims1 '*) (eq dims2 '*) (and (= (length dims1) (length dims2)) - (every #'(lambda (x y) - (or (eq x '*) (eq y '*) (= x y))) + (every (lambda (x y) + (or (eq x '*) (eq y '*) (= x y))) dims1 dims2)))) (values nil t)) ;; See whether complexpness is compatible. @@ -1914,16 +1913,18 @@ (type=-set (intersection-type-types type1) (intersection-type-types type2))) -(flet ((intersection-complex-subtypep-arg1 (type1 type2) - (any/type (swapped-args-fun #'csubtypep) - type2 - (intersection-type-types type1)))) - (!define-type-method (intersection :simple-subtypep) (type1 type2) - (every/type #'intersection-complex-subtypep-arg1 - type1 - (intersection-type-types type2))) - (!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) - (intersection-complex-subtypep-arg1 type1 type2))) +(defun %intersection-complex-subtypep-arg1 (type1 type2) + (any/type (swapped-args-fun #'csubtypep) + type2 + (intersection-type-types type1))) + +(!define-type-method (intersection :simple-subtypep) (type1 type2) + (every/type #'%intersection-complex-subtypep-arg1 + type1 + (intersection-type-types type2))) + +(!define-type-method (intersection :complex-subtypep-arg1) (type1 type2) + (%intersection-complex-subtypep-arg1 type1 type2)) (!define-type-method (intersection :complex-subtypep-arg2) (type1 type2) (every/type #'csubtypep type1 (intersection-type-types type2))) @@ -2154,7 +2155,7 @@ ;; that an object of type FUNCTION doesn't satisfy it, so ;; we return success no matter what. t) - (;; Otherwise both of them must be FUNCTION-TYPE objects. + (;; Otherwise both of them must be FUN-TYPE objects. t ;; FIXME: For now we only check compatibility of the return ;; type, not argument types, and we don't even check the @@ -2163,11 +2164,11 @@ ;; compatibility of the arguments, we should (1) redo ;; VALUES-TYPES-EQUAL-OR-INTERSECT as ;; ARGS-TYPES-EQUAL-OR-INTERSECT, and then (2) apply it to - ;; the ARGS-TYPE slices of the FUNCTION-TYPEs. (ARGS-TYPE - ;; is a base class both of VALUES-TYPE and of FUNCTION-TYPE.) + ;; the ARGS-TYPE slices of the FUN-TYPEs. (ARGS-TYPE + ;; is a base class both of VALUES-TYPE and of FUN-TYPE.) (values-types-equal-or-intersect - (function-type-returns defined-ftype) - (function-type-returns declared-ftype)))))) + (fun-type-returns defined-ftype) + (fun-type-returns declared-ftype)))))) ;;; This messy case of CTYPE for NUMBER is shared between the ;;; cross-compiler and the target system. @@ -2187,6 +2188,15 @@ :low low :high high)))) -(!defun-from-collected-cold-init-forms !late-type-cold-init) +(locally + ;; Why SAFETY 0? To suppress the is-it-the-right-structure-type + ;; checking for declarations in structure accessors. Otherwise we + ;; can get caught in a chicken-and-egg bootstrapping problem, whose + ;; symptom on x86 OpenBSD sbcl-0.pre7.37.flaky5.22 is an illegal + ;; instruction trap. I haven't tracked it down, but I'm guessing it + ;; has to do with setting LAYOUTs when the LAYOUT hasn't been set + ;; yet. -- WHN + (declare (optimize (safety 0))) + (!defun-from-collected-cold-init-forms !late-type-cold-init)) (/show0 "late-type.lisp end of file")