;;; 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).
;;; **********************************************************************
;;;
;;; Compiler Transforms for List, String, and Sequence functions.
;;; Written by Skef Wholey and Don Mathis.
;;; Adapted for use in the new Common Lisp Compiler by Scott Fahlman.
;;; Currently maintained by Scott Fahlman.
;;; Someday add transforms for REMOVE, DELETE, MISMATCH, MAP, and assorted
;;; other functions. Some of these existed in the old SEQTRAN, but they
;;; needed much work and have been removed for now.
;;;; Random utilities:
;;; Give-Up is called when we cannot open code a form. If the user has asked
;;; for feedback on this, give it to him.
(defmacro give-up (fn)
`(progn
(when *complain-about-inefficiency*
(clc-comment "Cannot open code a call to ~A." ,fn))
'%pass%))
;;; ENDP has its own microcoded instruction.
(defprimitive endp endp)
;;; The following functions construct the four types of iteration loop
;;; needed by the various sequence functions: list-forward, list-backward,
;;; indexed-forward, indexed-backward.
(defun list-forward (list list-temp index start end locals result forms)
(once-only ((start-name start)
(end-name end))
`(do* ((,list-temp (nthcdr ,start-name ,list) (cdr ,list-temp))
(,index ,start-name (1+ ,index))
,@locals)
(,(if (null end)
`(endp ,list-temp)
`(= ,index (the fixnum ,end-name)))
,result)
(declare (list ,list-temp) (fixnum ,index))
,@forms)))
(defun list-backward (list list-temp index start end locals result forms)
(once-only ((list-name list)
(start-name start))
(let ((end-name (new-internal-variable)))
`(do* ((,end-name ,(if end end `(length (the list ,list-name))))
(,index ,end-name)
(,list-temp
,(if end
`(nthcdr (- (length (the list ,list-name)) ,end-name)
(reverse ,list-name))
`(reverse ,list-name))
(cdr ,list-temp))
,@locals)
(,(if (zerop start)
`(endp ,list-temp)
`(or (endp ,list-temp) (= ,index (the fixnum ,start-name))))
,result)
(declare (list ,list-temp) (fixnum ,index))
(setq ,index (1- ,index))
,@forms))))
(defun indexed-forward (seq seq-name seq-type index start end locals result forms)
(let ((end-name (new-internal-variable)))
(once-only ((start-name start))
`(do* ((,seq-name ,seq)
(,end-name ,(or end `(length (the ,seq-type ,seq-name))))
(,index ,start-name (1+ ,index))
,@locals)
((>= ,index (the fixnum ,end-name))
,result)
(declare (fixnum ,index))
,@forms))))
(defun indexed-backward (seq seq-name seq-type index start end locals result forms)
(let ((end-name (new-internal-variable)))
(once-only ((start-name start))
`(do* ((,seq-name ,seq)
(,end-name ,(or end `(length (the ,seq-type ,seq-name))))
(,index ,end-name)
,@locals)
((<= ,index (the fixnum ,start-name))
,result)
(declare (fixnum ,index))
(setq ,index (1- ,index))
,@forms))))
;;; Build the testing function for use in one of the iteration forms.
(defun build-test (switch item-or-pred test test-not key element)
(case switch
(test
(cond (test
(if test-not
(clc-error "Both :TEST and :TEST-NOT in same call.")
`(funcall ,test ,item-or-pred (funcall ,key ,element))))
(test-not
`(not (funcall ,test-not ,item-or-pred (funcall ,key ,element))))
(t `(eql ,item-or-pred (funcall ,key ,element)))))
(if `(funcall ,item-or-pred (funcall ,key ,element)))
(if-not `(not (funcall ,item-or-pred (funcall ,key ,element))))))
;;;; List function transforms:
;;; There are microcoded instructions to handle the cases where MEMBER is called
;;; with a :TEST of EQL or EQ and no :KEY. If possible, calls to MEMBER or MEMQ
;;; will use these instructions. If not, such calls will turn into DO loops.
(defprimitive memq memq)
(deftransform member member-transform (thing list
&key test test-not (key '(function identity)))
(cond ((and (not test-not) (equal key '(function identity))
(or (not test)
(equal test '(quote eq))
(equal test '(function eq))
(equal test '(quote eql))
(equal test '(function eql))))
(if (or (not test) (eq (cadr test) 'eql))
`(%primitive member ,thing ,list)
`(%primitive memq ,thing ,list)))
(t
(once-only ((thing-name thing))
(let ((list-name (new-internal-variable)))
`(do ((,list-name ,list (cdr ,list-name)))
((endp ,list-name) nil)
(if ,(build-test 'test thing-name test test-not
key
`(car ,list-name))
(return ,list-name))))))))
(deftransform member-if member-if-transform (predicate list
&key (key '(function identity)))
(setq list (transform list))
(if (and (eq for-value 'predicate) (constantp list) (listp list))
(if (listp (cadr list))
(do ((list (cadr list) (cdr list))
(tests))
((endp list) `(or ,@(nreverse tests)))
(push `(funcall ,predicate (funcall ,key ,(car list)))
tests))
(clc-error "~S not a list for MEMBER-IF." list))
(let ((list-name (new-internal-variable)))
`(do ((,list-name ,list (cdr ,list-name)))
((endp ,list-name) nil)
(if (funcall ,predicate (funcall ,key (car ,list-name)))
(return ,list-name))))))
(deftransform member-if-not member-if-not-transform (predicate list
&key (key '(function identity)))
(setq list (transform list))
(if (and (eq for-value 'predicate) (constantp list) (listp list))
(if (listp (cadr list))
(do ((list (cadr list) (cdr list))
(tests))
((endp list) `(or ,@(nreverse tests)))
(push `(not (funcall ,predicate (funcall ,key ,(car list))))
tests))
(clc-error "~S not a list for MEMBER-IF." list))
(let ((list-name (new-internal-variable)))
`(do ((,list-name ,list (cdr ,list-name)))
((endp ,list-name) nil)
(if (not (funcall ,predicate (funcall ,key (car ,list-name))))
(return ,list-name))))))
;;; ASSOC and ASSQ have microcoded instructions as well.
(defprimitive assq assq)
(deftransform assoc assoc-transform (item a-list
&key test test-not)
(cond ((and (not test-not)
(or (not test)
(equal test '(quote eq))
(equal test '(function eq))
(equal test '(quote eql))
(equal test '(function eql))))
(if (or (not test) (eq (cadr test) 'eql))
`(%primitive assoc ,item ,a-list)
`(%primitive assq ,item ,a-list)))
(t
(let ((temp (new-internal-variable)))
(once-only ((iname item))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if ,(build-test 'test iname test test-not ''car `(car ,temp))
(return (car ,temp))))))))))
(deftransform assoc-if assoc-if-transform (predicate a-list)
(let ((temp (new-internal-variable)))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if (funcall ,predicate (caar ,temp))
(return (car ,temp)))))))
(deftransform assoc-if-not assoc-if-not-transform (predicate a-list)
(let ((temp (new-internal-variable)))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if (not (funcall ,predicate (caar ,temp)))
(return (car ,temp)))))))
(deftransform rassoc rassoc-transform (item a-list
&key test test-not)
(let ((temp (new-internal-variable)))
(once-only ((iname item))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if ,(build-test 'test iname test test-not ''cdr `(car ,temp))
(return (car ,temp))))))))
(deftransform rassoc-if rassoc-if-transform (predicate a-list)
(let ((temp (new-internal-variable)))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if (funcall ,predicate (cdar ,temp))
(return (car ,temp)))))))
(deftransform rassoc-if-not rassoc-if-not-transform (predicate a-list)
(let ((temp (new-internal-variable)))
`(do ((,temp ,a-list (cdr ,temp)))
((endp ,temp) nil)
(if (car ,temp)
(if (not (funcall ,predicate (cdar ,temp)))
(return (car ,temp)))))))
;;; Subst and friends turn into calls to non-keyword parsing functions:
(deftransform subst subst-transform (new old tree
&key test test-not (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(consp (cdr key))
(eq (cadr key) 'identity))
(cond ((and test test-not)
(clc-error "Both :TEST and :TEST-NOT specified in SUBST.")
nil)
(test `(subst-test* ,old ,new ,tree ,test))
(test-not `(subst-test-not* ,old ,new ,tree ,test-not))
(t `(subst* ,old ,new ,tree)))
(cond ((and test test-not)
(clc-error "Both :TEST and :TEST-NOT specified in SUBST.")
nil)
(test `(subst-key-test* ,old ,new ,tree ,key ,test))
(test-not `(subst-key-test-not* ,old ,new ,tree ,key ,test-not))
(t `(subst-key* ,old ,new ,tree ,key)))))
(deftransform subst-if subst-if-transform (predicate new tree
&key (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(consp (cdr key))
(eq (cadr key) 'identity))
`(subst-if* ,predicate ,new ,tree)
`(subst-if-key* ,predicate ,new ,tree ,key)))
(deftransform subst-if-not subst-if-not-transform (predicate new tree
&key (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(consp (cdr key))
(eq (cadr key) 'identity))
`(subst-if-not* ,predicate ,new ,tree)
`(subst-if-not-key* ,predicate ,new ,tree ,key)))
(deftransform nsubst nsubst-transform (new old tree
&key test test-not (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(consp (cdr key))
(eq (cadr key) 'identity))
(cond ((and test test-not)
(clc-error "Both :TEST and :TEST-NOT specified in NSUBST.")
nil)
(test `(nsubst-test* ,old ,new ,tree ,test))
(test-not `(nsubst-test-not* ,old ,new ,tree ,test-not))
(t `(nsubst* ,old ,new ,tree)))
(cond ((and test test-not)
(clc-error "Both :TEST and :TEST-NOT specified in NSUBST.")
nil)
(test `(nsubst-key-test* ,old ,new ,tree ,key ,test))
(test-not `(nsubst-key-test-not* ,old ,new ,tree ,key ,test-not))
(t `(nsubst-key* ,old ,new ,tree ,key)))))
(deftransform nsubst-if nsubst-if-transform (predicate new tree
&key (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(consp (cdr key))
(eq (cadr key) 'identity))
`(nsubst-if* ,predicate ,new ,tree)
`(nsubst-if-key* ,predicate ,new ,tree ,key)))
(deftransform nsubst-if-not nsubst-if-not-transform (predicate new tree
&key (key '(function identity)))
(if (and (consp key)
(eq (car key) 'function)
(memq (car key) '(quote function))
(consp (cdr key))
(eq (cadr key) 'identity))
`(nsubst-if-not* ,predicate ,new ,tree)
`(nsubst-if-not-key* ,predicate ,new ,tree ,key)))
;;;; Sequence function transforms:
;;; The following turn into calls to more specific functions. Just saves
;;; the time spent for keyword processing and type dispatching at runtime.
(deftransform elt elt-transform (seq n)
(case (find-type seq)
((cons list) `(nth ,n ,seq))
(simple-vector `(svref ,seq ,n))
(simple-string `(schar ,seq ,n))
(simple-bit-vector `(sbit ,seq ,n))
(simple-array `(saref1 ,seq ,n))
((vector string bit-vector array) `(aref ,seq ,n))
(t (give-up 'elt))))
(deftransform %setelt %setelt-transform (seq n val)
(case (find-type seq)
((cons list) `(setnth ,n ,seq ,val))
(simple-vector `(%svset ,seq ,n ,val))
(simple-string `(%scharset ,seq ,n ,val))
(simple-bit-vector `(%sbitset ,seq ,n ,val))
((vector string bit-vector array)
`(%aset1 ,seq ,n ,val))
(t (give-up "SETF of ELT"))))
(deftransform length length-transform (arg)
(case (find-type arg)
((cons list)
`(do ((%count 0 (1+ %count))
(%a ,arg (cdr %a)))
((endp %a) %count)))
(simple-vector
`(%primitive g-vector-length ,arg))
(simple-string
`(%primitive simple-string-length ,arg))
(simple-bit-vector
`(%primitive simple-bit-vector-length ,arg))
((vector array)
`(%primitive vector-length ,arg))
(t (give-up 'length))))
(deftransform subseq subseq-transform (seq start &optional (end nil))
(case (find-type seq)
((cons list) `(list-subseq* ,seq ,start ,end))
(simple-string
(let ((length-var (new-internal-variable))
(result-var (new-internal-variable)))
(once-only ((string-name seq)
(start-name start))
`(let* ((,length-var
(- ,(or end `(%sp-get-vector-length ,string-name))
,start-name))
(,result-var (make-string ,length-var)))
(%sp-byte-blt ,string-name ,start-name ,result-var 0 ,length-var)
,result-var))))
((simple-vector simple-bit-vector
vector string bit-vector array)
`(vector-subseq* ,seq ,start ,end))
(t (give-up 'subseq))))
(deftransform copy-seq copy-seq-transform (seq)
(case (find-type seq)
((cons list) `(list-copy-seq* ,seq))
(simple-string
(let ((length-var (new-internal-variable))
(result-var (new-internal-variable)))
(once-only ((name seq))
`(let* ((,length-var (%sp-get-vector-length ,name))
(,result-var (make-string ,length-var)))
(%sp-byte-blt ,name 0 ,result-var 0 ,length-var)
,result-var))))
((simple-vector simple-bit-vector
vector string bit-vector array)
`(vector-copy-seq* ,seq))
(t (give-up 'copy-seq))))
(deftransform fill fill-transform (sequence item &key (start 0) end)
(case (find-type sequence)
((cons list) `(list-fill* ,sequence ,item ,start ,end))
((simple-vector simple-string simple-bit-vector
vector string bit-vector array)
`(vector-fill* ,sequence ,item ,start ,end))
(t (give-up 'fill))))
(deftransform replace replace-transform (target source
&key (start1 0) (start2 0) end1 end2)
(let* ((ttype (find-type target))
(stype (find-type source)))
(cond ((and (eq ttype 'simple-string) (eq stype 'simple-string))
(once-only ((n-target target)
(n-source source))
(cond
((and (eql start1 0) (eql start2 0))
`(progn
(%sp-byte-blt
,n-source 0 ,n-target 0
(min ,(or end1 `(length (the simple-string ,n-target)))
,(or end2 `(length (the simple-string ,n-source)))))
,n-target))
(t
(once-only ((n-end1
(or end1 `(length (the simple-string ,n-target))))
(n-end2
(or end2 `(length (the simple-string ,n-source))))
(n-start1 start1)
(n-start2 start2))
`(progn
(%sp-byte-blt ,n-source ,n-start2 ,n-target ,n-start1
(+ ,n-start1
(min (- ,n-end1 ,n-start1)
(- ,n-end2 ,n-start2))))
,n-target))))))
((and (memq ttype
'(cons list simple-vector simple-string simple-bit-vector
vector string bit-vector array))
(memq stype
'(cons list simple-vector simple-string simple-bit-vector
vector string bit-vector array)))
`(,(case ttype
((cons list)
(case stype
((cons list) 'list-replace-from-list*)
(t 'list-replace-from-vector*)))
(t
(case stype
((cons list) 'vector-replace-from-list*)
(t 'vector-replace-from-vector*))))
,target ,source
,start1 ,end1 ,start2 ,end2))
(t (give-up 'replace)))))