[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Re: Common Lisp LOOP
Here is my code for LOOP, which will be included in the next release of
KCL available from University of Texas.
-- Taiichi
------------------- Cut Here ----------------------
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
;;;; loop.lsp
;;;;
;;;; defines the sophisticated LOOP macro, with the hope it's
;;;; compatible with Symbolics Common Lisp.
(in-package 'lisp)
(export '(define-loop-path define-loop-sequence-path))
(in-package 'system)
(export '(loop-tequal loop-tmember loop-tassoc loop-named-variable))
(eval-when (compile) (proclaim '(optimize (safety 2) (space 3))))
(defvar *loop-named-variables* nil)
(defun loop-tequal (x key) "
Args: (object symbol)
Returns T if OBJECT is a symbol with the same print name as SYMBOL; NIL
otherwise. Used typically to define a loop-path."
(and (symbolp x)
(or (eq x key)
(string= (symbol-name x) (symbol-name key)))))
(defun loop-tmember (x keys) "
Args: (object symbols)
Similar to MEMBER but uses SI:LOOP-TEQUAL to compare OBJECT and each element
of SYMBOLS. Used typically to define a loop-path."
(and (symbolp x)
(member (symbol-name x) keys :test #'string= :key #'symbol-name)))
(defun loop-tassoc (x alist) "
Args: (object alist)
Similar to ASSOC but uses SI:LOOP-TEQUAL to compare OBJECT and the car of each
element of ALIST using . Used typically to define a loop-path."
(and (symbolp x)
(assoc (symbol-name x) alist
:test #'(lambda (s key) (string= s (symbol-name key))))))
(defun loop-named-variable (key) "
Args: (symbol)
Returns the name of the variable for SYMBOL, which is specified by the USING
key of LOOP. Returns NIL if no variable is specified. Should be used only in
loop-path definitions."
(cadr (loop-tassoc key *loop-named-variables*)))
(defmacro test body `(macroexpand-1 '(loop ,@body)))
(defvar *loop-paths* (make-hash-table :test 'equal))
(defmacro define-loop-path (name fun keys &rest data) "
Syntax: (define-loop-path name-or-names symbol keys &rest data)
Defines loop-paths. When LOOP encounters a clause of the form
FOR var [type] BEING {THE | EACH} name (key1 thing1)...(keyn thingn)
LOOP invokes the function named SYMBOL with the following arguments.
1. name
2. var
3. type (or NIL if type is not specified)
4. ((key1 thing1)...(keyn thingn))
5. NIL
6. keys specified by DEFINE-LOOP-PATH
7. data specified by DEFINE-LOOP-PATH
In case of
FOR var [type] BEING form AND ITS name (key1 thing1)...(keyn thingn)
LOOP invokes the same function with the same arguments except for the fourth
and fifth:
4. ((OF form) (key1 thing1)...(keyn thingn))
5. T
Then LOOP expects a list of six or ten elements returned by the function
1. variable bindings as a list ((var init)...(var init))
2. prologue forms as a list (form...form)
3-6. general iteration spec
7-10. first iteration spec
For a six-element list, 7-10 are assumed the same as 3-6, respectively. The
iteration spec is
3. pre-step endtest
4. steps as a list ((var form)...(var form))
5. post-step endtest
6. pseudo-steps as a list ((var form)...(var form))"
`(progn ,.(mapcar #'(lambda (x)
`(setf (gethash ,(symbol-name x) *loop-paths*)
(list ',fun ',keys ',data)))
(if (symbolp name) (list name) name))
',name))
(defmacro define-loop-sequence-path (name fetch size &optional type1 type2) "
Syntax: (define-loop-sequence-path name-or-names fetch-fun size-fun
&optional type1 type2)
Defines loop-sequence-paths."
(declare (ignore type1 type2))
`(progn ,.(mapcar #'(lambda (x)
`(setf (gethash ,(symbol-name x) *loop-paths*)
(list nil ',fetch ',size)))
(if (symbolp name) (list name) name))
',name))
(defvar *loop-body*)
(defvar *bindings*)
(defvar *prologue*)
(defvar *pre-steps*)
(defvar *body*)
(defvar *post-steps*)
(defvar *epilogue*)
(defvar *acc*)
(defvar *acclist*)
(defvar *named-block*)
(defvar *t2*)
(defvar *it*)
(defvar *its-name*)
(defvar *it-is-used*)
(defvar *temps*)
(defvar *aux-bindings*)
(defmacro lkcase clauses
(let ((key (gensym))
(form nil))
(dolist (clause (reverse clauses)
`(let ((,key (if (symbolp (car *loop-body*))
(symbol-name (car *loop-body*)) "")))
,form))
(declare (object clause))
(setq form
(if (eq (car clause) :ow)
`(progn ,@(cdr clause))
`(if ,(cond ((atom (car clause))
`(string= ,key ,(symbol-name (car clause))))
(t `(or ,.(mapcar
#'(lambda (x)
`(string= ,key ,(symbol-name x)))
(car clause)))))
(progn (pop-body) ,@(cdr clause))
,form))))))
(defmacro pop-body () '(pop *loop-body*))
(defmacro peek-body () '(car *loop-body*))
(defmacro end-body () '(endp *loop-body*))
(defmacro do-it (form) `(push ,form *body*))
(defconstant *default-terminators*
'(REPEAT FOR AS WITH NODECLARE INITIALLY FINALLY DO DOING COLLECT COLLECTING
NCONC NCONCING APPEND APPENDING COUNT COUNTING SUM SUMMING MAXIMIZE
MINIMIZE WHILE UNTIL LOOP-FINISH ALWAYS NEVER THEREIS WHEN IF UNLESS NAMED
RETURN))
(defun parse-type (terminators)
(cond ((end-body) t)
((loop-tmember (peek-body) terminators) t)
(t (pop-body))))
(defmacro aux-bind (v init) `(push (list ,v ,init) *aux-bindings*))
(defun get-it ()
(unless *it* (error "The IT keyword comes in a wrong place."))
(setq *it-is-used* t)
(or *its-name*
(prog1 (setq *its-name* (gensym))
(aux-bind *its-name* nil))))
(defmacro loop *loop-body* "
Syntax: (loop {list-form}* {clause}*)
Upper compatible extension of the Common Lisp LOOP macro. If no CLAUSE is
given, then LOOP simply repeats execution of LIST-FORMs. The use of CLAUSEs
is expected to be compatible with those in Symbolics Common Lisp, with the
following syntax.
clause ::=
REPEAT form [AND more-iteration-clauses]
| {FOR | AS} FOR-clause [AND more-iteration-clauses]
| WITH var [type] [= form]
| {INITIALLY | FINALLY} form {list-form}*
| {DO | DOING} form {list-form}*
| {WHEN | IF | UNLESS} form clause {AND clause}* [ELSE clause {AND clause}*]
| {COLLECT | NCONC | APPEND} {form | IT} [INTO symbol]
| {COUNT | SUM} {form | IT} [INTO symbol] [type]
| {MAXIMIZE | MINIMIZE} {form | IT} [type] [INTO symbol]
| {WHILE | UNTIL | ALWAYS | NEVER | THEREIS} form
| LOOP-FINISH
| NAMED symbol
| NODECLARE symbol-list
| RETURN {form | IT}
FOR-clause ::=
var [type] { FROM form { {TO | DOWNTO | BELOW | ABOVE | BY} form }*
| {DOWNFROM | UPFROM} form [BY form]
| {IN | ON} form [BY form]
| = form [THEN form]
| FIRST form THEN form
| BEING form AND {ITS | EACH} loop-path {key thing}*
| BEING [THE | EACH] loop-path {key thing}*
}
Type declarations are simply ignored in the current version. The only known
differences from Symbolics Common Lisp LOOP are:
1. DEFAULT-LOOP-PATH is not supported simply because I (Taiichi) do
not know in which case I should use the default.
2. No built-in loop-path is defined. In order to define a loop-path,
use DEFINE-LOOP-PATH or DEFINE-LOOP-SEQUENCE-PATH.
See SI:LOOP-TEQUAL, SI:LOOP-TMEMBER, SI:LOOP-TASSOC, and SI:LOOP-NAMED-
VARIABLES."
(let (*bindings* *temps* *aux-bindings*
*prologue* *pre-steps* *body* *post-steps* *epilogue*
*acc* *acclist* *named-block* (*t2* (gensym))
*it* *its-name* *it-is-used*)
(parse-loop-body)
(let* ((identical-steps
(do ((x nil))
((or (endp *pre-steps*)
(endp *post-steps*)
(not (equal (car *pre-steps*) (car *post-steps*))))
x)
(push (pop *pre-steps*) x)
(pop *post-steps*)))
(t1 (gensym))
(template (list 'tagbody))
(form `(block ,*named-block*
,(lv-bind *bindings* *aux-bindings* template))))
(setf (cdr template)
`(,.(nreverse *prologue*)
,.(nreverse
(mapcar #'(lambda (x)
(if (eq (car x) 'when) x (lv-set x)))
*pre-steps*))
,t1
,.(mapcar #'(lambda (x)
(if (eq (car x) 'when) x (lv-set x)))
identical-steps)
,.(nreverse *body*)
,.(nreverse
(mapcar #'(lambda (x)
(if (eq (car x) 'when) x (lv-set x)))
*post-steps*))
(go ,t1)
,*t2*
,.(nreverse *epilogue*)
(return ,*acc*)))
form)))
(defun lv-bind (bindings aux-bindings form)
(let ((sb nil) (pb nil))
(labels ((lv-bind-tree (tree form)
(cond ((null tree))
((atom tree) (push (list tree form) sb))
(t (lv-bind-tree (cdr tree) `(cdr ,form))
(lv-bind-tree (car tree) `(car ,form)))))
(lv-bind-nil (tree)
(cond ((null tree))
((atom tree) (push tree sb))
(t (lv-bind-nil (cdr tree))
(lv-bind-nil (car tree))))))
(dolist (b aux-bindings) (push b sb))
(dolist (bs bindings)
(cond ((endp (cdr bs))
(let ((b (car bs)))
(cond ((or (symbolp b) (symbolp (car b))) (push b sb))
((null (cadr b)) (lv-bind-nil (car b)))
(t (let ((temp (gensym)))
(lv-bind-tree (car b) temp)
(push (list temp (cadr b)) sb)
(push temp *temps*))))))
(t (dolist (b (reverse bs))
(cond ((or (symbolp b) (symbolp (car b))) (push b pb))
((null (cadr b)) (lv-bind-nil (car b)))
(t (let ((temp (gensym)))
(lv-bind-tree (car b) temp)
(push (list temp (cadr b)) pb)
(push temp *temps*)))))
(when sb (setq form `(let* ,sb ,form)) (setq sb nil))
(when pb (setq form `(let ,pb ,form)) (setq pb nil)))))
(if sb `(let* ,sb ,form) form))))
(defun lv-set (sl)
(let ((more-temps nil) (temps *temps*) (ps nil) (ss nil))
(labels ((lv-set-tree (tree form)
(cond ((null tree))
((atom tree) (push form ss) (push tree ss))
(t (lv-set-tree (cdr tree) `(cdr ,form))
(lv-set-tree (car tree) `(car ,form))))))
(cond ((endp (cdr sl))
(let ((s (car sl)))
(cond ((symbolp (car s)) `(setq ,(car s) ,(cadr s)))
((endp temps)
(let ((temp (gensym)))
(lv-set-tree (car s) temp)
`(let ((,temp ,(cadr s))) (setq ,@ss))))
(t (let ((temp (car temps)))
(lv-set-tree (car s) temp)
`(setq ,temp ,(cadr s) ,@ss))))))
(t (dolist (s (reverse sl))
(cond ((symbolp (car s))
(push (cadr s) ps)
(push (car s) ps))
(t (let (temp)
(cond (temps (setq temp (pop temps)))
(t (setq temp (gensym))
(push temp more-temps)))
(push (cadr s) ps) (push temp ps)
(lv-set-tree (car s) temp)))))
(let ((body (if ss `((setq ,@ss)) nil)))
(when ps (push `(psetq ,@ps) body))
(cond (more-temps `(let* ,more-temps ,@body))
((endp (cdr body)) (car body))
(t (cons 'progn body)))))))))
(defun lv-pair-tree (tree form &optional (rest nil))
(cond ((null tree) rest)
((atom tree) (cons (list tree form) rest))
(t (lv-pair-tree (car tree) `(car ,form)
(lv-pair-tree (cdr tree) `(cdr ,form) rest)))))
(defun lv-tree-symbols (tree &optional (more nil))
(cond ((null tree) more)
((atom tree) (cons tree more))
(t (lv-tree-symbols (car tree) (lv-tree-symbols (cdr tree) more)))))
(defun parse-loop-body ()
(when (and (not (end-body))
(not (symbolp (car *loop-body*))))
(parse-do))
(do () ((end-body)) (parse-a-clause)))
(defun parse-a-clause ()
(lkcase
((REPEAT) (do ((inf (parse-repeat)
(merge-inf inf (lkcase (REPEAT (parse-repeat))
((FOR AS) (parse-for))
(WITH (parse-with))
(:ow (parse-repeat))))))
((lkcase (AND nil) (:ow t))
(set-iteration inf))))
((FOR AS) (do ((inf (parse-for)
(merge-inf inf (lkcase (REPEAT (parse-repeat))
((FOR AS) (parse-for))
(WITH (parse-with))
(:ow (parse-for))))))
((lkcase (AND nil) (:ow t))
(set-iteration inf))))
((WITH) (do ((inf (parse-with)
(merge-inf inf (lkcase (REPEAT (parse-repeat))
((FOR AS) (parse-for))
(WITH (parse-with))
(:ow (parse-with))))))
((lkcase (AND nil) (:ow t))
(set-iteration inf))))
((NODECLARE) (pop-body))
((INITIALLY) (parse-initially))
((FINALLY) (parse-finally))
((DO DOING) (parse-do))
((COLLECT COLLECTING) (parse-collect))
((NCONC NCONCING) (parse-nconc))
((APPEND APPENDING) (parse-append))
((COUNT COUNTING) (parse-count))
((SUM SUMMING) (parse-sum))
((MAXIMIZE MAXIMIZING) (parse-maximize))
((MINIMIZE MINIMIZING) (parse-minimize))
((WHILE) (do-it `(unless ,(pop-body) (go ,*t2*))))
((UNTIL) (do-it `(when ,(pop-body) (go ,*t2*))))
((LOOP-FINISH) (do-it `(go ,*t2*)))
((ALWAYS) (do-it `(unless ,(pop-body) (return))))
((NEVER) (do-it `(when ,(pop-body) (return))))
((THEREIS) (parse-thereis))
((WHEN IF) (parse-when t))
((UNLESS) (parse-when nil))
((NAMED) (setq *named-block* (pop-body)))
((RETURN) (do-it `(return ,(lkcase (IT (get-it)) (:ow (pop-body))))))
(:ow (error "~S is an illegal LOOP keyword." (car *loop-body*)))))
(defun merge-inf (inf inf1) (mapcar #'append inf inf1))
(defun set-iteration (inf)
(flet ((make-end-test (tests)
(cond ((cdr tests) `(when (or ,@tests) (go ,*t2*)))
(t `(when ,(car tests) (go ,*t2*))))))
(push (first inf) *bindings*)
(mapcar #'(lambda (x) (push x *prologue*)) (second inf))
(when (third inf) (push (make-end-test (third inf)) *post-steps*))
(when (fourth inf) (push (fourth inf) *post-steps*))
(when (fifth inf) (push (make-end-test (fifth inf)) *post-steps*))
(when (sixth inf) (push (sixth inf) *post-steps*))
(when (seventh inf) (push (make-end-test (seventh inf)) *pre-steps*))
(when (eighth inf) (push (eighth inf) *pre-steps*))
(when (ninth inf) (push (make-end-test (ninth inf)) *pre-steps*))
(when (tenth inf) (push (tenth inf) *pre-steps*))))
(defun parse-repeat ()
(let ((temp (gensym)))
(list `((,temp ,(pop-body))) nil
`((not (plusp ,temp))) `((,temp (1- ,temp))) nil nil
`((not (plusp ,temp))) `((,temp (1- ,temp))) nil nil)))
(defun parse-for ()
(let ((v (pop-body)))
(parse-type '(FROM DOWNFROM UPFROM IN ON = FIRST BEING))
(lkcase
(FROM (let ((init (pop-body)) test limit (step-fun '+) (step 1))
(lkcase
(TO (setq test '> limit (pop-body))
(lkcase (BY (setq step (pop-body)))))
(DOWNTO (setq test '< limit (pop-body) step-fun '-)
(lkcase (BY (setq step (pop-body)))))
(BELOW (setq test '>= limit (pop-body))
(lkcase (BY (setq step (pop-body)))))
(ABOVE (setq test '<= limit (pop-body) step-fun '-)
(lkcase (BY (setq step (pop-body)))))
(BY (setq step (pop-body))
(lkcase
(TO (setq test '> limit (pop-body)))
(DOWNTO (setq test '< limit (pop-body) step-fun '-))
(BELOW (setq test '>= limit (pop-body)))
(ABOVE (setq test '<= limit (pop-body) step-fun '-)))))
(parse-for1 v init test limit step-fun step)))
(DOWNFROM
(parse-for1 v (pop-body) nil nil '- (lkcase (BY (pop-body)) (:ow 1))))
(UPFROM
(parse-for1 v (pop-body) nil nil '+ (lkcase (BY (pop-body)) (:ow 1))))
(IN (let* ((form (pop-body))
(fun (lkcase (BY (pop-body)) (:ow '#'cdr)))
(temp (gensym))
(inf (list nil nil
nil nil `((endp ,temp)) nil
nil nil `((endp ,temp)) nil)))
(cond ((and (consp fun) (eq (car fun) 'function))
(push `(,temp (,(cadr fun) ,temp)) (fourth inf)))
((constantp fun)
(push `(,temp (funcall ,fun ,temp)) (fourth inf)))
(t (let ((temp1 (gensym)))
(push (list temp1 fun) (first inf))
(push `(,temp (funcall ,temp1 ,temp)) (fourth inf)))))
(push (list temp form) (first inf))
(cond ((symbolp v)
(push `(,v (car ,temp)) (sixth inf))
(push `(,v (car ,temp)) (tenth inf))
(push v (first inf)))
(t (let ((pairs (lv-pair-tree v `(car ,temp))))
(setf (sixth inf) pairs)
(setf (tenth inf) pairs))
(mapc #'(lambda (x) (push x (first inf)))
(nreverse (lv-tree-symbols v)))))
inf))
(ON (let* ((form (pop-body))
(fun (lkcase (BY (pop-body)) (:ow '#'cdr))))
(cond ((symbolp v)
(let ((inf (list nil nil
nil nil `((endp ,v)) nil
nil nil `((endp ,v)) nil)))
(cond ((and (consp fun) (eq (car fun) 'function))
(push `(,v (,(cadr fun) ,v)) (fourth inf)))
(t (unless (constantp fun)
(let ((temp1 (gensym)))
(push (list temp1 fun) (first inf))
(setq fun temp1)))
(push `(,v (funcall ,fun ,v)) (fourth inf))))
(push (list v form) (first inf))
inf))
(t (let* ((temp (gensym))
(pairs (lv-pair-tree v temp))
(inf (list nil nil
nil nil `((endp ,temp)) pairs
nil nil `((endp ,temp)) pairs)))
(cond ((and (consp fun) (eq (car fun) 'function))
(push `(,temp (,(cadr fun) ,temp))
(fourth inf)))
(t (unless (constantp fun)
(let ((temp1 (gensym)))
(push (list temp1 fun) (first inf))
(setq fun temp1)))
(push `(,temp (funcall ,fun ,temp))
(fourth inf))))
(push (list temp form) (first inf))
(mapc #'(lambda (x) (push x (first inf)))
(nreverse (lv-tree-symbols v)))
inf)))))
(= (let* ((init (pop-body)))
(lkcase (THEN (list `((,v ,init)) nil
nil `((,v ,(pop-body))) nil nil
nil nil nil nil))
(:ow (list `((,v nil)) nil
nil `((,v ,init)) nil nil
nil `((,v ,init)) nil nil)))))
(FIRST (let* ((init (pop-body))
(form (lkcase (THEN (pop-body))
(:ow (error "THEN missing after FIRST.")))))
(list `((,v nil)) nil
nil `((,v ,form)) nil nil
nil `((,v ,init)) nil nil)))
(BEING (parse-loop-path v))
(:ow (error "~S is an illegal LOOP keyword" (car *loop-body*))))))
(defun parse-for1 (v init test limit step-fun step)
(unless (symbolp v)
(error "The FOR control variable ~S cannot be destructured." v))
(let ((inf (make-list 10)))
(unless (numberp step)
(let ((temp (gensym)))
(push (list temp step) (first inf))
(setq step temp)))
(when test
(unless (numberp limit)
(let ((temp (gensym)))
(push (list temp limit) (first inf))
(setq limit temp)))
(let ((x (list test v limit)))
(push x (fifth inf))
(push x (ninth inf))))
(push (list v init) (first inf))
(push (list v (list step-fun v step)) (fourth inf))
inf))
(defun parse-loop-path (v)
(let ((flag nil) (pps nil) path (*loop-named-variables* nil))
(lkcase
((EACH THE) (setq path (pop-body)))
(:ow (setq path (pop-body))
(lkcase
(AND (setq flag t)
(push (list 'of (pop-body)) pps)
(lkcase
((ITS EACH HIS HER THEIR)
(setq path (pop-body)))
(:ow (error "ITS is missing after FOR..BEING..AND.")))))))
(unless (symbolp path)
(error "The LOOP path-name ~S is not a symbol." path))
(let ((def (gethash (symbol-name path) *loop-paths*)))