Newer
Older
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
(if not-p
`(if (,predicate ,(first args) ,(second args)) nil t)
(values nil t)))
(t
(do* ((i (1- nargs) (1- i))
(last nil current)
(current (gensym) (gensym))
(vars (list current) (cons current vars))
(result 't (if not-p
`(if (,predicate ,current ,last)
nil ,result)
`(if (,predicate ,current ,last)
,result nil))))
((zerop i)
`((lambda ,vars ,result) . ,args)))))))
(def-source-transform = (&rest args) (multi-compare '= args nil))
(def-source-transform < (&rest args) (multi-compare '< args nil))
(def-source-transform > (&rest args) (multi-compare '> args nil))
(def-source-transform <= (&rest args) (multi-compare '> args t))
(def-source-transform >= (&rest args) (multi-compare '< args t))
(def-source-transform char= (&rest args) (multi-compare 'char= args nil))
(def-source-transform char< (&rest args) (multi-compare 'char< args nil))
(def-source-transform char> (&rest args) (multi-compare 'char> args nil))
(def-source-transform char<= (&rest args) (multi-compare 'char> args t))
(def-source-transform char>= (&rest args) (multi-compare 'char< args t))
(def-source-transform char-equal (&rest args) (multi-compare 'char-equal args nil))
(def-source-transform char-lessp (&rest args) (multi-compare 'char-lessp args nil))
(def-source-transform char-greaterp (&rest args) (multi-compare 'char-greaterp args nil))
(def-source-transform char-not-greaterp (&rest args) (multi-compare 'char-greaterp args t))
(def-source-transform char-not-lessp (&rest args) (multi-compare 'char-lessp args t))
;;; Multi-Not-Equal -- Internal
;;;
;;; 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.
;;;
(proclaim '(function multi-not-equal (symbol list)))
(defun multi-not-equal (predicate args)
(let ((nargs (length args)))
(cond ((< nargs 1) (values nil t))
((= nargs 1) `(progn ,@args t))
((= nargs 2)
`(if (,predicate ,(first args) ,(second args)) nil t))
((not (policy nil (>= speed space) (>= speed cspeed)))
(values nil t))
(t
(collect ((vars))
(dotimes (i nargs) (vars (gensym)))
(do ((var (vars) next)
(next (cdr (vars)) (cdr next))
(result 't))
((null next)
`((lambda ,(vars) ,result) . ,args))
(let ((v1 (first var)))
(dolist (v2 next)
(setq result `(if (,predicate ,v1 ,v2) nil ,result))))))))))
(def-source-transform /= (&rest args) (multi-not-equal '= args))
(def-source-transform char/= (&rest args) (multi-not-equal 'char= args))
(def-source-transform char-not-equal (&rest args) (multi-not-equal 'char-equal args))
;;; Expand Max and Min into the obvious comparisons.
(def-source-transform max (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(max ,@more-args)))
`(if (> ,arg1 ,arg2)
,arg1 ,arg2))))
;;;
(def-source-transform min (arg &rest more-args)
(if (null more-args)
`(values ,arg)
(once-only ((arg1 arg)
(arg2 `(min ,@more-args)))
`(if (< ,arg1 ,arg2)
,arg1 ,arg2))))
;;;; Converting N-arg arithmetic functions:
;;;
;;; N-arg arithmetic and logic functions are associated into two-arg
;;; versions, and degenerate cases are flushed.
;;; Associate-Arguments -- Internal
;;;
;;; Left-associate First-Arg and More-Args using Function.
;;;
(proclaim '(function associate-arguments (symbol t list) list))
(defun associate-arguments (function first-arg more-args)
(let ((next (rest more-args))
(arg (first more-args)))
(if (null next)
`(,function ,first-arg ,arg)
(associate-arguments function `(,function ,first-arg ,arg) next))))
;;; Source-Transform-Transitive -- Internal
;;;
;;; Do source transformations for transitive functions such as +. One-arg
;;; cases are replaced with the arg and zero arg cases with the identity. If
;;; Leaf-Fun is true, then replace two-arg calls with a call to that function.
;;;
(defun source-transform-transitive (fun args identity &optional leaf-fun)
(declare (symbol fun leaf-fun) (list args))
(case (length args)
(0 identity)
(1 `(values ,(first args)))
(2 (if leaf-fun
`(,leaf-fun ,(first args) ,(second args))
(values nil t)))
(t
(associate-arguments fun (first args) (rest args)))))
(def-source-transform + (&rest args) (source-transform-transitive '+ args 0))
(def-source-transform * (&rest args) (source-transform-transitive '* args 1))
(def-source-transform logior (&rest args) (source-transform-transitive 'logior args 0))
(def-source-transform logxor (&rest args) (source-transform-transitive 'logxor args 0))
(def-source-transform logand (&rest args) (source-transform-transitive 'logand args -1))
(if (evenp (length args))
`(lognot (logxor ,@args))
`(logxor ,@args)))
;;; Note: we can't use source-transform-transitive for GCD and LCM because when
;;; they are given one argument, they return it's absolute value.
(def-source-transform gcd (&rest args)
(case (length args)
(0 0)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'gcd (first args) (rest args)))))
(def-source-transform lcm (&rest args)
(case (length args)
(0 1)
(1 `(abs (the integer ,(first args))))
(2 (values nil t))
(t (associate-arguments 'lcm (first args) (rest args)))))
;;; Source-Transform-Intransitive -- Internal
;;;
;;; Do source transformations for intransitive n-arg functions such as /.
;;; With one arg, we form the inverse. With two args we pass. Otherwise we
;;; associate into two-arg calls.
;;;
(proclaim '(function source-transform-intransitive (symbol list t) list))
(defun source-transform-intransitive (function args inverse)
(1 `(,@inverse ,(first args)))
(t
(associate-arguments function (first args) (rest args)))))
(def-source-transform - (&rest args)
(source-transform-intransitive '- args '(%negate)))
(def-source-transform / (&rest args)
(source-transform-intransitive '/ args '(/ 1)))
;;;; Apply:
;;;
;;; We convert Apply into Multiple-Value-Call so that the compiler only
;;; needs to understand one kind of variable-argument call. It is more
;;; efficient to convert Apply to MV-Call than MV-Call to Apply.
(def-source-transform apply (fun arg &rest more-args)
(let ((args (cons arg more-args)))
`(multiple-value-call ,fun
,@(mapcar #'(lambda (x)
`(values ,x))
(butlast args))
(values-list ,(car (last args))))))
;;;; FORMAT transform:
;;;
;;; If the control string is a compile-time constant, then replace it with
;;; a use of the FORMATTER macro so that the control string is ``compiled.''
;;; Furthermore, if the destination is either a stream or T and the control
;;; string is a function (i.e. formatter), then convert the call to format to
;;; just a funcall of that function.
;;;
(deftransform format ((dest control &rest args) (t simple-string &rest t) *
:policy (> speed space))
(unless (constant-continuation-p control)
(give-up "Control string is not a constant."))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) 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))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (stream control ,@arg-names)
(funcall control stream ,@arg-names)
nil)))
;;;
(deftransform format ((tee control &rest args) ((member t) function &rest t) *
:policy (> speed space))
(let ((arg-names (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) args)))
`(lambda (tee control ,@arg-names)
(declare (ignore tee))
(funcall control *standard-output* ,@arg-names)
nil)))