From 3893e84021b2466d34e44e97340b96c6325a4b8d Mon Sep 17 00:00:00 2001 From: "Tobias C. Rittweiler" Date: Thu, 11 Feb 2010 18:11:20 +0000 Subject: [PATCH] 1.0.35.11: Minor cleanup in MAKE-FUN-TYPE / MAKE-VALUES-TYPE * MAKE-FUN-TYPE and MAKE-VALUES-TYPE took an :ARGS key parameter to translate from a list type-specifier to a ctype. This was used in the type-translators for FUNCTION and VALUES, only. So I removed :ARGS, and put that code into those type-translators. * Renamed ARGS-TYPES helper function to PARSE-ARGS-TYPES. --- src/code/early-type.lisp | 81 +++++++++++----------------------------------- src/code/late-type.lisp | 39 ++++++++++++++++++++-- version.lisp-expr | 2 +- 3 files changed, 56 insertions(+), 66 deletions(-) diff --git a/src/code/early-type.lisp b/src/code/early-type.lisp index 4ad4966..7d5a14c 100644 --- a/src/code/early-type.lisp +++ b/src/code/early-type.lisp @@ -81,7 +81,7 @@ (subseq optional 0 (1+ last-not-rest)))) rest)))) -(defun args-types (lambda-list-like-thing) +(defun parse-args-types (lambda-list-like-thing) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count llk-p) @@ -136,34 +136,17 @@ :rest rest :allowp allowp)) -(defun make-values-type (&key (args nil argsp) - required optional rest allowp) - (if argsp - (if (eq args '*) - *wild-type* - (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))) - (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) - (null optional) - (eq rest *universal-type*)) - *wild-type*) - ((memq *empty-type* required) - *empty-type*) - (t (make-values-type-cached required optional - rest allowp)))))) +(defun make-values-type (&key required optional rest allowp) + (multiple-value-bind (required optional rest) + (canonicalize-args-type-args required optional rest) + (cond ((and (null required) + (null optional) + (eq rest *universal-type*)) + *wild-type*) + ((memq *empty-type* required) + *empty-type*) + (t (make-values-type-cached required optional + rest allowp))))) (!define-type-class values) @@ -171,44 +154,18 @@ (defstruct (fun-type (:include args-type (class-info (type-class-or-lose 'function))) (:constructor - %make-fun-type (&key required optional rest - keyp keywords allowp - wild-args - returns - &aux (rest (if (eq rest *empty-type*) - nil - rest))))) + make-fun-type (&key required optional rest + keyp keywords allowp + wild-args + returns + &aux (rest (if (eq rest *empty-type*) + nil + rest))))) ;; 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 695b27a..190c42b 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -358,11 +358,44 @@ (result))) (!def-type-translator function (&optional (args '*) (result '*)) - (make-fun-type :args args - :returns (coerce-to-values (values-specifier-type result)))) + (let ((result (coerce-to-values (values-specifier-type result)))) + (if (eq args '*) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (multiple-value-bind (required optional rest keyp keywords allowp) + (parse-args-types args) + (if (and (null required) + (null optional) + (eq rest *universal-type*) + (not keyp)) + (if (eq result *wild-type*) + (specifier-type 'function) + (make-fun-type :wild-args t :returns result)) + (make-fun-type :required required + :optional optional + :rest rest + :keyp keyp + :keywords keywords + :allowp allowp + :returns result)))))) (!def-type-translator values (&rest values) - (make-values-type :args values)) + (if (eq values '*) + *wild-type* + (multiple-value-bind (required optional rest keyp keywords allowp llk-p) + (parse-args-types values) + (declare (ignore keywords)) + (cond (keyp + (error "&KEY appeared in a VALUES type specifier ~S." + `(values ,@values))) + (llk-p + (make-values-type :required required + :optional optional + :rest rest + :allowp allowp)) + (t + (make-short-values-type required)))))) ;;;; VALUES types interfaces ;;;; diff --git a/version.lisp-expr b/version.lisp-expr index d54e0a9..3b50987 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".) -"1.0.35.10" +"1.0.35.11" -- 1.7.10.4