X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=478e5785e048a265bf7e48aa1b6ba1306df2c3a4;hb=c7de1989d006e0b3a4f26143b7a81c9bdb754101;hp=c59ab7c868b698e325bb0db1330fc37d2eee13b4;hpb=77af6d16968262049d6dadfb5521af7a8a7c6868;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index c59ab7c..478e578 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -1001,41 +1001,41 @@ ;;; a function. ;;; ;;; Given the continuation ARG, derive the resulting type using the -;;; DERIVE-FCN. DERIVE-FCN takes exactly one argument which is some +;;; DERIVE-FUN. DERIVE-FUN takes exactly one argument which is some ;;; "atomic" continuation type like numeric-type or member-type ;;; (containing just one element). It should return the resulting ;;; type, which can be a list of types. ;;; -;;; For the case of member types, if a member-fcn is given it is +;;; For the case of member types, if a MEMBER-FUN is given it is ;;; called to compute the result otherwise the member type is first -;;; converted to a numeric type and the derive-fcn is call. -(defun one-arg-derive-type (arg derive-fcn member-fcn +;;; converted to a numeric type and the DERIVE-FUN is called. +(defun one-arg-derive-type (arg derive-fun member-fun &optional (convert-type t)) - (declare (type function derive-fcn) - (type (or null function) member-fcn)) + (declare (type function derive-fun) + (type (or null function) member-fun)) (let ((arg-list (prepare-arg-for-derive-type (continuation-type arg)))) (when arg-list (flet ((deriver (x) (typecase x (member-type - (if member-fcn + (if member-fun (with-float-traps-masked (:underflow :overflow :divide-by-zero) (make-member-type :members (list - (funcall member-fcn + (funcall member-fun (first (member-type-members x)))))) ;; Otherwise convert to a numeric type. (let ((result-type-list - (funcall derive-fcn (convert-member-type x)))) + (funcall derive-fun (convert-member-type x)))) (if convert-type (convert-back-numeric-type-list result-type-list) result-type-list)))) (numeric-type (if convert-type (convert-back-numeric-type-list - (funcall derive-fcn (convert-numeric-type x))) - (funcall derive-fcn x))) + (funcall derive-fun (convert-numeric-type x))) + (funcall derive-fun x))) (t *universal-type*)))) ;; Run down the list of args and derive the type of each one, @@ -1051,14 +1051,14 @@ (first results))))))) ;;; Same as ONE-ARG-DERIVE-TYPE, except we assume the function takes -;;; two arguments. DERIVE-FCN takes 3 args in this case: the two +;;; two arguments. DERIVE-FUN takes 3 args in this case: the two ;;; original args and a third which is T to indicate if the two args ;;; really represent the same continuation. This is useful for ;;; deriving the type of things like (* x x), which should always be ;;; positive. If we didn't do this, we wouldn't be able to tell. -(defun two-arg-derive-type (arg1 arg2 derive-fcn fcn +(defun two-arg-derive-type (arg1 arg2 derive-fun fun &optional (convert-type t)) - (declare (type function derive-fcn fcn)) + (declare (type function derive-fun fun)) (flet ((deriver (x y same-arg) (cond ((and (member-type-p x) (member-type-p y)) (let* ((x (first (member-type-members x))) @@ -1066,7 +1066,7 @@ (result (with-float-traps-masked (:underflow :overflow :divide-by-zero :invalid) - (funcall fcn x y)))) + (funcall fun x y)))) (cond ((null result)) ((and (floatp result) (float-nan-p result)) (make-numeric-type :class 'float @@ -1077,21 +1077,21 @@ ((and (member-type-p x) (numeric-type-p y)) (let* ((x (convert-member-type x)) (y (if convert-type (convert-numeric-type y) y)) - (result (funcall derive-fcn x y same-arg))) + (result (funcall derive-fun x y same-arg))) (if convert-type (convert-back-numeric-type-list result) result))) ((and (numeric-type-p x) (member-type-p y)) (let* ((x (if convert-type (convert-numeric-type x) x)) (y (convert-member-type y)) - (result (funcall derive-fcn x y same-arg))) + (result (funcall derive-fun x y same-arg))) (if convert-type (convert-back-numeric-type-list result) result))) ((and (numeric-type-p x) (numeric-type-p y)) (let* ((x (if convert-type (convert-numeric-type x) x)) (y (if convert-type (convert-numeric-type y) y)) - (result (funcall derive-fcn x y same-arg))) + (result (funcall derive-fun x y same-arg))) (if convert-type (convert-back-numeric-type-list result) result))) @@ -2226,10 +2226,10 @@ (t (specifier-type 'integer)))))) -(macrolet ((deffrob (logfcn) - (let ((fcn-aux (symbolicate logfcn "-DERIVE-TYPE-AUX"))) - `(defoptimizer (,logfcn derive-type) ((x y)) - (two-arg-derive-type x y #',fcn-aux #',logfcn))))) +(macrolet ((deffrob (logfun) + (let ((fun-aux (symbolicate logfun "-DERIVE-TYPE-AUX"))) + `(defoptimizer (,logfun derive-type) ((x y)) + (two-arg-derive-type x y #',fun-aux #',logfun))))) (deffrob logand) (deffrob logior) (deffrob logxor)) @@ -3314,21 +3314,20 @@ "Too many arguments (~D) to ~S ~S: uses at most ~D." nargs fun string max))))))) -(deftransform format ((dest control &rest args) (t simple-string &rest t) * - :node node) +(defoptimizer (format optimizer) ((dest control &rest args)) + (when (constant-continuation-p control) + (let ((x (continuation-value control))) + (when (stringp x) + (check-format-args x args 'format))))) - (cond - ((policy node (> speed space)) - (unless (constant-continuation-p control) - (give-up-ir1-transform "The control string is not a constant.")) - (check-format-args (continuation-value control) args 'format) - (let ((arg-names (make-gensym-list (length args)))) - `(lambda (dest control ,@arg-names) - (declare (ignore control)) - (format dest (formatter ,(continuation-value control)) ,@arg-names)))) - (t (when (constant-continuation-p control) - (check-format-args (continuation-value control) args 'format)) - (give-up-ir1-transform)))) +(deftransform format ((dest control &rest args) (t simple-string &rest t) * + :policy (> speed space)) + (unless (constant-continuation-p control) + (give-up-ir1-transform "The control string is not a constant.")) + (let ((arg-names (make-gensym-list (length args)))) + `(lambda (dest control ,@arg-names) + (declare (ignore control)) + (format dest (formatter ,(continuation-value control)) ,@arg-names)))) (deftransform format ((stream control &rest args) (stream function &rest t) * :policy (> speed space)) @@ -3347,11 +3346,11 @@ (macrolet ((def (name) - `(deftransform ,name - ((control &rest args) (simple-string &rest t) *) + `(defoptimizer (,name optimizer) ((control &rest args)) (when (constant-continuation-p control) - (check-format-args (continuation-value control) args ',name)) - (give-up-ir1-transform)))) + (let ((x (continuation-value control))) + (when (stringp x) + (check-format-args x args ',name))))))) (def error) (def warn) #+sb-xc-host ; Only we should be using these @@ -3365,39 +3364,39 @@ (def maybe-compiler-notify) (def bug))) -(deftransform cerror ((report control &rest args) - (simple-string simple-string &rest t) *) - (unless (and (constant-continuation-p control) - (constant-continuation-p report)) - (give-up-ir1-transform)) - (multiple-value-bind (min1 max1) - (handler-case (sb!format:%compiler-walk-format-string - (continuation-value control) args) - (sb!format:format-error (c) - (compiler-warn "~A" c))) - (when min1 - (multiple-value-bind (min2 max2) - (handler-case (sb!format:%compiler-walk-format-string - (continuation-value report) args) - (sb!format:format-error (c) - (compiler-warn "~A" c))) - (when min2 - (let ((nargs (length args))) - (cond - ((< nargs (min min1 min2)) - (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~ - requires at least ~D." - nargs 'cerror report control (min min1 min2))) - ((> nargs (max max1 max2)) - (;; to get warned about probably bogus code at - ;; cross-compile time. - #+sb-xc-host compiler-warn - ;; ANSI saith that too many arguments doesn't cause a - ;; run-time error. - #-sb-xc-host compiler-style-warn - "Too many arguments (~D) to ~S ~S ~S: uses at most ~D." - nargs 'cerror report control (max max1 max2))))))))) - (give-up-ir1-transform)) +(defoptimizer (cerror optimizer) ((report control &rest args)) + (when (and (constant-continuation-p control) + (constant-continuation-p report)) + (let ((x (continuation-value control)) + (y (continuation-value report))) + (when (and (stringp x) (stringp y)) + (multiple-value-bind (min1 max1) + (handler-case + (sb!format:%compiler-walk-format-string x args) + (sb!format:format-error (c) + (compiler-warn "~A" c))) + (when min1 + (multiple-value-bind (min2 max2) + (handler-case + (sb!format:%compiler-walk-format-string y args) + (sb!format:format-error (c) + (compiler-warn "~A" c))) + (when min2 + (let ((nargs (length args))) + (cond + ((< nargs (min min1 min2)) + (compiler-warn "Too few arguments (~D) to ~S ~S ~S: ~ + requires at least ~D." + nargs 'cerror y x (min min1 min2))) + ((> nargs (max max1 max2)) + (;; to get warned about probably bogus code at + ;; cross-compile time. + #+sb-xc-host compiler-warn + ;; ANSI saith that too many arguments doesn't cause a + ;; run-time error. + #-sb-xc-host compiler-style-warn + "Too many arguments (~D) to ~S ~S ~S: uses at most ~D." + nargs 'cerror y x (max max1 max2))))))))))))) (defoptimizer (coerce derive-type) ((value type)) (cond @@ -3678,5 +3677,5 @@ (format t "/(CONTINUATION-VALUE X)=~S~%" (continuation-value x))) (format t "/MESSAGE=~S~%" (continuation-value message)) (give-up-ir1-transform "not a real transform")) - (defun /report-continuation (&rest rest) - (declare (ignore rest)))) + (defun /report-continuation (x message) + (declare (ignore x message))))