#-sacla
(progn
(defpackage "SACLA-LOOP"
(:documentation "An ANSI Common Lisp Loop facility.")
(:use "COMMON-LISP")
(:shadow "ERROR" "WARN" "LOOP" "LOOP-FINISH")
(:export "LOOP" "LOOP-FINISH"))
(in-package "SACLA-LOOP"))
#-sacla
(progn
(defvar *message-prefix* "")
(defun error (datum &rest arguments)
(when (stringp datum)
(setq datum (concatenate 'string *message-prefix* datum)))
(apply #'cl:error datum arguments))
(defun warn (datum &rest arguments)
(when (stringp datum)
(setq datum (concatenate 'string *message-prefix* datum)))
(apply #'cl:warn datum arguments))
(defun %list (designator)
(if (listp designator) designator (list designator)))
(defun %keyword (designator)
(intern (string designator) "KEYWORD"))
(define-modify-macro appendf (&rest args) append "Append onto list")
(defun mapappend (function &rest lists)
(apply #'append (apply #'mapcar function lists)))
(define-condition simple-program-error (simple-condition program-error) ())
)
(defun globally-special-p (symbol)
(assert (symbolp symbol))
(if (constantp symbol)
(values nil t)
#+allegro (values (excl::variable-special-p symbol nil) t)
#+lispworks (values (eq :special (hcl:variable-information symbol)) t)
#+clisp (values (ext:special-variable-p symbol nil) t)
#+cmu (values (walker:variable-globally-special-p symbol) t)
#+sbcl (values (sb-walker:var-globally-special-p symbol) t)
#+gcl (values (si:specialp symbol) t)
#+ecl (values (si:specialp symbol) t)
#-(or allegro lispworks clisp cmu sbcl gcl ecl)
(progn
(warn "Implementation-specific globally-special-p should be defined.")
(values nil nil))))
(defvar *loop-clauses*
(let ((table (make-hash-table)))
(mapc #'(lambda (spec)
(destructuring-bind (clause-name . keywords) spec
(dolist (key keywords) (setf (gethash key table) clause-name))))
'((for-as-clause :for :as)
(with-clause :with)
(do-clause :do :doing)
(return-clause :return)
(initially-clause :initially)
(finally-clause :finally)
(accumulation-clause :collect :collecting :append :appending
:nconc :nconcing :count :counting :sum :summing :maximize :maximizing
:minimize :minimizing)
(conditional-clause :if :when :unless)
(repeat-clause :repeat)
(always-never-thereis-clause :always :never :thereis)
(while-clause :while)
(until-clause :until)))
table)
"A table mapping loop keywords to their processor function-designator.")
(defvar *for-as-subclauses*
(let ((table (make-hash-table)))
(mapc #'(lambda (spec)
(destructuring-bind (subclause-name . keywords) spec
(dolist (key keywords)
(setf (gethash key table) subclause-name))))
'((for-as-arithmetic-subclause
:from :downfrom :upfrom :to :downto :upto :below :above :by)
(for-as-in-list-subclause :in)
(for-as-on-list-subclause :on)
(for-as-equals-then-subclause :=)
(for-as-across-subclause :across)
(for-as-being-subclause :being)))
table)
"A table mapping for-as prepositions to their processor function-designator.")
(defvar *for-as-prepositions*
(let ((prepositions nil))
(maphash #'(lambda (key value) (declare (ignore value)) (push key prepositions))
*for-as-subclauses*)
prepositions))
(defvar *environment*)
(defvar *loop-tokens*)
(defvar *current-keyword* nil)
(defvar *current-clause* nil)
(defun append-context (message)
(concatenate 'string message
(let ((clause (ldiff *current-clause* *loop-tokens*)))
(format nil "~%Current LOOP context:~{ ~S~}" clause))))
(defun loop-error (datum &rest arguments)
(when (stringp datum) (setq datum (append-context datum)))
(apply #'error datum arguments))
(defun loop-warn (datum &rest arguments)
(when (stringp datum) (setq datum (append-context datum)))
(apply #'warn datum arguments))
(defun keyword? (&optional keyword-list-designator)
(and *loop-tokens*
(symbolp (car *loop-tokens*))
(let ((keyword-list (%list keyword-list-designator))
(keyword (%keyword (car *loop-tokens*))))
(and (or (null keyword-list) (find keyword keyword-list))
(setq *current-clause* *loop-tokens*
*loop-tokens* (rest *loop-tokens*)
*current-keyword* keyword)))))
(defun keyword1 (keyword-list-designator &key prepositionp)
(let ((keywords (%list keyword-list-designator)))
(or (keyword? keywords)
(let ((length (length keywords))
(kind (if prepositionp "preposition" "keyword")))
(case length
(0 (loop-error "A loop ~A is missing." kind))
(1 (loop-error "Loop ~A ~S is missing." kind (car keywords)))
(t (loop-error "One of the loop ~As ~S must be supplied."
kind keywords)))))))
(defun preposition? (&optional keyword-list-designator)
(let ((*current-keyword* *current-keyword*)
(*current-clause* *current-clause*))
(keyword? keyword-list-designator)))
(defun preposition1 (&optional keyword-list-designator)
(let ((*current-keyword* *current-keyword*)
(*current-clause* *current-clause*))
(keyword1 keyword-list-designator :prepositionp t)))
(defvar *loop-name* nil)
(defvar *it-symbol* nil)
(defvar *it-visible-p* nil)
(defvar *anonymous-accumulator* nil)
(defvar *boolean-terminator* nil)
(defvar *accumulators* nil)
(defvar *loop-components* nil)
(defun clause1 ()
(multiple-value-bind (clause-function-designator present-p)
(gethash *current-keyword* *loop-clauses*)
(unless present-p
(loop-error "Unknown loop keyword ~S encountered." (car *current-clause*)))
(let ((*message-prefix* (format nil "LOOP ~A clause: " *current-keyword*)))
(funcall clause-function-designator))))
(defun clause* ()
(loop
(let ((key (keyword?)))
(unless key (return))
(clause1))))
(defun lp (&rest tokens)
(let ((*loop-tokens* tokens)
*current-keyword*
*current-clause*)
(clause*)
(when *loop-tokens* (error "~S remained after lp." *loop-tokens*))))
(defun form1 ()
(unless *loop-tokens* (loop-error "A normal lisp form is missing."))
(pop *loop-tokens*))
(defun compound-forms* ()
(when (and *loop-tokens* (consp (car *loop-tokens*)))
(cons (pop *loop-tokens*) (compound-forms*))))
(defun compound-forms+ ()
(or (compound-forms*) (loop-error "At least one compound form is needed.")))
(defun simple-var-p (var) (and (not (null var)) (symbolp var)))
(defun simple-var1 ()
(unless (and *loop-tokens* (simple-var-p (car *loop-tokens*)))
(loop-error "A simple variable name is missing."))
(pop *loop-tokens*))
(defun empty-p (d-var-spec)
(or (null d-var-spec)
(and (consp d-var-spec)
(empty-p (car d-var-spec))
(empty-p (cdr d-var-spec)))))
(defun d-var-spec-p (spec)
(or (simple-var-p spec)
(null spec)
(and (consp spec) (d-var-spec-p (car spec)) (d-var-spec-p (cdr spec)))))
(defun d-var-spec1 ()
(unless (and *loop-tokens* (d-var-spec-p (car *loop-tokens*)))
(loop-error "A destructured-variable-spec is missing."))
(let ((d-var-spec (pop *loop-tokens*)))
d-var-spec))
(defun stray-of-type-error ()
(loop-error "OF-TYPE keyword should be followed by a type spec."))
(defun type-spec? ()
(let ((type t)
(supplied-p nil))
(when (or (and (preposition? :of-type) (or *loop-tokens* (stray-of-type-error)))
(and *loop-tokens* (member (car *loop-tokens*) '(fixnum float t nil))))
(setq type (pop *loop-tokens*) supplied-p t))
(values type supplied-p)))
(defun car-type (d-type-spec)
(if (consp d-type-spec) (car d-type-spec) d-type-spec))
(defun cdr-type (d-type-spec)
(if (consp d-type-spec) (cdr d-type-spec) d-type-spec))
(defun default-value (type)
(cond
((subtypep type 'bignum) (1+ most-positive-fixnum))
((subtypep type 'integer) 0)
((subtypep type 'ratio) 1/10)
((subtypep type 'float) 0.0)
((subtypep type 'number) 0)
((subtypep type 'character) #\Space)
((subtypep type 'string) "")
((subtypep type 'bit-vector) #*0)
((subtypep type 'vector) #())
((subtypep type 'package) *package*)
(t nil)))
(defun default-type (type)
(if (eq type t)
t
(let ((value (default-value type)))
(if (typep value type)
type
(let ((default-type (type-of value)))
(if (subtypep type default-type)
default-type
(if (null value)
`(or null ,type)
`(or ,default-type ,type))))))))
(defun default-binding (type var)
`(,(default-type type) ,var ,(default-value type)))
(defvar *temporaries* nil
"Temporary variables used in with-clauses and for-as-clauses.")
(defvar *ignorable* nil
"Ignorable temporary variables in *temporaries*.")
(defun constant-bindings (d-type-spec d-var-spec value)
(let ((bindings nil))
(labels ((dig (type var value)
(cond
((null var) nil) ((simple-var-p var) (appendf bindings `((,type ,var ',value))))
(t (dig (car-type type) (car var) (car value))
(dig (cdr-type type) (cdr var) (cdr value))))))
(dig d-type-spec d-var-spec value)
bindings)))
(defun default-bindings (d-type-spec d-var-spec)
(let ((bindings nil))
(labels ((dig (type var)
(cond
((null var) nil) ((simple-var-p var)
(appendf bindings `(,(default-binding type var))))
(t (dig (car-type type) (car var))
(dig (cdr-type type) (cdr var))))))
(dig d-type-spec d-var-spec)
bindings)))
(defun ordinary-bindings (d-type-spec d-var-spec value-form)
(let ((temporaries *temporaries*)
(bindings nil))
(labels
((dig (type var form temp)
(cond
((empty-p var) nil)
((simple-var-p var)
(when temp (push temp temporaries))
(appendf bindings `((,type ,var ,form))))
((empty-p (car var))
(dig (cdr-type type) (cdr var) `(cdr ,form) temp))
((empty-p (cdr var))
(when temp (push temp temporaries))
(dig (car-type type) (car var) `(car ,form) nil))
(t (unless temp (setq temp (or (pop temporaries) (gensym))))
(dig (car-type type) (car var) `(car (setq ,temp ,form)) nil)
(dig (cdr-type type) (cdr var) `(cdr ,temp) temp)))))
(dig d-type-spec d-var-spec value-form nil)
(setq *temporaries* temporaries)
bindings)))
(defun quoted-form-p (form)
(let ((expansion (macroexpand form *environment*)))
(and (consp expansion) (eq (first expansion) 'quote))))
(defun quoted-object (form)
(let ((expansion (macroexpand form *environment*)))
(destructuring-bind (quote-special-operator object) expansion
(assert (eq quote-special-operator 'quote))
object)))
(defun bindings (d-type-spec d-var-spec
&optional (value-form "NEVER USED" value-form-p))
(cond
((null value-form-p) (default-bindings d-type-spec d-var-spec))
((quoted-form-p value-form) (constant-bindings d-type-spec d-var-spec
(quoted-object value-form)))
(t (ordinary-bindings d-type-spec d-var-spec value-form))))
(defun fill-in (&rest args)
(when args
(appendf (getf *loop-components* (first args)) (second args))
(apply #'fill-in (cddr args))))
(defun declarations (bindings)
(let ((declarations (mapcan #'(lambda (binding)
(destructuring-bind (type var . rest) binding
(declare (ignore rest))
(unless (eq type 't) `((type ,type ,var)))))
bindings)))
(when declarations `((declare ,@declarations)))))
(defun let-form (bindings) `(let ,(mapcar #'cdr bindings) ,@(declarations bindings)))
(defun with (var &optional (type t) &key (= (default-value type)))
(fill-in :binding-forms `(,(let-form `((,type ,var ,=))))))
(defun multiple-value-list-form-p (form)
(let (expanded-p)
(loop
(when (and (consp form) (eq (first form) 'multiple-value-list))
(return t))
(multiple-value-setq (form expanded-p) (macroexpand-1 form *environment*))
(unless expanded-p (return nil)))))
(defun multiple-value-list-argument-form (form)
(let ((expansion form)
(expanded-p nil))
(loop
(when (and (consp expansion) (eq (first expansion) 'multiple-value-list))
(return (second expansion)))
(multiple-value-setq (expansion expanded-p)
(macroexpand-1 expansion *environment*))
(unless expanded-p
(error "~S is not expanded into a multiple-value-list form." form)))))
(defun destructuring-multiple-value-bind (d-type-spec d-var-spec value-form)
(let ((mv-bindings nil)
(d-bindings nil)
(padding-temps nil)
temp)
(do ((vars d-var-spec (cdr vars))
(types d-type-spec (cdr-type types)))
((endp vars))
(if (listp (car vars))
(progn (setq temp (gensym))
(appendf mv-bindings `((t ,temp)))
(appendf d-bindings `((,(car-type types) ,(car vars) ,temp)))
(when (empty-p (car vars)) (push temp padding-temps)))
(appendf mv-bindings `((,(car-type types) ,(car vars))))))
(fill-in :binding-forms `((multiple-value-bind ,(mapcar #'second mv-bindings)
,(multiple-value-list-argument-form value-form)
,@(declarations mv-bindings)
,@(when padding-temps
`((declare (ignore ,@padding-temps)))))))
(let ((bindings (mapappend #'(lambda (d-binding) (apply #'bindings d-binding))
d-bindings)))
(when bindings (fill-in :binding-forms `(,(let-form bindings)))))))
(defun d-var-type-spec ()
(let ((var (d-var-spec1))
(type (type-spec?)))
(when (empty-p var)
(unless (member type '(nil t)) (loop-warn "Type spec ~S is ignored." type))
(setq var (gensym)
type t))
(values var type)))
(defun with-clause ()
(let ((d-bindings nil))
(loop (multiple-value-bind (var type) (d-var-type-spec)
(let ((rest (when (preposition? :=) `(,(form1)))))
(appendf d-bindings `((,type ,var ,@rest)))))
(unless (preposition? :and) (return)))
(destructuring-bind (d-binding0 . rest) d-bindings
(if (and (null rest)
(cddr d-binding0)
(destructuring-bind (type var form) d-binding0
(declare (ignore type))
(and (consp var) (multiple-value-list-form-p form))))
(apply #'destructuring-multiple-value-bind d-binding0)
(let ((bindings (mapappend #'(lambda (d-binding)
(apply #'bindings d-binding))
d-bindings)))
(fill-in :binding-forms `(,(let-form bindings))))))))
(defun dispatch-for-as-subclause (var type)
(unless *loop-tokens* (loop-error "A preposition is missing."))
(let ((preposition (preposition1 *for-as-prepositions*)))
(multiple-value-bind (subclause-function-designator present-p)
(gethash preposition *for-as-subclauses*)
(unless present-p
(loop-error "Unknown preposition ~S is supplied." preposition))
(push preposition *loop-tokens*)
(funcall subclause-function-designator var type))))
(defun for (var type &rest rest)
(let ((*loop-tokens* rest))
(dispatch-for-as-subclause var type)))
(defvar *for-as-components*)
(defun for-as-fill-in (&rest key-list-pairs)
(when key-list-pairs
(destructuring-bind (key list . rest) key-list-pairs
(appendf (getf *for-as-components* key) list)
(apply #'for-as-fill-in rest))))
(defvar *hash-group* '(:hash-key :hash-keys :hash-value :hash-values))
(defvar *symbol-group* '(:symbol :symbols :present-symbol :present-symbols
:external-symbol :external-symbols))
(defun loop-finish-test-forms (tests)
(case (length tests)
(0 nil)
(1 `((when ,@tests (loop-finish))))
(t `((when (or ,@tests) (loop-finish))))))
(defun psetq-forms (args)
(assert (evenp (length args)))
(case (length args)
(0 nil)
(2 `((setq ,@args)))
(t `((psetq ,@args)))))
(defun for-as-clause ()
(let ((*for-as-components* nil))
(loop (multiple-value-bind (var type) (d-var-type-spec)
(dispatch-for-as-subclause var type))
(unless (preposition? :and) (return)))
(destructuring-bind (&key bindings bindings2
before-head head-psetq head-tests after-head
before-tail tail-psetq tail-tests after-tail)
*for-as-components*
(fill-in :binding-forms `(,@(when bindings `(,(let-form bindings)))
,@(when bindings2 `(,(let-form bindings2))))
:head `(,@before-head
,@(psetq-forms head-psetq)
,@(loop-finish-test-forms head-tests)
,@after-head)
:tail `(,@before-tail
,@(psetq-forms tail-psetq)
,@(loop-finish-test-forms tail-tests)
,@after-tail)))))
(defun for-as-parallel-p ()
(or *for-as-components*
(and *loop-tokens*
(symbolp (car *loop-tokens*))
(string= (symbol-name (car *loop-tokens*)) "AND"))))
(defun gensym-ignorable ()
(let ((var (gensym)))
(push var *ignorable*)
var))
(defun destructuring-multiple-value-setq (d-var-spec value-form &key iterator-p)
(let (d-bindings mv-vars temp)
(do ((vars d-var-spec (cdr vars)))
((endp vars))
(if (listp (car vars))
(progn (setq temp (or (pop *temporaries*) (gensym-ignorable)))
(appendf mv-vars `(,temp))
(appendf d-bindings `((t ,(car vars) ,temp))))
(appendf mv-vars `(,(car vars)))))
(let ((mv-setq-form `(multiple-value-setq ,mv-vars ,value-form))
(bindings nil))
(do ((d-bindings d-bindings (cdr d-bindings)))
((endp d-bindings))
(destructuring-bind (type var temp) (car d-bindings)
(declare (ignore type var))
(push temp *temporaries*)
(appendf bindings (apply #'bindings (car d-bindings)))))
(when iterator-p (setq mv-setq-form `(unless ,mv-setq-form (loop-finish))))
(if bindings
`(progn ,mv-setq-form (setq ,@(mapappend #'cdr bindings)))
mv-setq-form))))
(defun along-with (var type &key equals (then equals))
(for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p equals)
`(,equals))))
(unless (quoted-form-p equals)
(for-as-fill-in :after-head
`((setq ,@(mapappend #'cdr (bindings type var equals))))))
(for-as-fill-in :after-tail
`((setq ,@(mapappend #'cdr (bindings type var then))))))
(defun for-as-equals-then-subclause (var type)
(preposition1 :=)
(let* ((first (form1))
(then (if (preposition? :then) (form1) first))
(parallel-p (for-as-parallel-p)))
(for-as-fill-in :bindings (apply #'bindings type var (when (quoted-form-p first)
`(,first))))
(if (and (not parallel-p) (consp var) (multiple-value-list-form-p first))
(for-as-fill-in :before-head
`(,(destructuring-multiple-value-setq var
(multiple-value-list-argument-form first))))
(unless (quoted-form-p first)
(for-as-fill-in :head-psetq (mapappend #'cdr (bindings type var first)))))
(if (and (not parallel-p) (consp var) (multiple-value-list-form-p then))
(for-as-fill-in :before-tail
`(,(destructuring-multiple-value-setq var
(multiple-value-list-argument-form then))))
(for-as-fill-in :tail-psetq (mapappend #'cdr (bindings type var then))))))
(defun for-as-arithmetic-step-and-test-functions (used-prepositions)
(let ((up-p (subsetp used-prepositions '(:below :upto :upfrom :from :to :by))))
(values (if up-p '+ '-)
(cond ((member :to used-prepositions) (if up-p '> '<))
((member :upto used-prepositions) '>)
((member :below used-prepositions) '>=)
((member :downto used-prepositions) '<)
((member :above used-prepositions) '<=)
(t nil)))))
(defun zero (type)
(cond
((subtypep type 'short-float) 0.0s0)
((subtypep type 'single-float) 0.0f0)
((subtypep type 'double-float) 0.0d0)
((subtypep type 'long-float) 0.0l0)
((subtypep type 'float) 0.0)
(t 0)))
(defun one (type)
(cond
((subtypep type 'short-float) 1.0s0)
((subtypep type 'single-float) 1.0f0)
((subtypep type 'double-float) 1.0d0)
((subtypep type 'long-float) 1.0l0)
(t 1)))
(defun for-as-arithmetic-possible-prepositions (used-prepositions)
(append
(cond
((intersection '(:from :downfrom :upfrom) used-prepositions) nil)
((intersection '(:downto :above) used-prepositions) '(:from :downfrom))
((intersection '(:upto :below) used-prepositions) '(:from :upfrom))
(t '(:from :downfrom :upfrom)))
(cond
((intersection '(:to :downto :upto :below :above) used-prepositions) nil)
((find :upfrom used-prepositions) '(:to :upto :below))
((find :downfrom used-prepositions) '(:to :downto :above))
(t '(:to :downto :upto :below :above)))
(unless (find :by used-prepositions) '(:by))))
(defun for-as-arithmetic-subclause (var type)
(unless (simple-var-p var) (loop-error "Destructuring on a number is invalid."))
(multiple-value-bind (subtype-p valid-p) (subtypep type 'real)
(when (and (not subtype-p) valid-p) (setq type 'real)))
(let (from to by preposition used candidates bindings)
(loop (setq candidates (or (for-as-arithmetic-possible-prepositions used)
(return)))
(push (or (setq preposition (preposition? candidates)) (return))
used)
(let ((value-form (form1)))
(if (member preposition '(:from :downfrom :upfrom))
(progn (setq from value-form)
(appendf bindings `((,type ,var ,from))))
(progn (when (not (constantp value-form *environment*))
(let ((temp (gensym)))
(appendf bindings `((number ,temp ,value-form)))
(setq value-form temp)))
(ecase preposition
((:to :downto :upto :below :above) (setq to value-form))
(:by (setq by value-form)))))))
(unless (intersection used '(:from :downfrom :upfrom))
(appendf bindings `((,type ,var ,(zero type)))))
(multiple-value-bind (step test) (for-as-arithmetic-step-and-test-functions used)
(let ((tests (when test `((,test ,var ,to)))))
(for-as-fill-in :bindings bindings
:head-tests tests
:tail-psetq `(,var (,step ,var ,(or by (one type))))
:tail-tests tests)))))
(defun cl-external-p (symbol)
(multiple-value-bind (cl-symbol status)
(find-symbol (symbol-name symbol) "CL")
(and (eq symbol cl-symbol) (eq status :external))))
(defun constant-function-p (form)
(let ((expansion (macroexpand form *environment*)))
(and (consp expansion)
(eq (first expansion) 'function)
(symbolp (second expansion))
(let ((symbol (second expansion)))
(and (cl-external-p symbol) (fboundp symbol))))))
(defvar *list-end-test* 'atom)
(defun by-step-fun () (if (preposition? :by) (form1) '#'cdr))
(defun for-as-on-list-subclause (var type)
(preposition1 :on)
(let* ((form (form1))
(by-step-fun (by-step-fun))
(test *list-end-test*)
(list-var (if (simple-var-p var) var (gensym "LIST-")))
(list-type (if (simple-var-p var) type t))
(at-least-one-iteration-p (and (quoted-form-p form)
(not (funcall test (quoted-object form))))))
(for-as-fill-in :bindings `((,list-type ,list-var ,form)
,@(unless (constant-function-p by-step-fun)
(let ((temp (gensym "STEPPER-")))
(prog1 `((t ,temp ,by-step-fun))
(setq by-step-fun temp)))))
:head-tests (unless at-least-one-iteration-p
`((,test ,list-var)))
:tail-psetq `(,list-var (funcall ,by-step-fun ,list-var))
:tail-tests `((,test ,list-var)))
(unless (simple-var-p var)
(along-with var type :equals (if at-least-one-iteration-p form list-var)
:then list-var))))
(defun for-as-in-list-subclause (var type)
(preposition1 :in)
(let ((*list-end-test* 'endp))
(for `(,var) `(,type) :on (form1) :by (by-step-fun))))
(defun constant-vector-p (form) (or (quoted-form-p form) (vectorp form)))
(defun constant-vector (form)
(cond
((quoted-form-p form) (quoted-object form))
((vectorp form) form)
(t (error "~S is not a vector form." form))))
(defun for-as-across-subclause (var type)
(preposition1 :across)
(let* ((form (form1))
(vector (if (constant-vector-p form) form (gensym "VECTOR-")))
(length (if (constant-vector-p form)
(length (constant-vector form))
(gensym "LENGTH-")))
(i (gensym "INDEX-"))
(at-least-one-iteration-p (and (constant-vector-p form) (plusp length))))
(unless (constant-vector-p form)
(for-as-fill-in :bindings `((t ,vector ,form))
:bindings2 `((fixnum ,length (length ,vector)))))
(for-as-fill-in :bindings `((fixnum ,i 0))
:head-tests (unless at-least-one-iteration-p `((= ,i ,length)))
:tail-psetq `(,i (1+ ,i))
:tail-tests `((= ,i ,length)))
(along-with var type :equals (if at-least-one-iteration-p
`',(aref (constant-vector form) 0)
`(aref ,vector ,i))
:then `(aref ,vector ,i))))
(defun using-other-var (kind)
(let ((using-phrase (when (preposition? :using) (pop *loop-tokens*)))
(other-key-name (if (find kind '(:hash-key :hash-keys))
"HASH-VALUE"
"HASH-KEY")))
(when using-phrase
(destructuring-bind (other-key other-var) using-phrase
(unless (string= other-key other-key-name)
(loop-error "Keyword ~A is missing." other-key-name))
other-var))))
(defun hash-d-var-spec (returned-p var other-var kind)
(if (find kind '(:hash-key :hash-keys))
`(,returned-p ,var ,other-var)
`(,returned-p ,other-var ,var)))
(defun for-as-hash-subclause (var type kind)
(let* ((hash-table (progn (preposition1 '(:in :of)) (form1)))
(other-var (using-other-var kind))
(for-as-parallel-p (for-as-parallel-p))
(returned-p (or (pop *temporaries*) (gensym-ignorable)))
(iterator (gensym))
narrow-typed-var narrow-type)
(when (and (simple-var-p var) (not (typep 'nil type)))
(setq narrow-typed-var var
narrow-type type)
(setq var (gensym)
type `(or null ,type))
(for-as-fill-in :bindings `(,(default-binding narrow-type narrow-typed-var))))
(flet ((iterator-form () `(with-hash-table-iterator (,iterator ,hash-table))))
(if for-as-parallel-p
(progn (unless (constantp hash-table *environment*)
(let ((temp (gensym "HASH-TABLE-")))
(for-as-fill-in :bindings `((t ,temp ,hash-table)))
(setq hash-table temp)))
(fill-in :iterator-forms `(,(iterator-form))))
(fill-in :binding-forms `(,(iterator-form)))))
(let* ((d-var-spec (hash-d-var-spec returned-p var other-var kind))
(d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator)
:iterator-p t))
(setters `(,d-mv-setq
,@(when narrow-typed-var `((setq ,narrow-typed-var ,var))))))
(push returned-p *temporaries*)
(for-as-fill-in :bindings `(,@(bindings type var)
,@(when other-var (bindings t other-var)))
:after-head setters
:after-tail setters))))
(defun for-as-package-subclause (var type kind)
(let* ((package (if (preposition? '(:in :of)) (form1) '*package*))
(for-as-parallel-p (for-as-parallel-p))
(returned-p (or (pop *temporaries*) (gensym-ignorable)))
(iterator (gensym))
(kinds (ecase kind
((:symbol :symbols) '(:internal :external :inherited))
((:present-symbol :present-symbols) '(:internal :external))
((:external-symbol :external-symbols) '(:external)))))
(unless (typep 'nil type) (setq type `(or null ,type)))
(flet ((iterator-form () `(with-package-iterator (,iterator ,package ,@kinds))))
(if for-as-parallel-p
(progn (unless (constantp package *environment*)
(let ((temp (gensym "PACKAGE-")))
(for-as-fill-in :bindings `((t ,temp ,package)))
(setq package temp)))
(fill-in :iterator-forms `(,(iterator-form))))
(fill-in :binding-forms `(,(iterator-form)))))
(let* ((d-var-spec `(,returned-p ,var))
(d-mv-setq (destructuring-multiple-value-setq d-var-spec `(,iterator)
:iterator-p t)))
(push returned-p *temporaries*)
(for-as-fill-in :bindings (bindings type var)
:after-head `(,d-mv-setq)
:after-tail `(,d-mv-setq)))))
(defun for-as-being-subclause (var type)
(preposition1 :being)
(preposition1 '(:each :the))
(let* ((kind (preposition1 (append *hash-group* *symbol-group*))))
(cond
((find kind *hash-group*) (for-as-hash-subclause var type kind))
((find kind *symbol-group*) (for-as-package-subclause var type kind))
(t (loop-error "Internal logic error")))))
(defun form-or-it ()
(if (and *it-visible-p* (preposition? :it))
(or *it-symbol* (setq *it-symbol* (gensym)))
(form1)))
(defun enumerate (items)
(case (length items)
(1 (format nil "~S" (first items)))
(2 (format nil "~S and ~S" (first items) (second items)))
(t (format nil "~{~S, ~}and ~S" (butlast items) (first (last items))))))
(defun invalid-accumulator-combination-error (keys)
(loop-error "Accumulator ~S cannot be mixed with ~S."
*current-keyword* (enumerate keys)))
(defun accumulator-kind (key)
(ecase key
((:collect :collecting :append :appending :nconc :nconcing) :list)
((:sum :summing :count :counting) :total)
((:maximize :maximizing :minimize :minimizing) :limit)))
(defun accumulator-spec (name)
(let* ((kind (accumulator-kind *current-keyword*))
(spec (cdr (assoc name *accumulators*))))
(if spec
(if (not (eq kind (getf spec :kind)))
(invalid-accumulator-combination-error (reverse (getf spec :keys)))
(progn
(pushnew *current-keyword* (getf spec :keys))
(when (member kind '(:total :limit))
(multiple-value-bind (type supplied-p) (type-spec?)
(when supplied-p (push type (getf spec :types)))))))
(let ((var (or name (gensym "ACCUMULATOR-"))))
(setq spec `(:var ,var :kind ,kind :keys (,*current-keyword*)))
(ecase kind
(:list (setf (getf spec :splice) (gensym "SPLICE-"))
(unless name (fill-in :results `((cdr ,var)))))
((:total :limit)
(multiple-value-bind (type supplied-p) (type-spec?)
(when supplied-p (push type (getf spec :types))))
(when (eq kind :limit)
(let ((first-p (gensym "FIRST-P-")))
(setf (getf spec :first-p) first-p)
(with first-p t := t)))
(unless name (fill-in :results `(,var)))))
(push `(,name ,@spec) *accumulators*)))
spec))
(defun ambiguous-loop-result-error ()
(error 'simple-program-error
:format-control
(append-context "~S cannot be used without `into' preposition with ~S")
:format-arguments `(,*anonymous-accumulator* ,*boolean-terminator*)))
(defun accumulate-in-list (form accumulator)
(destructuring-bind (&key var splice &allow-other-keys) accumulator
(let* ((copy-f (ecase *current-keyword*
((:collect :collecting) 'list)
((:append :appending) 'copy-list)
((:nconc :nconcing) 'identity)))
(collecting-p (member *current-keyword* '(:collect :collecting)))
(last-f (if collecting-p 'cdr 'last))
(splicing-form (if collecting-p
`(rplacd ,splice (setq ,splice (list ,form)))
`(setf (cdr ,splice) (,copy-f ,form)
,splice (,last-f ,splice)))))
(if (globally-special-p var)
(lp :do `(if ,splice
,splicing-form
(setq ,splice (,last-f (setq ,var (,copy-f ,form))))))
(lp :do splicing-form)))))
(defun accumulation-clause ()
(let* ((form (form-or-it))
(name (if (preposition? :into)
(simple-var1)
(progn
(setq *anonymous-accumulator* *current-keyword*)
(when *boolean-terminator* (ambiguous-loop-result-error))
nil)))
(accumulator-spec (accumulator-spec name)))
(destructuring-bind (&key var &allow-other-keys) accumulator-spec
(ecase *current-keyword*
((:collect :collecting :append :appending :nconc :nconcing)
(accumulate-in-list form accumulator-spec))
((:count :counting) (lp :if form :do `(incf ,var)))
((:sum :summing) (lp :do `(incf ,var ,form)))
((:maximize :maximizing :minimize :minimizing)
(let ((first-p (getf accumulator-spec :first-p))
(fun (if (member *current-keyword* '(:maximize :maximizing)) '< '>)))
(lp :do `(let ((value ,form))
(cond
(,first-p (setq ,first-p nil ,var value))
((,fun ,var value) (setq ,var value)))))))))))
(defun return-clause () (lp :do `(return-from ,*loop-name* ,(form-or-it))))
(defun do-clause () (fill-in :body (compound-forms+)))
(defun selectable-clause ()
(let ((*current-keyword* *current-keyword*)
(*current-clause* *current-clause*))
(unless (keyword? '(:if :when :unless :do :doing :return :collect :collecting
:append :appending :nconc :nconcing :count :counting
:sum :summing :maximize :maximizing :minimize :minimizing))
(loop-error "A selectable-clause is missing."))
(ecase *current-keyword*
((:if :when :unless) (conditional-clause))
((:do :doing) (do-clause))
((:return) (return-clause))
((:collect :collecting :append :appending :nconc :nconcing :count :counting
:sum :summing :maximize :maximizing :minimize :minimizing)
(accumulation-clause)))))
(defun conditional-clause ()
(let* ((*it-symbol* nil)
(middle (gensym "MIDDLE-"))
(bottom (gensym "BOTTOM-"))
(test-form (if (eq *current-keyword* :unless) `(not ,(form1)) (form1)))
(condition-form `(unless ,test-form (go ,middle))))
(lp :do condition-form)
(let ((*it-visible-p* t)) (selectable-clause))
(loop (unless (preposition? :and) (return)) (selectable-clause))
(cond
((preposition? :else)
(lp :do `(go ,bottom))
(fill-in :body `(,middle))
(let ((*it-visible-p* t)) (selectable-clause))
(loop (unless (preposition? :and) (return)) (selectable-clause))
(fill-in :body `(,bottom)))
(t (fill-in :body `(,middle))))
(preposition? :end)
(when *it-symbol*
(with *it-symbol*)
(setf (second condition-form)
`(setq ,*it-symbol* ,(second condition-form))))))
(defun initially-clause () (fill-in :initially (compound-forms+)))
(defun finally-clause () (fill-in :finally (compound-forms+)))
(defun while-clause () (lp :unless (form1) :do '(loop-finish) :end))
(defun until-clause () (lp :while `(not ,(form1))))
(defun repeat-clause ()
(let* ((form (form1))
(type (typecase (if (quoted-form-p form) (quoted-object form) form)
(fixnum 'fixnum)
(t 'real))))
(lp :for (gensym) :of-type type :downfrom form :to 1)))
(defun always-never-thereis-clause ()
(setq *boolean-terminator* *current-keyword*)
(when *anonymous-accumulator* (ambiguous-loop-result-error))
(ecase *current-keyword*
(:always (lp :unless (form1) :return nil :end) (fill-in :results '(t)))
(:never (lp :always `(not ,(form1))))
(:thereis (lp :if (form1) :return :it :end) (fill-in :results '(nil)))))
(defun variable-clause* ()
(loop (let ((key (keyword? '(:with :initially :finally :for :as))))
(if key (clause1) (return)))))
(defun main-clause* ()
(loop
(if (keyword? '(:do :doing :return :if :when :unless :initially :finally
:while :until :repeat :always :never :thereis
:collect :collecting :append :appending :nconc :nconcing
:count :counting :sum :summing :maximize :maximizing
:minimize :minimizing))
(clause1)
(return))))
(defun name-clause? ()
(when (keyword? :named)
(unless *loop-tokens* (loop-error "A loop name is missing."))
(let ((name (pop *loop-tokens*)))
(unless (symbolp name)
(loop-error "~S cannot be a loop name which must be a symbol." name))
(setq *loop-name* name))))
(defun bound-variables (binding-form)
(let ((operator (first binding-form))
(second (second binding-form)))
(ecase operator
((let let* symbol-macrolet) (mapcar #'first second))
((multiple-value-bind) second)
((with-package-iterator with-hash-table-iterator) `(,(first second))))))
(defun check-multiple-bindings (variables)
(mapl #'(lambda (vars)
(when (member (first vars) (rest vars))
(loop-error 'simple-program-error
:format-control "Variable ~S is bound more than once."
:format-arguments (list (first vars)))))
variables))
(defmacro with-loop-context (tokens &body body &environment environment)
`(let ((*environment* ,environment)
(*loop-tokens* ,tokens)
(*loop-name* nil)
(*current-keyword* nil)
(*current-clause* nil)
(*loop-components* nil)
(*temporaries* nil)
(*ignorable* nil)
(*accumulators* nil)
(*anonymous-accumulator* nil)
(*boolean-terminator* nil)
(*message-prefix* "LOOP: "))
,@body))
(defun with-iterator-forms (iterator-forms form)
(if (null iterator-forms)
form
(destructuring-bind ((iterator-macro spec) . rest) iterator-forms
`(,iterator-macro ,spec
,(with-iterator-forms rest form)))))
(defun with-binding-forms (binding-forms form)
(if (null binding-forms)
form
(destructuring-bind (binding-form0 . rest) binding-forms
(append binding-form0 (list (with-binding-forms rest form))))))
(defun with-temporaries (temporary-specs form)
(destructuring-bind (temporaries &key ignorable) temporary-specs
(if temporaries
`(let ,temporaries
,@(when ignorable `((declare (ignorable ,@ignorable))))
,form)
form)))
(defun with-list-accumulator (accumulator-spec form)
(destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec
(let* ((anonymous-p (null name))
(list-var (if (or anonymous-p (globally-special-p var))
var
(gensym "LIST-")))
(value-form (if (and (not anonymous-p) (globally-special-p var))
nil
'(list nil)))
(form (if (and (not anonymous-p) (not (globally-special-p var)))
`(symbol-macrolet ((,var (cdr ,list-var)))
,form)
form)))
`(let ((,list-var ,value-form))
(declare (type list ,list-var))
(let ((,splice ,list-var))
(declare (type list ,splice))
,form)))))
(defun with-numeric-accumulator (accumulator-spec form)
(destructuring-bind (name &key var types &allow-other-keys) accumulator-spec
(labels ((type-eq (a b) (and (subtypep a b) (subtypep b a))))
(when (null types) (setq types '(number)))
(destructuring-bind (type0 . rest) types
(when (and rest (notevery #'(lambda (type) (type-eq type0 type)) types))
(warn "Different types ~A are declared for ~A accumulator."
(enumerate types) (or name "the anonymous")))
(let ((type (if rest `(or ,type0 ,@rest) type0)))
`(let ((,var ,(zero type)))
(declare (type ,type ,var))
,form))))))
(defun with-accumulators (accumulator-specs form)
(if (null accumulator-specs)
form
(destructuring-bind (spec . rest) accumulator-specs
(ecase (getf (cdr spec) :kind)
(:list
(with-list-accumulator spec (with-accumulators rest form)))
((:total :limit)
(with-numeric-accumulator spec (with-accumulators rest form)))))))
(defun reduce-redundant-code ()
(let ((rhead (reverse (getf *loop-components* :head)))
(rtail (reverse (getf *loop-components* :tail)))
(neck nil))
(loop
(when (or (null rhead) (null rtail) (not (equal (car rhead) (car rtail))))
(return))
(push (pop rhead) neck)
(pop rtail))
(setf (getf *loop-components* :head) (nreverse rhead)
(getf *loop-components* :neck) neck
(getf *loop-components* :tail) (nreverse rtail))))
(defmacro extended-loop (&rest tokens)
(with-loop-context tokens
(let ((body-tag (gensym "LOOP-BODY-"))
(epilogue-tag (gensym "LOOP-EPILOGUE-")))
(name-clause?)
(variable-clause*)
(main-clause*)
(when *loop-tokens*
(error "Loop form tail ~S remained unprocessed." *loop-tokens*))
(reduce-redundant-code)
(destructuring-bind (&key binding-forms iterator-forms initially
head neck body tail finally results)
*loop-components*
(check-multiple-bindings
(append *temporaries* (mapappend #'bound-variables binding-forms)
(mapcar #'(lambda (spec) (getf (cdr spec) :var)) *accumulators*)))
`(block ,*loop-name*
,(with-temporaries `(,*temporaries* :ignorable ,*ignorable*)
(with-accumulators *accumulators*
(with-binding-forms binding-forms
(with-iterator-forms iterator-forms
`(macrolet ((loop-finish () '(go ,epilogue-tag)))
(tagbody
,@initially
,@head
,body-tag
,@neck
,@body
,@tail
(go ,body-tag)
,epilogue-tag
,@finally
,@(when results
`((return-from ,*loop-name* ,(car results)))))))))))))))
(defmacro simple-loop (&rest compound-forms)
(let ((top (gensym)))
`(block nil
(tagbody
,top
,@compound-forms
(go ,top)))))
(defmacro loop (&rest forms)
(if (symbolp (car forms))
`(extended-loop ,@forms)
`(simple-loop ,@forms)))
