diff options
Diffstat (limited to 'Sacla/loop.lisp')
| -rw-r--r-- | Sacla/loop.lisp | 1142 |
1 files changed, 1142 insertions, 0 deletions
diff --git a/Sacla/loop.lisp b/Sacla/loop.lisp new file mode 100644 index 0000000..f1ab322 --- /dev/null +++ b/Sacla/loop.lisp @@ -0,0 +1,1142 @@ +;; Copyright (C) 2002-2004, Yuji Minejima <ggb01164@nifty.ne.jp> +;; ALL RIGHTS RESERVED. +;; +;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $ +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions +;; are met: +;; +;; * Redistributions of source code must retain the above copyright +;; notice, this list of conditions and the following disclaimer. +;; * Redistributions in binary form must reproduce the above copyright +;; notice, this list of conditions and the following disclaimer in +;; the documentation and/or other materials provided with the +;; distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#-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) + #+abcl (values (EXT:SPECIAL-VARIABLE-P symbol t)) + #+allegro (values (excl::variable-special-p symbol nil) t) + #+clisp (values (ext:special-variable-p symbol nil) t) + #+cmu (values (walker:variable-globally-special-p symbol) t) + #+ecl (values (si:specialp symbol) t) + #+gcl (values (si:specialp symbol) t) + #+lispworks (values (eq :special (hcl:variable-information symbol)) t) + #+sbcl (values (sb-walker:var-globally-special-p symbol) t) + #-(or abcl allegro clisp cmu ecl gcl lispworks sbcl) + (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) ;; do nothing + ((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) ;; do nothing + ((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) + ;; a TEMP moves horizontally, or cdr-wise, on an FORM. + ;; a TEMP can be reused by pushing it back onto TEMPORARIES. + (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) + ;; 6.1.1.4 Expanding Loop Forms + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_aad.htm + ;; the form1 and form2 in a for-as-equals-then form includes the lexical + ;; environment of all the loop variables. + (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) + ((subtypep type 'float) 1.0) + (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) + ;; Check with atom. See 6.1.2.1.3 The for-as-on-list subclause. + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abac.htm + (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) + ;; Check with endp. See 6.1.2.1.2 The for-as-in-list subclause. + ;; http://www.lispworks.com/reference/HyperSpec/Body/06_abab.htm + (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 (assoc name *accumulators*)) + (plist (cdr spec))) + (if spec + (if (not (eq kind (getf plist :kind))) + (invalid-accumulator-combination-error (reverse (getf plist :keys))) + (progn + (pushnew *current-keyword* (getf plist :keys)) + (when (member kind '(:total :limit)) + (multiple-value-bind (type supplied-p) (type-spec?) + (when supplied-p (push type (getf plist :types))))))) + (let ((var (or name (gensym "ACCUMULATOR-")))) + (setq plist `(:var ,var :kind ,kind :keys (,*current-keyword*))) + (ecase kind + (:list (setf (getf plist :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 plist :types)))) + (when (eq kind :limit) + (let ((first-p (gensym "FIRST-P-"))) + (setf (getf plist :first-p) first-p) + (with first-p t := t))) + (unless name (fill-in :results `(,var))))) + (push (setq spec `(,name ,@plist)) *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-spec) + (destructuring-bind (name &key var splice &allow-other-keys) accumulator-spec + (declare (ignore name)) + (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 (name &rest plist &key var &allow-other-keys) + accumulator-spec + (declare (ignore name)) + (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 plist :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)))) + ;; condition-form is destructively modified in the following code for IT. + (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) + `(let ((*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 (dynamic-extent ,list-var)) + (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 () + (when (null (getf *loop-components* :initially)) + (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 &environment environment) + (let ((*environment* environment)) + (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 + ,@head + ,@initially + ,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 (every #'consp forms) + `(simple-loop ,@forms) + `(extended-loop ,@forms))) + + |