;;; This is a -*-Lisp-*- file.
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;; Source-level transforms for the Common Lisp Cross Compiler. These
;;; transforms work like macros, but are only used when compiling.
;;; Written by Scott Fahlman, Dave Dill, Skef Wholey, et al.
;;; Currently maintained by Scott Fahlman.
;;; See also the files MACROS.SLISP (true built-in macros in Common Lisp),
;;; SEQTRAN.SLISP (efficiency transforms for sequence and list functions),
;;; and TYPETRAN.SLISP (implementation-specific transforms for type
;;; predicates).
;;; **********************************************************************
;;;; SETQ AND FRIENDS.
;;; Turn any multiple SETQ forms into a progn of individual SETQs.
;;; Setq of 0 pairs is legal, and returns NIL.
(deftransform setq setq-transform (&rest pairs)
(let ((n (length pairs)))
(cond ((zerop n) nil)
((= n 2)
(test-varname (car pairs))
'%pass%)
((oddp n)
(clc-error "Odd number of args to SETQ.")
nil)
(t (do ((m pairs (cddr m))
(l nil))
((null m)
`(progn ,@(nreverse l)))
(push `(setq ,(car m) ,(cadr m)) l))))))
;;; Handle cases of PSETQ with 0, 2 or odd number of args.
(deftransform psetq psetq-transform (&rest pairs)
(let ((n (length pairs)))
(cond ((zerop n) nil)
((= n 2)
`(setq ,(car pairs) ,(cadr pairs)))
((oddp n)
(clc-error "Odd number of args to PSETQ.")
nil)
(t '%pass%))))
;;;; PREDICATES
;;; Just turn NULL into NOT.
(defsynonym null not)
;;; Handle degenerate case of NOT with constant or null argument.
(deftransform not not-transform (x)
(cond ((or (null x) (equal x '(quote nil))) t)
((or (eq x t) (equal x '(quote t))) nil)
(t '%pass%)))
;;; Transform for EQ. If one arg is NIL, convert form to NOT test.
(deftransform eq eq-transform (x y)
(cond ((or (null x) (equal x '(quote nil))) `(not ,y))
((or (null y) (equal y '(quote nil))) `(not ,x))
(t '%pass%)))
;;; Transform for EQL. Convert to EQ where one arg is constant and not
;;; a number. If one arg is a zero, convert to ZEROP.
(deftransform eql eql-transform (x y)
(cond ((fixnump x) `(eq ,x ,y))
((fixnump y) `(eq ,x ,y))
((numberp x) '%pass%)
((numberp y) '%pass%)
((or (constantp x) (constantp y))
`(eq ,x ,y))
(t '%pass%)))
;;; Transform for =. This only handles the two-arg case.
;;; If one arg is zero, convert to ZEROP.
(deftransform = =-transform (x &rest y)
(cond ((not (= (length y) 1)) '%pass%)
((and (numberp x) (zerop x))
`(zerop ,(car y)))
((and (numberp (car y)) (zerop (car y)))
`(zerop ,x))
(t '%pass%)))
;;;; CONTROL STRUCTURES
(deftransform return return-transform (&optional (value nil))
`(return-from nil ,value))
(deftransform prog prog-transform (varlist &rest forms)
(let* ((pb (parse-body2 forms))
(decls (car pb))
(body (cadr pb)))
`(let ,varlist
(declare ,@decls)
(block nil (tagbody ,@body)))))
(deftransform prog* prog*-transform (varlist &rest forms)
(let* ((pb (parse-body2 forms))
(decls (car pb))
(body (cadr pb)))
`(let* ,varlist
(declare ,@decls)
(block nil (tagbody ,@body)))))
(deftransform progv progv-transform (varlist arglist &body body)
(let ((v (new-internal-variable))
(a (new-internal-variable))
(n (new-internal-variable)))
`(let ((,n 0))
(do ((,v ,varlist (cdr ,v))
(,a ,arglist (cdr ,a)))
((atom ,v))
(%sp-bind (car ,a) (car ,v))
(setq ,n (1+ ,n)))
(multiple-value-prog1 (progn ,@body)
(%sp-unbind ,n)))))
(deftransform values values-transform (&rest values)
(cond ((or (eq for-value 'tail) (eq for-value 'multiple))
(if (eq for-value 'tail) (setq returns-single-value nil))
(do ((v values (cdr v))
(n 0 (1+ n))
(l nil))
((atom v)
`(progn ,@(nreverse l)
(%sp-n-to-values ,n)))
(push `(%sp-push ,(car v)) l)))
(t `(prog1 . ,values))))
(deftransform values-list values-list-transform (form)
(cond ((or (eq for-value 'tail) (eq for-value 'multiple))
(if (eq for-value 'tail) (setq returns-single-value nil))
(once-only ((v form))
`(progn (%sp-spread ,v)
(%sp-n-to-values (list-length ,v)))))
(t `(car ,form))))
;;; Throw swaps the order of its args, so transform any case where the
;;; tag is not a constant.
(deftransform throw throw-transform (tag value)
(cond ((constantp tag) '%pass%)
((eq tag 'internal-throw-tag) '%pass%)
(t `(let ((internal-throw-tag ,tag))
(throw internal-throw-tag ,value)))))
;;; Catch wants to reference the tag twice, so transform any case where
;;; the tag is not a constant.
(deftransform catch catch-transform (tag &rest forms)
(cond ((constantp tag) '%pass%)
((eq tag 'internal-throw-tag) '%pass%)
(t `(let ((internal-throw-tag ,tag))
(catch internal-throw-tag ,@forms)))))
;;; The following transform only gets called on DEFUN forms not at top level.
(deftransform defun defun-transform (name varlist &rest forms)
(let* ((pb (parse-body1 forms))
(decls (car pb))
(doc (cadr pb))
(body (caddr pb)))
`(progn
,@(if doc `((%put ',name '%fun-documentation ',doc)))
(remprop ',name 'macro-in-compiler)
(setf (symbol-function ',name)
(function (lambda ,varlist
(declare ,@decls)
(block ,name ,@body))))
',name)))
;;; The following transform catches EVAL-WHEN forms that are not at top level.
(deftransform eval-when eval-when-transform (situations &rest forms)
(cond ((or (atom situations)
(eq 'quote (car situations)))
(clc-error "Ill-formed EVAL-WHEN situation list: ~S. ~
Ignoring its contents." situations)
nil)
(t (let ((*eval-when-compile* (memq 'compile situations))
(*eval-when-load* (memq 'load situations)))
(dolist (x forms) (process-form x))
(if (memq 'EVAL situations)
`(progn ,@forms))))))
;;; For Funcall, if the function is #'symbol or 'symbol (and the symbol isn't
;;; functionally bound in the current lexical environment), turn it into the
;;; equivalent form with the symbol in the car.
(deftransform funcall funcall-transform (fn &rest args)
(if (and (consp fn)
(consp (cdr fn))
(symbolp (cadr fn))
(or (eq (car fn) 'function)
(and (eq (car fn) 'quote)
(not (assq (cadr fn) *fenv*)))))
(cons (cadr fn) args)
'%pass%))
;;; IDENTITY turns into its arg.
(deftransform identity identity-transform (x) x)
;;;; LIST and SEQUENCE OPERATORS.
(defprimitive cons cons)
;;; RPLACA and RPLACD, if called for value, need to return the first argument.
;;; %RPLACA and %RPLACD just turn into Replace-Car and Replace-Cdr.
(deftransform rplaca rplaca-transform (a b)
(if for-value
(once-only ((aa a))
`(progn
(%primitive replace-car ,aa ,b)
,aa))
`(%primitive replace-car ,a ,b)))
(deftransform rplacd rplacd-transform (a b)
(if for-value
(once-only ((aa a))
`(progn
(%primitive replace-cdr ,aa ,b)
,aa))
`(%primitive replace-cdr ,a ,b)))
(defprimitive %rplaca replace-car)
(defprimitive %rplacd replace-cdr)
(deftransform caar caar-transform (x) `(car (car ,x)))
(deftransform cadr cadr-transform (x) `(car (cdr ,x)))
(deftransform cdar cdar-transform (x) `(cdr (car ,x)))
(deftransform cddr cddr-transform (x) `(cdr (cdr ,x)))
(deftransform caaar caaar-transform (x) `(car (car (car ,x))))
(deftransform caadr caadr-transform (x) `(car (car (cdr ,x))))
(deftransform cadar cadar-transform (x) `(car (cdr (car ,x))))
(deftransform caddr caddr-transform (x) `(car (cdr (cdr ,x))))
(deftransform cdaar cdaar-transform (x) `(cdr (car (car ,x))))
(deftransform cdadr cdadr-transform (x) `(cdr (car (cdr ,x))))
(deftransform cddar cddar-transform (x) `(cdr (cdr (car ,x))))
(deftransform cdddr cdddr-transform (x) `(cdr (cdr (cdr ,x))))
(deftransform caaaar caaaar-transform (x) `(car (car (car (car ,x)))))
(deftransform caaadr caaadr-transform (x) `(car (car (car (cdr ,x)))))
(deftransform caadar caadar-transform (x) `(car (car (cdr (car ,x)))))
(deftransform caaddr caaddr-transform (x) `(car (car (cdr (cdr ,x)))))
(deftransform cadaar cadaar-transform (x) `(car (cdr (car (car ,x)))))
(deftransform cadadr cadadr-transform (x) `(car (cdr (car (cdr ,x)))))
(deftransform caddar caddar-transform (x) `(car (cdr (cdr (car ,x)))))
(deftransform cadddr cadddr-transform (x) `(car (cdr (cdr (cdr ,x)))))
(deftransform cdaaar cdaaar-transform (x) `(cdr (car (car (car ,x)))))
(deftransform cdaadr cdaadr-transform (x) `(cdr (car (car (cdr ,x)))))
(deftransform cdadar cdadar-transform (x) `(cdr (car (cdr (car ,x)))))
(deftransform cdaddr cdaddr-transform (x) `(cdr (car (cdr (cdr ,x)))))
(deftransform cddaar cddaar-transform (x) `(cdr (cdr (car (car ,x)))))
(deftransform cddadr cddadr-transform (x) `(cdr (cdr (car (cdr ,x)))))
(deftransform cdddar cdddar-transform (x) `(cdr (cdr (cdr (car ,x)))))
(deftransform cddddr cddddr-transform (x) `(cdr (cdr (cdr (cdr ,x)))))
(deftransform first first-transform (x) `(car ,x))
(deftransform second second-transform (x) `(cadr ,x))
(deftransform third third-transform (x) `(caddr ,x))
(deftransform fourth fourth-transform (x) `(cadddr ,x))
(deftransform fifth fifth-transform (x) `(car (cddddr ,x)))
(deftransform sixth sixth-transform (x) `(cadr (cddddr ,x)))
(deftransform seventh seventh-transform (x) `(caddr (cddddr ,x)))
(deftransform eighth eighth-transform (x) `(cadddr (cddddr ,x)))
(deftransform ninth ninth-transform (x) `(car (cddddr (cddddr ,x))))
(deftransform tenth tenth-transform (x) `(cadr (cddddr (cddddr ,x))))
;;; Transform to open code short NTH and NTHCDR.
(deftransform nth nth-transform (n l)
`(car (nthcdr ,n ,l)))
(deftransform nthcdr nthcdr-transform (n l)
(if (and (integerp n) (< -1 n *nthcdr-open-code-limit*))
(do ((x n (1- x))
(f l (list 'cdr f)))
((zerop x) f))
'%pass%))
;;;; SYMBOL FUNCTIONS.
;;; MAKUNBOUND and FMAKUNBOUND set the value or definition cell to
;;; the Misc-Trap code.
(deftransform makunbound makunbound-transform (x)
(once-only ((symbol x))
`(progn
(set ,symbol ,unbound-marker)
,symbol)))
(deftransform fmakunbound fmakunbound-transform (x)
(once-only ((symbol x))
`(progn
(%primitive set-definition ,symbol ,unbound-marker)
,symbol)))
(defprimitive set set-value)
(defprimitive symbol-value get-value)
(defprimitive fset set-definition)
(defprimitive symbol-function get-definition)
(defprimitive boundp boundp)
(defprimitive fboundp fboundp)
(defprimitive symbol-plist get-plist)
(defprimitive %set-plist set-plist)
(defprimitive symbol-name get-pname)
(defprimitive symbol-package get-package)
(defprimitive make-symbol alloc-symbol)
(deftransform fset fset-transform (symbol value)
(clc-warning "FSET is obsolete, use SETF of SYMBOL-FUNCTION.")
`(%sp-set-definition ,symbol ,value))
;;; We've got microcoded instructions to do GET, %PUT, GETF, and PUTF.
;;; PUTF is generated by the PUTF macro, so we don't do anything about that here.
(deftransform get get-transform (symbol indicator &optional default)
(if (null default)
`(%primitive get ,symbol ,indicator)
'%pass%))
(deftransform getf getf-transform (symbol indicator &optional default)
(if (null default)
`(%primitive getf ,symbol ,indicator)
'%pass%))
(defprimitive %put put)
;;;; ARITHMETIC and NUMEROLOGY.
(deftransform plusp plusp-transform (x)
`(> ,x 0))
(deftransform minusp minusp-transform (x)
`(< ,x 0))
(deftransform oddp oddp-transform (x)
`(not (zerop (logand ,x 1))))
(deftransform evenp evenp-transform (x)
`(zerop (logand ,x 1)))
;;; Handler for multi-argument comparisons. Basically, turn things
;;; like (> a b c ... ) to (AND (> a b) (> b c) ... ). But if an
;;; interior arg is not a number or symbol, have to do a setq to
;;; avoid evaling the arg twice. If any setqs are needed, have to
;;; make one extra local variable with a LET form.
(defun multi-compare (form)
(cond ((= (length form) 2) 't)
((= (length form) 3) '%pass%)
;; Simple case, args have no side effects.
((do ((args (cdr form) (cdr args))
(result nil))
((atom (cdr args))
(cons 'and (nreverse result)))
(cond ((trivialp (car args))
(push `(,(car form) ,(car args) ,(cadr args)) result))
(t (return nil)))))
;; Bad case, eval all args first, exactly once.
(t (do ((args (cddr form) (cdr args))
(oldvar (if (numberp (cadr form))
(cadr form)
(new-internal-variable))
newvar)
(oldarg (cadr form) (car args))
(newvar nil)
(varlist nil (if (numberp oldvar)
varlist
(cons (list oldvar oldarg) varlist)))
(result nil))
((null args)
(or (numberp oldvar)
(push (list oldvar oldarg) varlist))
`(let ,(nreverse varlist) (and ,@(nreverse result))))
(setq newvar (if (numberp (car args))
(car args)
(new-internal-variable)))
(push `(,(car form) ,oldvar ,newvar) result)))))
(push 'multi-compare (get '= 'clc-transforms))
(push 'multi-compare (get '> 'clc-transforms))
(push 'multi-compare (get '< 'clc-transforms))
(push 'multi-compare (get '>= 'clc-transforms))
(push 'multi-compare (get '<= 'clc-transforms))
;;; Convert 2-arg comparisons to equivalents.
(deftransform >= >=-two-arg (x &rest y)
(if (= (length y) 1)
`(not (< ,x ,(car y)))
'%pass%))
(deftransform <= <=-two-arg (x &rest y)
(if (= (length y) 1)
`(not (> ,x ,(car y)))
'%pass%))
;;; /= is different, since it requires every element of the arglist to
;;; be compared to every other -- a doubly-nested DO loop. Only open-code
;;; the one arg and two arg cases, and let the rest go call the actual /=
;;; function.
(deftransform /= /=-transform (x &rest more)
(cond ((null more) 't)
((null (cdr more))
`(not (= ,x ,(car more))))
(t '%pass%)))
;;; Transforms for max and min. Zap one-arg case and open-code
;;; two-arg case.
(deftransform max max-transform (x &rest more)
(cond ((null more) x)
((null (cdr more))
(once-only ((a x) (b (car more)))
`(if (> ,a ,b) ,a ,b)))
(t '%pass%)))
(deftransform min min-transform (x &rest more)
(cond ((null more) x)
((null (cdr more))
(once-only ((a x) (b (car more)))
`(if (< ,a ,b) ,a ,b)))
(t '%pass%)))
;;; Transform for multi-arg arithmetic and logical functions.
(defun multi-arith (form)
(if (< (length form) 4)
'%pass%
(do ((f form `(,op (,op ,(cadr f) ,(caddr f)) ,@(cdddr f)))
(op (car form)))
((< (length f) 4) f))))
(push 'multi-arith (get '+ 'clc-transforms))
(push 'multi-arith (get '- 'clc-transforms))
(push 'multi-arith (get '* 'clc-transforms))
(push 'multi-arith (get '/ 'clc-transforms))
(push 'multi-arith (get 'logior 'clc-transforms))
(push 'multi-arith (get 'logxor 'clc-transforms))
(push 'multi-arith (get 'logand 'clc-transforms))
(push 'multi-arith (get 'logeqv 'clc-transforms))
;;; Some of the following use EQ on numbers deliberately. If the number
;;; is merely = to 1 or 0, it might be a float and should cause contagion.
(deftransform + +-transform (&rest args)
(cond ((null args) 0)
((null (cdr args)) (car args))
((cddr args) '%pass%)
((eq (car args) 0) (cadr args))
((eq (car args) 1) `(1+ ,(cadr args)))
((eq (cadr args) 0) (car args))
((eq (cadr args) 1) `(1+ ,(car args)))
(t '%pass%)))
(deftransform - --transform (x &rest args)
(cond ((null args) `(%sp-negate ,x))
((cdr args) '%pass%)
((eq x 0) `(%sp-negate ,(car args)))
((eq (car args) 0) x)
((eq (car args) 1) `(1- ,x))
(t '%pass%)))
(deftransform * *-transform (&rest args)
(cond ((null args) 1)
((null (cdr args)) (car args))
((cddr args) '%pass%)
((eq (car args) 1) (cadr args))
((eq (cadr args) 1) (car args))
(t '%pass%)))
(deftransform / /-transform (x &rest args)
(cond ((null args) `(/ 1 ,x))
((cdr args) '%pass%)
((eql (car args) 0)
(clc-warning "Dividing by constant 0.")
'%pass%)
((eq (car args) 1) x)
(t '%pass%)))
;;; Transform one-arg forms to two-arg with 1 as second arg. Also
;;; if not for value, just eval args for side-effect.
(defun second-arg-is-1 (form)
;; All of these guys return multiple values.
(if (eq for-value 'tail) (setq returns-single-value nil))
(cond ((cddr form) '%pass%)
(t `(,(car form) ,(cadr form) 1))))
(push 'second-arg-is-1 (get 'truncate 'clc-transforms))
(push 'second-arg-is-1 (get 'floor 'clc-transforms))
(push 'second-arg-is-1 (get 'ceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'round 'clc-transforms))
(push 'second-arg-is-1 (get 'ftruncate 'clc-transforms))
(push 'second-arg-is-1 (get 'ffloor 'clc-transforms))
(push 'second-arg-is-1 (get 'fceiling 'clc-transforms))
(push 'second-arg-is-1 (get 'fround 'clc-transforms))
;;; In 1-return case, convert FTRUNCATE and friends to (FLOAT (TRUNCATE ...)).
(deftransform ftruncate ftruncate-transform (x &optional (y 1))
(if (or (eq for-value 'tail) (eq for-value 'multiple))
'%pass%
`(float (truncate ,x ,y))))
(deftransform ffloor ffloor-transform (x &optional (y 1))
(if (or (eq for-value 'tail) (eq for-value 'multiple))
'%pass%
`(float (floor ,x ,y))))
(deftransform fceiling fceiling-transform (x &optional (y 1))
(if (or (eq for-value 'tail) (eq for-value 'multiple))
'%pass%
`(float (ceiling ,x ,y))))
(deftransform fround fround-transform (x &optional (y 1))
(if (or (eq for-value 'tail) (eq for-value 'multiple))
'%pass%
`(float (round ,x ,y))))
;;; Handle degenerate 0 and 1 arg cases of logical functions.
(deftransform logior logior-transform (&rest args)
(cond ((null args) 0)
((null (cdr args)) (car args))
(t '%pass%)))
(deftransform logxor logxor-transform (&rest args)
(cond ((null args) 0)
((null (cdr args)) (car args))
(t '%pass%)))
(deftransform logand logand-transform (&rest args)
(cond ((null args) -1)
((null (cdr args)) (car args))
(t '%pass%)))
;;; Other logical functions.
(deftransform logeqv logeqv-transform (&rest args)
(cond ((null args) -1)
((null (cdr args)) (car args))
((null (cddr args))
`(lognot (logxor ,(car args) ,(cadr args))))
(t '%pass%)))
(deftransform lognand lognand-transform (x y)
`(lognot (logand ,x ,y)))
(deftransform lognor lognor-transform (x y)
`(lognot (logior ,x ,y)))
(deftransform logandc1 logandc1-transform (x y)
`(logand (lognot ,x) ,y))
(deftransform logandc2 logandc2-transform (x y)
`(logand ,x (lognot ,y)))
(deftransform logorc1 logorc1-transform (x y)
`(logior (lognot ,x) ,y))
(deftransform logorc2 logorc2-transform (x y)
`(logior ,x (lognot ,y)))
;;; If control arg to BOOLE is a constant integer, convert to the
;;; appropriate logical function.
(deftransform boole boole-transform (op x y)
(let ((control (transform op)))
(cond ((not (integerp control)) '%pass%)
(t (case control
(0 0)
(1 -1)
(2 x)
(3 y)
(4 `(lognot ,x))
(5 `(lognot ,y))
(6 `(logand ,x ,y))
(7 `(logior ,x ,y))
(8 `(logxor ,x ,y))
(9 `(logeqv ,x ,y))
(10 `(lognand ,x ,y))
(11 `(lognor ,x ,y))
(12 `(logandc1 ,x ,y))
(13 `(logandc2 ,x ,y))
(14 `(logorc1 ,x ,y))
(15 `(logorc2 ,x ,y))
(t (clc-error "~S illegal control arg to BOOLE." control)
nil))))))
(deftransform logtest logtest-transform (x y)
`(not (zerop (logand ,x ,y))))
(deftransform logbitp logbitp-transform (x y)
`(not (zerop (%primitive ldb 1 ,x ,y))))
;;; Byte specifier is just the cons of Size and Position.
(defsynonym byte cons)
(defsynonym byte-size car)
(defsynonym byte-position cdr)
(deftransform ldb ldb-transform (byte-spec x)
(let ((bs (convert-byte-spec byte-spec)))
(cond (bs `(%primitive ldb ,(car bs) ,(cdr bs) ,x))
(t (once-only ((b byte-spec))
`(%primitive ldb (car ,b) (cdr ,b) ,x))))))
(deftransform mask-field mask-field-transform (byte-spec x)
(let ((bs (convert-byte-spec byte-spec)))
(cond (bs `(%primitive mask-field ,(car bs) ,(cdr bs) ,x))
(t (once-only ((b byte-spec))
`(%primitive mask-field (car ,b) (cdr ,b) ,x))))))
(deftransform dpb dpb-transform (new byte-spec x)
(let ((bs (convert-byte-spec byte-spec)))
(cond (bs `(%primitive dpb ,new ,(car bs) ,(cdr bs) ,x))
(t (once-only ((b byte-spec))
`(%primitive dpb ,new (car ,b) (cdr ,b) ,x))))))
(deftransform deposit-field deposit-field-transform (new byte-spec x)
(let ((bs (convert-byte-spec byte-spec)))
(cond (bs `(%primitive deposit-field ,new ,(car bs) ,(cdr bs) ,x))
(t (once-only ((b byte-spec))
`(%primitive deposit-field ,new (car ,b) (cdr ,b) ,x))))))
(deftransform ldb-test ldb-test-transform (bytespec x)
`(not (zerop (ldb ,bytespec ,x))))
(deftransform float float-transform (n &optional (other nil otherp))
(cond ((not otherp) `(%primitive float-short ,n))
((not (floatp (setq other (transform other)))) '%pass%)
((typep other 'short-float) `(%primitive float-short ,n))
((typep other 'single-float) `(%primitive float-short ,n))
((typep other 'double-float) `(%primitive float-long ,n))
((typep other 'long-float) `(%primitive float-long ,n))
(t (error "Unknown float type?"))))
(defprimitive abs abs)
(defprimitive short-float float-short)
(defprimitive single-float float-short)
(defprimitive double-float float-long)
(defprimitive long-float float-long)
(defprimitive ash ash)
(defprimitive integer-length integer-length)
;;;; VECTOR and ARRAY HACKERY.
;;; This stuff is filled with millions of bogus pseudo-subprimtives that
;;; should be flushed someday.
;;; Simple accessors:
(defprimitive svref svref)
(defprimitive schar schar)
;(defprimitive sbit sbit); <-- SBIT works on multi-D things.
(defprimitive saref1 aref1)
(defprimitive %sp-svref svref)
(defprimitive %sp-schar schar)
(defprimitive %sp-sbit sbit)
(defprimitive %sp-saref1 aref1)
;;; Simple setters:
(defprimitive %svset svset)
(defprimitive %scharset scharset)
;(defprimitive %sbitset sbitset); <-- %SBITSET works on multi-D things.
(defprimitive %saset1 aset1)
(defprimitive %sp-svset svset)
(defprimitive %sp-scharset scharset)
(defprimitive %sp-sbitset sbitset)
(defprimitive %sp-saset1 aset1)
;;; Complex sets and accesses:
(defprimitive aref1 aref1)
(defprimitive %aset1 aset1)
;;; General Lisp-level accessors:
(deftransform aref aref-transform (array &rest indices)
(let ((index (car indices)))
(if (and index (null (cdr indices)))
(case (find-type array)
(simple-vector `(svref ,array ,index))
(simple-string `(schar ,array ,index))
(simple-bit-vector `(%primitive sbit ,array ,index))
(simple-array `(saref1 ,array ,index))
(t `(aref1 ,array ,index)))
'%pass%)))
(deftransform char char-transform (array index)
(if (eq (find-type array) 'simple-string)
`(schar ,array ,index)
`(aref1 ,array ,index)))
;;; Bit accessors are special...
(deftransform sbit sbit-transform (array &rest indices)
(if (and (car indices) (null (cdr indices)))
`(%primitive sbit ,array ,(car indices))
`(aref ,array ,@indices)))
(deftransform bit bit-transform (array &rest indices)
`(aref ,array ,@indices))
;;; General Lisp-level setters:
(deftransform %aset %aset-transform (array &rest stuff)
(let ((index (car stuff))
(new (cadr stuff)))
(if (and new (null (cddr stuff)))
(case (find-type array)
(simple-vector `(%svset ,array ,index ,new))
(simple-string `(%scharset ,array ,index ,new))
(simple-bit-vector `(%sbitset ,array ,index ,new))
(simple-array `(%saset1 ,array ,index ,new))
(t `(%aset1 ,array ,index ,new)))
'%pass%)))
(deftransform %charset %charset-transform (array index new)
(if (eq (find-type array) 'simple-string)
`(%scharset ,array ,index ,new)
`(%aset1 ,array ,index ,new)))
(deftransform %sbitset %sbitset-transform (array &rest stuff)
(if (and (cadr stuff) (null (cddr stuff)))
`(%primitive sbitset ,array ,(car stuff) ,(cadr stuff))
`(%aset ,array ,@stuff)))
(deftransform %bitset %bitset-transform (array &rest stuff)
`(%aset ,array ,@stuff))
;;; Transforms for MAKE-VECTOR and MAKE-ARRAY.
;;; Since we can handle a specification of :Initial-Element, we'll squeeze
;;; out that special case.
(deftransform make-vector make-vector-transform (n &rest stuff)
(cond ((null stuff)
`(%sp-alloc-b-vector ,n nil))
((and (eq (car stuff) ':initial-element) (null (cddr stuff)))
`(%sp-alloc-b-vector ,n ,(cadr stuff)))
(t '%pass%)))
(deftransform make-array make-array-transform (n &rest stuff)
(cond ((not (integerp n)) '%pass%)
((null stuff)
`(%sp-alloc-b-vector ,n nil))
((and (eq (car stuff) ':initial-element) (null (cddr stuff)))
`(%sp-alloc-b-vector ,n ,(cadr stuff)))
(t '%pass%)))
(deftransform make-string make-string-transform (n &rest stuff)
(if (null stuff)
`(%sp-alloc-string ,n)
'%pass%))
;;;; CHARACTER FUNCTIONS
;;; CHAR= is just EQ in this system.
(deftransform char= char=-transform (char &rest more)
(cond ((null more) t)
((null (cdr more)) `(eq ,char ,(car more)))
(t '%pass%)))
;;; Handle >2 arg cases just like numerical comparisons.
(push 'multi-compare (get 'char= 'clc-transforms))
(push 'multi-compare (get 'char> 'clc-transforms))
(push 'multi-compare (get 'char< 'clc-transforms))
(push 'multi-compare (get 'char>= 'clc-transforms))
(push 'multi-compare (get 'char<= 'clc-transforms))
;;; Like /=, this requires that all chars be compared.
(deftransform char/= char/=-transform (char &rest more)
(cond ((null more) t)
((null (cdr more)) `(not (eq ,char ,(car more))))
(t '%pass%)))
(deftransform char-int char-int-transform (x)
`(%primitive make-immediate-type ,x 16))
(deftransform char-code char-code-transform (x)
`(logand 255 (%primitive make-immediate-type ,x 16)))
;;;; Instruction-level transforms.
(defprimitive %sp-cons cons)
(defprimitive %sp-alloc-symbol alloc-symbol)
(defprimitive %sp-alloc-b-vector alloc-g-vector)
(defprimitive %sp-alloc-u-vector alloc-i-vector)
(defprimitive %sp-alloc-string alloc-string)
(defprimitive %sp-alloc-function alloc-function)
(defprimitive %sp-alloc-array alloc-array)
(defprimitive %sp-alloc-xnum alloc-bignum)
(defprimitive %sp-type get-type)
(defprimitive %sp-make-immediate-type make-immediate-type)
(defprimitive %sp-get-vector-subtype get-vector-subtype)
(defprimitive %sp-set-vector-subtype set-vector-subtype)
(defprimitive %sp-get-vector-length vector-length)
(defprimitive %sp-get-value get-value)
(defprimitive %sp-set-value set-value)
(defprimitive %sp-get-definition get-definition)
(defprimitive %sp-set-definition set-definition)
(defprimitive %sp-get-plist get-plist)
(defprimitive %sp-set-plist set-plist)
(defprimitive %sp-get-pname get-pname)
(defprimitive %sp-get-package get-package)
(defprimitive %sp-set-package set-package)
(defprimitive %sp-boundp boundp)
(defprimitive %sp-fboundp fboundp)
(defprimitive %sp-negate negate)
(defprimitive %sp-lsh lsh)
(defprimitive %sp-get-vector-access-type get-vector-access-code)
(defprimitive %sp-logldb logldb)
(defprimitive %sp-logdpb logdpb)
(defprimitive %sp-abs abs)
(defprimitive %sp-subspace get-space)
(defprimitive %sp-typed-v-access typed-vref)
(defprimitive %sp-typed-v-store typed-vset)
(defprimitive %sp-shrink-vector shrink-vector)
(defprimitive %sp-values-to-n values-to-n)
(defprimitive %sp-n-to-values n-to-values)
(defprimitive %sp-arg-in-frame arg-in-frame)
(defprimitive %sp-current-stack-frame active-call-frame)
(defprimitive %sp-set-stack-frame set-call-frame)
(defprimitive %sp-current-open-frame current-open-frame)
(defprimitive %sp-set-open-frame set-open-frame)
(defprimitive %sp-current-stack-pointer current-stack-pointer)
(defprimitive %sp-current-binding-pointer current-binding-pointer)
(defprimitive %sp-read-control-stack read-control-stack)
(defprimitive %sp-write-control-stack write-control-stack)
(defprimitive %sp-read-binding-stack read-binding-stack)
(defprimitive %sp-write-binding-stack write-binding-stack)
(defprimitive %sp-ldb ldb)
(defprimitive %sp-mask-field mask-field)
(defprimitive %sp-dpb dpb)
(defprimitive %sp-deposit-field deposit-field)
(defprimitive %sp-ash ash)
(defprimitive %sp-haulong integer-length)
(defprimitive %sp-v-access aref1)
(defprimitive %sp-svref aref1)
(defprimitive %sp-v-store aset1)
(defprimitive %sp-svset aset1)
(defprimitive %sp-force-values force-values)
(defprimitive %sp-flush-values flush-values)
(defprimitive %sp-get-newspace-bit newspace-bit)
(defprimitive %sp-halt halt)
(defprimitive %sp-escape-return escape-return)
(defprimitive %sp-break-return break-return)
(defprimitive %sp-kernel-trap kernel-trap)
(defprimitive %sp-byte-blt byte-blt)
(defprimitive %sp-find-character find-character)
(defprimitive %sp-find-character-with-attribute find-character-with-attribute)
(defprimitive %sp-sxhash-simple-string sxhash-simple-string)
(defprimitive %sp-short-float float-short)
(defprimitive %sp-long-float float-long)
(defprimitive %sp-single-float float-short)
(defprimitive %sp-double-float float-long)
(defprimitive %sp-scale-float scale-float)
(defprimitive %sp-decode-float decode-float)
(defprimitive %sp-assoc assoc)
(defprimitive %sp-assq assq)
(defprimitive %sp-member member)
(defprimitive %sp-memq memq)
;;; This is the macro that constructs the transforms for string<, string<=,
;;; string>, and string>=. Char-fn is the character comparison function that
;;; finished off the job of %sp-string-compare. String-fn is the * function that
;;; is called when one of the args to the function call that is being transformed
;;; is not simple (i.e. when we are punting on the transform). These are put
;;; in by ,', at macroexpand time. The backquoted form that is returned then
;;; evaluates in all of the six arguments to the string comparison function at
;;; transform time.
(defmacro string<>=-body (string*-fn lessp equalp)
`(if (and (eq (find-type string1) 'simple-string)
(eq (find-type string2) 'simple-string))
(once-only ((str1 string1)
(str2 string2)
(s1 start1)
(e1 end1)
(s2 start2)
(e2 end2))
(let ((index (new-internal-variable))
(end1 (new-internal-variable))
(end2 (new-internal-variable)))
`(let* ((,end1 (if (not ,e1) (length (the simple-string ,str1)) ,e1))
(,end2 (if (not ,e2) (length (the simple-string ,str2)) ,e2))
(,index (%sp-string-compare ,str1 ,s1 ,end1 ,str2 ,s2 ,end2)))
(if ,index
(cond ((= ,index ,(if ,lessp end1 end2)) ,index)
((= ,index ,(if ,lessp end2 end1)) nil)
((,(if ,lessp 'char< 'char>)
(schar ,str1 ,index)
(schar ,str2 (+ ,index (- ,s2 ,s1))))
,index)
(t nil))
,(if ,equalp `(- ,end1 ,s1) 'nil)))))
`(,',string*-fn ,string1 ,string2 ,start1 ,end1 ,start2 ,end2)))
(deftransform string< string<-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string<>=-body string<* t nil))
(deftransform string> string>-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string<>=-body string>* nil nil))
(deftransform string<= string<=-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string<>=-body string<=* t t))
(deftransform string>= string>=-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string<>=-body string>=* nil t))
;;; As above, but for string= and string/=. Compare-fn is the function to call
;;; on the result of %sp-string-compare. *-fn is the * function to call if there
;;; are non-simple strings.
(defmacro string=-body (compare-fn *-fn)
`(if (and (eq (find-type string1) 'simple-string)
(eq (find-type string2) 'simple-string))
(once-only ((str1 string1)
(str2 string2)
(e1 end1)
(e2 end2))
`(,',compare-fn (%sp-string-compare ,str1 ,start1
(if (not ,e1) (length (the simple-string ,str1)) ,e1)
,str2 ,start2
(if (not ,e2) (length (the simple-string ,str2)) ,e2))))
`(,',*-fn ,string1 ,string2 ,start1 ,end1 ,start2 ,end2)))
(deftransform string= string=-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string=-body not string=*))
(deftransform string/= string/=-transform
(string1 string2 &key (start1 0) end1 (start2 0) end2)
(string=-body identity string/=*))
;;; A transform for FORMAT, courtesy of Skef.
(deftransform format format-transform (stream control &rest args)
(if (or (not (simple-string-p control))
(not (trivialp stream))
(eq stream nil))
'%pass%
(do* ((index 0)
(forms ())
(end (length control))
(penultimus (1- end))
(stream-var (new-internal-variable))
(stream-form (if (eq stream t) () `(,stream-var))))
((= index end)
`(let (,@(if (eq stream t)
()
`((,stream-var ,stream))))
,@(nreverse forms)
nil))
(let* ((command-index (position #\~ (the simple-string control)
:start index)))
(cond (command-index
(when (= command-index penultimus)
(clc-error "FORMAT control string ends in a ~~: ~S" control)
(return '%pass%))
;; Get the format directive.
(let ((command-char (schar control (1+ command-index))))
;; Non-command stuff gets write-string'ed out.
(if (/= index command-index)
(push `(write-string
,(subseq (the simple-string control)
index command-index)
,@stream-form)
forms))
;; Generate code for the command.
(push
(case command-char
((#\b #\B) `(let ((*print-base* 2))
(princ ,(pop args) ,@stream-form)))
((#\o #\O) `(let ((*print-base* 8))
(princ ,(pop args) ,@stream-form)))
((#\d #\D) `(let ((*print-base* 10))
(princ ,(pop args) ,@stream-form)))
((#\x #\X) `(let ((*print-base* 16))
(princ ,(pop args) ,@stream-form)))
((#\a #\A) `(princ ,(pop args) ,@stream-form))
((#\s #\S) `(prin1 ,(pop args) ,@stream-form))
(#\% `(terpri ,@stream-form))
(#\& `(fresh-line ,@stream-form))
(#\| `(write-char #\form ,@stream-form)) ; |) for EMACS
(#\~ `(write-char #\~ ,@stream-form))
(#\newline
(let ((new-pos (position-if-not
#'whitespace-char-p
(the simple-string control)
:start (+ command-index 2))))
(if new-pos
(setq command-index (- new-pos 2)))))
(t (return '%pass%)))
forms))
(setq index (+ command-index 2)))
(t
;; Write out the final part of the string.
(push `(write-string ,(subseq (the simple-string control)
index end)
,@stream-form)
forms)
(setq index end)))))))