X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsrctran.lisp;h=f0df2a00df58e8b6b70fe4477519260de1d777b0;hb=58084279740fc96c6ffcd14e86dca73b71b7c288;hp=124d841d6fd57d585181a76e3d8f4021d33c287e;hpb=ecad36c71e99fa4155b80af8bed38d02b9bdb83d;p=sbcl.git diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 124d841..f0df2a0 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2262,10 +2262,7 @@ (specifier-type 'base-char)) (defoptimizer (values derive-type) ((&rest values)) - (values-specifier-type - `(values ,@(mapcar (lambda (x) - (type-specifier (continuation-type x))) - values)))) + (make-values-type :required (mapcar #'continuation-type values))) ;;;; byte operations ;;;; @@ -2959,6 +2956,24 @@ #-sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.) (deftransform > ((x y) (float float) *) (ir1-transform-< y x x y '<)) + +(defun ir1-transform-char< (x y first second inverse) + (cond + ((same-leaf-ref-p x y) nil) + ;; If we had interval representation of character types, as we + ;; might eventually have to to support 2^21 characters, then here + ;; we could do some compile-time computation as in IR1-TRANSFORM-< + ;; above. -- CSR, 2003-07-01 + ((and (constant-continuation-p first) + (not (constant-continuation-p second))) + `(,inverse y x)) + (t (give-up-ir1-transform)))) + +(deftransform char< ((x y) (character character) *) + (ir1-transform-char< x y x y 'char>)) + +(deftransform char> ((x y) (character character) *) + (ir1-transform-char< y x x y 'char<)) ;;;; converting N-arg comparisons ;;;; @@ -2975,11 +2990,11 @@ ;;; negated test as appropriate. If it is a degenerate one-arg call, ;;; then we transform to code that returns true. Otherwise, we bind ;;; all the arguments and expand into a bunch of IFs. -(declaim (ftype (function (symbol list boolean) *) multi-compare)) -(defun multi-compare (predicate args not-p) +(declaim (ftype (function (symbol list boolean t) *) multi-compare)) +(defun multi-compare (predicate args not-p type) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn ,@args t)) + ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) (if not-p `(if (,predicate ,(first args) ,(second args)) nil t) @@ -2995,40 +3010,46 @@ `(if (,predicate ,current ,last) ,result nil)))) ((zerop i) - `((lambda ,vars ,result) . ,args))))))) - -(define-source-transform = (&rest args) (multi-compare '= args nil)) -(define-source-transform < (&rest args) (multi-compare '< args nil)) -(define-source-transform > (&rest args) (multi-compare '> args nil)) -(define-source-transform <= (&rest args) (multi-compare '> args t)) -(define-source-transform >= (&rest args) (multi-compare '< args t)) - -(define-source-transform char= (&rest args) (multi-compare 'char= args nil)) -(define-source-transform char< (&rest args) (multi-compare 'char< args nil)) -(define-source-transform char> (&rest args) (multi-compare 'char> args nil)) -(define-source-transform char<= (&rest args) (multi-compare 'char> args t)) -(define-source-transform char>= (&rest args) (multi-compare 'char< args t)) + `((lambda ,vars (declare (type ,type ,@vars)) ,result) + ,@args))))))) + +(define-source-transform = (&rest args) (multi-compare '= args nil 'number)) +(define-source-transform < (&rest args) (multi-compare '< args nil 'real)) +(define-source-transform > (&rest args) (multi-compare '> args nil 'real)) +(define-source-transform <= (&rest args) (multi-compare '> args t 'real)) +(define-source-transform >= (&rest args) (multi-compare '< args t 'real)) + +(define-source-transform char= (&rest args) (multi-compare 'char= args nil + 'character)) +(define-source-transform char< (&rest args) (multi-compare 'char< args nil + 'character)) +(define-source-transform char> (&rest args) (multi-compare 'char> args nil + 'character)) +(define-source-transform char<= (&rest args) (multi-compare 'char> args t + 'character)) +(define-source-transform char>= (&rest args) (multi-compare 'char< args t + 'character)) (define-source-transform char-equal (&rest args) - (multi-compare 'char-equal args nil)) + (multi-compare 'char-equal args nil 'character)) (define-source-transform char-lessp (&rest args) - (multi-compare 'char-lessp args nil)) + (multi-compare 'char-lessp args nil 'character)) (define-source-transform char-greaterp (&rest args) - (multi-compare 'char-greaterp args nil)) + (multi-compare 'char-greaterp args nil 'character)) (define-source-transform char-not-greaterp (&rest args) - (multi-compare 'char-greaterp args t)) + (multi-compare 'char-greaterp args t 'character)) (define-source-transform char-not-lessp (&rest args) - (multi-compare 'char-lessp args t)) + (multi-compare 'char-lessp args t 'character)) ;;; This function does source transformation of N-arg inequality ;;; functions such as /=. This is similar to MULTI-COMPARE in the <3 ;;; arg cases. If there are more than two args, then we expand into ;;; the appropriate n^2 comparisons only when speed is important. -(declaim (ftype (function (symbol list) *) multi-not-equal)) -(defun multi-not-equal (predicate args) +(declaim (ftype (function (symbol list t) *) multi-not-equal)) +(defun multi-not-equal (predicate args type) (let ((nargs (length args))) (cond ((< nargs 1) (values nil t)) - ((= nargs 1) `(progn ,@args t)) + ((= nargs 1) `(progn (the ,type ,@args) t)) ((= nargs 2) `(if (,predicate ,(first args) ,(second args)) nil t)) ((not (policy *lexenv* @@ -3041,24 +3062,18 @@ (next (cdr vars) (cdr next)) (result t)) ((null next) - `((lambda ,vars ,result) . ,args)) + `((lambda ,vars (declare (type ,type ,@vars)) ,result) + ,@args)) (let ((v1 (first var))) (dolist (v2 next) (setq result `(if (,predicate ,v1 ,v2) nil ,result)))))))))) -(define-source-transform /= (&rest args) (multi-not-equal '= args)) -(define-source-transform char/= (&rest args) (multi-not-equal 'char= args)) +(define-source-transform /= (&rest args) + (multi-not-equal '= args 'number)) +(define-source-transform char/= (&rest args) + (multi-not-equal 'char= args 'character)) (define-source-transform char-not-equal (&rest args) - (multi-not-equal 'char-equal args)) - -;;; FIXME: can go away once bug 194 is fixed and we can use (THE REAL X) -;;; as God intended -(defun error-not-a-real (x) - (error 'simple-type-error - :datum x - :expected-type 'real - :format-control "not a REAL: ~S" - :format-arguments (list x))) + (multi-not-equal 'char-equal args 'character)) ;;; Expand MAX and MIN into the obvious comparisons. (define-source-transform max (arg0 &rest rest)