home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / loop.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-06-16  |  59.4 KB  |  1,174 lines
  1. ;; LOOP-Facility nach CLTL2
  2. ;; (LOOP {loop-clause}*), CLTL2 S. 163,709-747
  3. ;; Bruno Haible 19.10.1991-20.10.1991, 22.10.1991, 6.6.1993, 28.6.1994, 16.6.1996
  4.  
  5. (in-package "LISP")
  6. (export '(loop loop-finish))
  7. (pushnew 'loop *features*)
  8.  
  9. (in-package "SYSTEM")
  10.  
  11. ;; Parser-Hilfsfunktionen:
  12.  
  13. (eval-when (compile load eval)
  14.  
  15. ; (loop-keywordp obj) stellt fest, ob obj ein Loop-Keyword ist,
  16. ; und liefert dann das entsprechende Symbol (eindeutig), sonst NIL.
  17. (defun loop-keywordp (obj)
  18.   (and (symbolp obj)
  19.        (gethash (symbol-name obj)
  20.          (load-time-value
  21.            (make-hash-table :test #'equal
  22.              :initial-contents
  23.                (mapcar #'(lambda (s) (cons (symbol-name s) s))
  24.                  '(named
  25.                    for as and from downfrom upfrom to downto upto below
  26.                    above by in on = then across being each the hash-key
  27.                    hash-keys hash-value hash-values of using symbol
  28.                    present-symbol internal-symbol external-symbol symbols
  29.                    present-symbols internal-symbols external-symbols
  30.                    repeat
  31.                    while until always never thereis
  32.                    collect collecting append appending nconc nconcing
  33.                    count counting sum summing maximize maximizing
  34.                    minimize minimizing into
  35.                    with
  36.                    if when unless else end it
  37.                    do doing return
  38.                    of-type
  39.                    initially finally
  40.          ) )   )  )
  41. ) )    )
  42.  
  43. (defvar *whole*) ; die gesamte Form (LOOP ...)
  44.  
  45. ; (loop-syntax-error loop-keyword) meldet einen Syntaxfehler
  46. (defun loop-syntax-error (loop-keyword)
  47.   (error (DEUTSCH "~S: Syntaxfehler nach ~A in ~S"
  48.           ENGLISH "~S: syntax error after ~A in ~S"
  49.           FRANCAIS "~S : mauvaise syntaxe aprΦs ~A dans ~S")
  50.          'loop (symbol-name loop-keyword) *whole*
  51. ) )
  52.  
  53. ;; Destructuring:
  54.  
  55. ; (destructure-vars pattern) liefert die Liste der Variablen,
  56. ; die in pattern vorkommen.
  57. (defun destructure-vars (pattern)
  58.   (cond ((null pattern) nil)
  59.         ((atom pattern) (list pattern))
  60.         (t (nconc (destructure-vars (car pattern))
  61.                   (destructure-vars (cdr pattern))
  62. ) )     )  )
  63.  
  64. ; (empty-tree-p pattern) stellt fest, ob in pattern
  65. ; ⁿberhaupt keine Variablen vorkommen.
  66. (defun empty-tree-p (pattern)
  67.   (cond ((null pattern) t)
  68.         ((atom pattern) nil)
  69.         (t (and (empty-tree-p (car pattern)) (empty-tree-p (cdr pattern))))
  70. ) )
  71.  
  72. ; (destructure-type pattern type) liefert eine Liste von Declaration-Specifiern,
  73. ; die die Variablen aus pattern zu den Typen aus type deklarieren.
  74. (defun destructure-type (pattern type)
  75.   (cond ((null pattern) nil)
  76.         ((atom pattern) (list `(TYPE ,type ,pattern)))
  77.         ((consp type)
  78.          (nconc (destructure-type (car pattern) (car type))
  79.                 (destructure-type (cdr pattern) (cdr type))
  80.         ))
  81.         (t (let ((vars (destructure-vars pattern)))
  82.              (if vars (list `(TYPE ,type ,@vars)) nil)
  83. ) )     )  )
  84.  
  85. ; (simple-type-p type) stellt fest, ob der Typ type nach Destructuring nur
  86. ; aus NIL, T, FIXNUM, FLOAT besteht (und damit ein OF-TYPE ⁿberflⁿssig macht).
  87. (defun simple-type-p (type)
  88.   (if (atom type)
  89.     (case type
  90.       ((NIL T FIXNUM FLOAT) t)
  91.       (t nil)
  92.     )
  93.     (and (simple-type-p (car type))
  94.          (simple-type-p (cdr type))
  95. ) ) )
  96.  
  97. (defvar *helpvars*) ; Vektor mit Hilfsvariablen fⁿrs Destructuring
  98.  
  99. ; (helpvar n) liefert die (n+1)-te Hilfsvariable (n>=0). Es mⁿssen schon
  100. ; mindestens n Hilfvariablen gebraucht worden sein.
  101. ; Evtl. wird eine neue Hilfvariable erzeugt.
  102. (defun helpvar (n)
  103.   (when (= n (fill-pointer *helpvars*))
  104.     (vector-push-extend (gensym) *helpvars*)
  105.   )
  106.   (aref *helpvars* n)
  107. )
  108.  
  109. ; (destructure pattern form) liefert eine Liste von Listen
  110. ; (Variable Form). Das erste ist eine Variable aus pattern, das
  111. ; zweite eine Form, an die die Variable zu binden ist bzw. die
  112. ; der Variablen zuzuweisen ist. Auf die Reihenfolge der Bindungen
  113. ; bzw. Zuweisungen kommt es nicht an (d.h. es sind sowohl LET
  114. ; als auch LET* bzw. sowohl PSETQ als auch SETQ m÷glich).
  115. (defun destructure (pattern form)
  116.   (labels ((destructure-tree (pattern form helpvar-count)
  117.              ; helpvar-count = Anzahl der belegten Hilfsvariablen
  118.              (cond ((empty-tree-p pattern) nil)
  119.                    ((atom pattern) (list (list pattern form)))
  120.                    ((empty-tree-p (car pattern))
  121.                     (destructure-tree (cdr pattern) `(CDR ,form) helpvar-count)
  122.                    )
  123.                    ((empty-tree-p (cdr pattern))
  124.                     (destructure-tree (car pattern) `(CAR ,form) helpvar-count)
  125.                    )
  126.                    (t ; mu▀ form zwischendurch einer Hilfsvariablen zuweisen
  127.                      (let ((helpvar (helpvar helpvar-count)))
  128.                        (nconc (destructure-tree (car pattern) `(CAR (SETQ ,helpvar ,form)) (1+ helpvar-count))
  129.                               (destructure-tree (cdr pattern) `(CDR ,helpvar) helpvar-count)
  130.           )) )     ) ) )
  131.     (or (destructure-tree pattern form 0)
  132.         ; keine Variablen -> mu▀ trotzdem form auswerten!
  133.         (list (list (helpvar 0) form))
  134. ) ) )
  135.  
  136. ; Liefert zu einer Liste (var ...) von Variablen ohne Initialisierungsformen
  137. ; die Bindungsliste ((var var-init) ...), wobei var-init mit den declspecs
  138. ; vertrΣglich ist.
  139. (defun default-bindings (vars declspecs)
  140.   ; Verwende NIL oder 0 oder 0.0 - falls das pa▀t -
  141.   ; oder verwende NIL und erweitere die Typdeklaration.
  142.   (let ((bindings (mapcar #'(lambda (var) (list var 'NIL)) vars)))
  143.     (dolist (declspec declspecs)
  144.       (when (eq (first declspec) 'TYPE)
  145.         ; declspec hat die Form (TYPE type . vars)
  146.         (let ((type (second declspec)) h)
  147.           (cond ((typep 'NIL type) ) ; OK
  148.                 ((or (typep (setq h '0) type) (typep (setq h '0.0) type))
  149.                  (dolist (var (cddr declspec))
  150.                    (setf (second (find var bindings :key #'first)) h)
  151.                 ))
  152.                 (t (setf (second declspec) `(OR NULL ,type)))
  153.     ) ) ) )
  154.     bindings
  155. ) )
  156.  
  157. ;; A loop-initialisation describes at macro expansion time the task
  158. ;; to initialise one or more variables. The initialisation may end up
  159. ;; generating code in the prologue or in the inner loop.
  160. (defstruct (loop-initialisation
  161.              (:copier nil)
  162.              (:conc-name "LI-")
  163.              (:predicate nil)
  164.              (:constructor make-loop-init)
  165.            )
  166.   ;; How to generate the Lisp code.
  167.   specform           ; special form: LET or MULTIPLE-VALUE-BIND or PROGN
  168.   bindings           ; for LET: list of bindings, for MULTIPLE-VALUE-BIND: varlist and form
  169.   declspecs          ; list of declspecs
  170.   (endtest-forms nil) ; more forms to be inserted after the declarations, within the tagbody.
  171.   ;; Properties of this initialisation.
  172.   everytime          ; If the assignment has to be evaluated in the prologue only: NIL.
  173.                      ; If the assignment has to be evaluated once for each iteration:
  174.                      ; a cons, pointing at the right place in the stepafter-code.
  175.   (requires-stepbefore nil) ; True if the variables can get their values only in the stepbefore-code or initially-code,
  176.                      ; false if the first assignment can be merged with the initial binding.
  177.   (depends-preceding nil) ; True if everytime=NIL and the values may depend on preceding variables,
  178.                      ; so that these preceding variables must get their values no later than in
  179.                      ; the initially-code.
  180.   (later-depend nil) ; True if some later variables depend on these values, so that these values
  181.                      ; must be computed no later than in the initially-code.
  182. )
  183. #+CLISP (remprop 'loop-initialisation 'sys::defstruct-description)
  184.  
  185. ; (wrap-initialisations initialisations form) wickelt eine (umgedrehte!)
  186. ; Liste von Initialisierungen um form herum und liefert die neue Form.
  187. (defun wrap-initialisations (initialisations form)
  188.   (dolist (initialisation initialisations)
  189.     (let ((name (li-specform initialisation))
  190.           (bindings (li-bindings initialisation))
  191.           (declarations (li-declspecs initialisation)))
  192.       (setq form
  193.         `(,name
  194.           ,@(case name (MULTIPLE-VALUE-BIND bindings) (LET `(,bindings)))
  195.           ,@(if declarations `((DECLARE ,@declarations)))
  196.           ,@(li-endtest-forms initialisation)
  197.           ,form
  198.          )
  199.   ) ) )
  200.   form
  201. )
  202.  
  203. (defvar *last-it*) ; Variable, die das letzte Test-Ergebnis ("it") enthΣlt
  204. (defvar *used-it*) ; Flag, ob diese Variable benutzt wird
  205.  
  206. ; Das Gros des Expanders:
  207. (defun expand-loop (*whole* body)
  208.   (let ((body-rest body) ; alle Parse-Funktionen verkⁿrzen body-rest
  209.         (block-name 'NIL) ; Name des umgebenden BLOCKs
  210.         (already-within-main nil) ; im zweiten Teil von {variables}* {main}* ?
  211.         (*helpvars* (make-array 1 :fill-pointer 0 :adjustable t)) ; Vektor
  212.                                    ; mit Hilfsvariablen fⁿrs Destructuring
  213.         (*last-it* nil) ; Variable, die das letzte Test-Ergebnis ("it") enthΣlt
  214.         (acculist-var nil) ; Akkumulationsvariable fⁿr collect, append etc.
  215.         (accunum-var nil) ; Akkumulationsvariable fⁿr count, sum etc.
  216.         (accu-vars-nil nil) ; Akkumulationsvariablen mit Initialwert NIL
  217.         (accu-vars-0 nil) ; Akkumulationsvariablen mit Initialwert 0
  218.         (accu-declarations nil) ; Typdeklarationen (umgedrehte Liste von declspecs)
  219.         (initialisations nil) ; Bindungen: (init ...) (umgedrehte Liste)
  220.         (seen-for-as-= nil) ; schon eine FOR-AS-= Klausel gesehen?
  221.         (seen-endtest nil) ; schon eine FOR-AS Klausel mit Abbruchbedingung gesehen?
  222.         (initially-code nil) ; initially-Code (umgedrehte Liste)
  223.         (stepbefore-code nil) ; Code zum Abbruch vor dem Schleifendurchlauf (umgedrehte Liste)
  224.         (main-code nil) ; Code im Hauptteil der Schleife (umgedrehte Liste)
  225.         (stepafter-code nil) ; Code zur Vorbereitung des nΣchsten Schleifendurchlaufs (umgedrehte Liste)
  226.         (accu-vars-nreverse nil) ; Akkumulationsvariablen, die am Schlu▀ umzudrehen sind
  227.         (finally-code nil) ; finally-Code (umgedrehte Liste)
  228.         (results nil) ; Liste von Ergebnisformen (h÷chstens eine!)
  229.        )
  230.     (labels
  231.       ((next-kw () ; Schaut, ob als nΣchstes ein Keyword kommt.
  232.                    ; Wenn ja, wird es geliefert. Wenn nein, Ergebnis NIL.
  233.          (and (consp body-rest) (loop-keywordp (first body-rest)))
  234.        )
  235.        (parse-kw-p (kw) ; Schaut, ob als nΣchstes das Keyword kw kommt.
  236.                         ; Wenn ja, wird es ⁿbergangen. Wenn nein, Ergebnis NIL.
  237.          (and (consp body-rest) (eq (loop-keywordp (first body-rest)) kw)
  238.               (progn (pop body-rest) t)
  239.        ) )
  240.        (parse-form (kw) ; Nach kw: parst expr
  241.          (unless (consp body-rest) (loop-syntax-error kw))
  242.          (pop body-rest)
  243.        )
  244.        (parse-form-or-it (kw) ; Nach kw: parst expr, das auch 'it' sein kann
  245.          (unless (consp body-rest) (loop-syntax-error kw))
  246.          (let ((form (pop body-rest)))
  247.            (if (eq (loop-keywordp form) 'it)
  248.              (if *last-it*
  249.                (progn (setq *used-it* t) *last-it*)
  250.                (loop-syntax-error 'it)
  251.              )
  252.              form
  253.        ) ) )
  254.        (parse-var-typespec () ; parst var [typespec]
  255.          ; Liefert das Variablen-Pattern und eine Liste von declspecs.
  256.          (unless (consp body-rest)
  257.            (error (DEUTSCH "~S: Variable fehlt."
  258.                    ENGLISH "~S: missing variable"
  259.                    FRANCAIS "~S : Il manque une variable.")
  260.                   'loop
  261.          ) )
  262.          (let ((pattern (pop body-rest))
  263.                (typedecl nil))
  264.            (block nil
  265.              (unless (consp body-rest) (return))
  266.              (case (loop-keywordp (first body-rest))
  267.                ((NIL) ; kein Loop-Keyword -> als Typespec interpretieren
  268.                 (setq typedecl (pop body-rest))
  269.                 (unless (simple-type-p typedecl)
  270.                   (warn (DEUTSCH "~S: Nach ~S wird ~S als Typspezifikation interpretiert."
  271.                          ENGLISH "~S: After ~S, ~S is interpreted as a type specification"
  272.                          FRANCAIS "~S : AprΦs ~S, on traite ~S comme une spΘcification d'un type.")
  273.                         'loop pattern typedecl
  274.                )) )
  275.                ((OF-TYPE) ; OF-TYPE -> danach kommt ein Typespec
  276.                 (pop body-rest)
  277.                 (setq typedecl (parse-form 'of-type))
  278.                )
  279.                (T (return)) ; sonstiges
  280.              )
  281.              (setq typedecl (destructure-type pattern typedecl))
  282.            )
  283.            (values pattern typedecl)
  284.        ) )
  285.        (parse-progn () ; parst: {expr}*
  286.                        ; und liefert die Liste der Formen
  287.          (let ((list nil))
  288.            (loop
  289.              (unless (and (consp body-rest)
  290.                           (not (loop-keywordp (first body-rest)))
  291.                      )
  292.                (return)
  293.              )
  294.              (push (pop body-rest) list)
  295.            )
  296.            (nreverse list)
  297.        ) )
  298.        (parse-unconditional () ; parst ein Unconditional
  299.          ; unconditional ::= {do | doing} {expr}*
  300.          ; unconditional ::= return expr
  301.          ; Liefert eine Lisp-Form oder NIL wenn's kein Unconditional war.
  302.          (let ((kw (next-kw)))
  303.            (case kw
  304.              ((DO DOING)
  305.               (pop body-rest)
  306.               `(PROGN ,@(parse-progn))
  307.              )
  308.              ((RETURN)
  309.               (pop body-rest)
  310.               `(RETURN-FROM ,block-name ,(parse-form-or-it kw))
  311.              )
  312.              (t 'NIL)
  313.        ) ) )
  314.        (parse-clause () ; parst eine Clause
  315.          ; clause ::= accumulation | conditional | unconditional
  316.          ; accumulation ::= {collect | collecting | append | appending |
  317.          ;                   nconc | nconcing} expr [into var]
  318.          ; accumulation ::= {count | counting | sum | summing |
  319.          ;                   maximize | maximizing | minimize |
  320.          ;                   minimizing} expr [into var] [typespec]
  321.          ; conditional ::= {if | when | unless} expr clause {and clause}*
  322.          ;                 [else clause {and clause}*] [end]
  323.          ; Liefert eine Lisp-Form oder NIL wenn's keine Clause war.
  324.          (or (parse-unconditional)
  325.              (let ((kw (next-kw)))
  326.                (case kw
  327.                  ((COLLECT COLLECTING APPEND APPENDING NCONC NCONCING)
  328.                   (pop body-rest)
  329.                   (let ((form (parse-form-or-it kw))
  330.                         (accuvar nil))
  331.                     (when (parse-kw-p 'into)
  332.                       (unless (and (consp body-rest)
  333.                                    (symbolp (setq accuvar (pop body-rest)))
  334.                               )
  335.                         (loop-syntax-error 'into)
  336.                     ) )
  337.                     (if accuvar
  338.                       (pushnew accuvar accu-vars-nreverse)
  339.                       (progn
  340.                         (setq accuvar
  341.                           (or acculist-var (setq acculist-var (gensym)))
  342.                         )
  343.                         (push `(SYS::LIST-NREVERSE ,accuvar) results)
  344.                     ) )
  345.                     (push accuvar accu-vars-nil)
  346.                     `(SETQ ,accuvar
  347.                        (,(case kw
  348.                            ((COLLECT COLLECTING) 'CONS)
  349.                            ((APPEND APPENDING) 'REVAPPEND)
  350.                            ((NCONC NCONCING) 'NRECONC)
  351.                          )
  352.                         ,form
  353.                         ,accuvar
  354.                      ) )
  355.                  ))
  356.                  ((COUNT COUNTING SUM SUMMING MAXIMIZE MAXIMIZING MINIMIZE MINIMIZING)
  357.                   (pop body-rest)
  358.                   (let ((form (parse-form-or-it kw))
  359.                         (accuvar nil))
  360.                     (when (parse-kw-p 'into)
  361.                       (unless (and (consp body-rest)
  362.                                    (symbolp (setq accuvar (pop body-rest)))
  363.                               )
  364.                         (loop-syntax-error 'into)
  365.                     ) )
  366.                     (unless accuvar
  367.                       (setq accuvar
  368.                         (or accunum-var (setq accunum-var (gensym)))
  369.                       )
  370.                       (push accuvar results)
  371.                     )
  372.                     (when (and (consp body-rest)
  373.                                (not (loop-keywordp (first body-rest)))
  374.                           )
  375.                       (let ((type (pop body-rest)))
  376.                         (case kw
  377.                           ((MAXIMIZE MAXIMIZING MINIMIZE MINIMIZING)
  378.                            (setq type `(OR NULL ,type)) ; wegen Startwert NIL
  379.                         ) )
  380.                         (push `(TYPE ,type ,accuvar) accu-declarations)
  381.                     ) )
  382.                     (case kw
  383.                       ((MAXIMIZE MAXIMIZING MINIMIZE MINIMIZING)
  384.                        (push accuvar accu-vars-nil)
  385.                       )
  386.                       ((COUNT COUNTING SUM SUMMING)
  387.                        (push accuvar accu-vars-0)
  388.                     ) )
  389.                     (case kw
  390.                       ((COUNT COUNTING) `(WHEN ,form (INCF ,accuvar)))
  391.                       ((SUM SUMMING) `(SETQ ,accuvar (+ ,accuvar ,form)))
  392.                       ((MAXIMIZE MAXIMIZING) `(SETQ ,accuvar (MAX-IF ,form ,accuvar)))
  393.                       ((MINIMIZE MINIMIZING) `(SETQ ,accuvar (MIN-IF ,form ,accuvar)))
  394.                  )) )
  395.                  ((IF WHEN UNLESS)
  396.                   (pop body-rest)
  397.                   (let* ((condition (parse-form kw))
  398.                          (it-var (gensym))
  399.                          used-it
  400.                          (true-form
  401.                            (let ((*last-it* it-var) (*used-it* nil))
  402.                              (prog1
  403.                                (parse-clauses kw)
  404.                                (setq used-it *used-it*)
  405.                          ) ) )
  406.                          (false-form 'NIL))
  407.                     (when (parse-kw-p 'else)
  408.                       (setq false-form
  409.                         (let ((*last-it* it-var) (*used-it* nil))
  410.                           (prog1
  411.                             (parse-clauses 'else)
  412.                             (setq used-it (or used-it *used-it*))
  413.                     ) ) ) )
  414.                     (parse-kw-p 'end)
  415.                     (when used-it
  416.                       (psetq it-var `((,it-var ,condition))
  417.                              condition it-var
  418.                     ) )
  419.                     (let ((form
  420.                             `(IF ,(if (eq kw 'UNLESS)
  421.                                     `(NOT ,condition) ; UNLESS
  422.                                     `,condition ; IF, WHEN
  423.                                   )
  424.                                ,true-form
  425.                                ,false-form
  426.                              )
  427.                          ))
  428.                       (if used-it `(LET ,it-var ,form) `,form)
  429.                  )) )
  430.                  (t 'NIL)
  431.        ) )   ) )
  432.        (parse-clauses (kw) ; Nach kw: parst  clause {and clause}*
  433.                            ; oder kurz       {clause}+{and}
  434.          ; Liefert eine Lisp-Form.
  435.          (let ((clauses nil))
  436.            (loop
  437.              (let ((clause (parse-clause)))
  438.                (unless clause (loop-syntax-error kw))
  439.                (push clause clauses)
  440.              )
  441.              (unless (parse-kw-p 'and) (return))
  442.              (setq kw 'and)
  443.              (setq *last-it* nil) ; 'it' ist nur in der ersten Klausel gⁿltig
  444.            )
  445.            `(PROGN ,@(nreverse clauses))
  446.        ) )
  447.        ; Binden und Initialisieren von Variablen:
  448.        ; Nach dpANS 6.1.1.4 gelten zwei Grundregeln:
  449.        ; - Beim Initialisieren von FOR-AS Variablen (au▀er FOR-AS-=) sind
  450.        ;   mindestens alle vorherigen FOR-AS Variablen sichtbar.
  451.        ; - Beim Initialisieren von FOR-AS-= Variablen sind alle FOR-AS Variablen
  452.        ;   sichtbar.
  453.        ; ZusΣtzlich ist die folgende Grundregel wⁿnschenswert:
  454.        ; - Beim Initialisieren von FOR-AS-= Variablen sind mindestens alle
  455.        ;   vorherigen FOR-AS Variablen initialisiert und deren Abbruch-
  456.        ;   bedingungen abgeprⁿft.
  457.        ; Man k÷nnte erst alle Variablen binden und dann im initially-code
  458.        ; die Initialisierungen durchfⁿhren. Wir fⁿhren demgegenⁿber zwei
  459.        ; Optimierungen durch:
  460.        ; - Falls vor der FOR-AS Variablen keine FOR-AS-= Klausel kommt,
  461.        ;   braucht die Variable zum Zeitpunkt ihrer Initialisierung nicht
  462.        ;   sichtbar zu sein, und wir verlagern ihre Initialisierung nach
  463.        ;   vorne, zur Bindung. Das geht aber nur, wenn vor der FOR-AS Variablen
  464.        ;   keine FOR-AS Klausel mit Abbruchbedingung kommt.
  465.        ; - Falls eine Variable gar nicht sichtbar zu sein braucht, weil keine
  466.        ;   FOR-AS-= Klausel vorkommt und hinter ihr auch keine andere FOR-AS
  467.        ;   Klausel st÷rt, k÷nnen die Bindung und die Initialiserung der
  468.        ;   Variablen ins Schleifeninnere verschoben werden.
  469.        (note-initialisation (initialisation)
  470.          (when (or (li-bindings initialisation)
  471.                    (li-declspecs initialisation)
  472.                    (li-endtest-forms initialisation)
  473.                )
  474.            (when seen-for-as-= (setf (li-requires-stepbefore initialisation) t))
  475.            (when (li-endtest-forms initialisation) (setq seen-endtest t))
  476.            (push initialisation initialisations)
  477.        ) )
  478.        (make-endtest (endtest-form)
  479.          (make-loop-init
  480.            :specform 'PROGN
  481.            :bindings nil
  482.            :declspecs nil
  483.            :endtest-forms (list endtest-form)
  484.            :everytime (setq stepafter-code (cons 'NIL stepafter-code))
  485.            :requires-stepbefore seen-endtest
  486.        ) )
  487.       )
  488.       ;; Los geht's!
  489.       ; parst: [named name]
  490.       (when (parse-kw-p 'named)
  491.         (unless (and (consp body-rest) (symbolp (first body-rest)))
  492.           (loop-syntax-error 'named)
  493.         )
  494.         (setq block-name (pop body-rest))
  495.       )
  496.       (loop
  497.         ; main ::= clause | termination | initially | finally |
  498.         ;          with | for-as | repeat
  499.         ; termination ::= {while | until | always | never | thereis} expr
  500.         ; initially ::= initially {expr}*
  501.         ; finally ::= finally { unconditional | {expr}* }
  502.         ; with ::= with {var-typespec [= expr]}+{and}
  503.         ; for-as ::= {for | as} {var-typespec ...}+{and}
  504.         ; repeat ::= repeat expr
  505.         (unless (consp body-rest) (return))
  506.         (let ((clause (parse-clause)))
  507.           (if clause
  508.             (progn (setq already-within-main t) (push clause main-code))
  509.             (let ((kw (loop-keywordp (first body-rest))))
  510.               (case kw
  511.                 ((WHILE UNTIL ALWAYS NEVER THEREIS)
  512.                  (pop body-rest)
  513.                  (setq already-within-main t)
  514.                  (let ((form (parse-form kw)))
  515.                    (push (case kw
  516.                            (WHILE `(UNLESS ,form (LOOP-FINISH)) )
  517.                            (UNTIL `(WHEN ,form (LOOP-FINISH)) )
  518.                            (ALWAYS
  519.                              (push 'T results)
  520.                              `(UNLESS ,form (RETURN-FROM ,block-name 'NIL))
  521.                            )
  522.                            (NEVER
  523.                              (push 'T results)
  524.                              `(WHEN ,form (RETURN-FROM ,block-name 'NIL))
  525.                            )
  526.                            (THEREIS
  527.                              (let ((dummy (gensym)))
  528.                                `(BLOCK ,dummy
  529.                                   (RETURN-FROM ,block-name
  530.                                     (OR ,form (RETURN-FROM ,dummy NIL))
  531.                                 ) )
  532.                            ) )
  533.                          )
  534.                          main-code
  535.                 )) )
  536.                 ((INITIALLY)
  537.                  (pop body-rest)
  538.                  (push `(PROGN ,@(parse-progn)) initially-code)
  539.                 )
  540.                 ((FINALLY)
  541.                  (pop body-rest)
  542.                  (push (or (parse-unconditional) `(PROGN ,@(parse-progn)))
  543.                        finally-code
  544.                 ))
  545.                 ((WITH FOR AS REPEAT)
  546.                  (pop body-rest)
  547.                  (when already-within-main
  548.                    (warn (DEUTSCH "~S: ~A-Klauseln sollten vor dem Schleifeninhalt kommen."
  549.                           ENGLISH "~S: ~A clauses should occur before the loop's main body"
  550.                           FRANCAIS "~S : Les phrases ~A doivent apparaεtre avant le contenu principale de la boucle.")
  551.                          'loop (symbol-name kw)
  552.                  ) )
  553.                  (case kw
  554.                    ((WITH)
  555.                     (let ((bindings nil)
  556.                           (declspecs nil))
  557.                       (loop
  558.                         (let (new-bindings)
  559.                           (multiple-value-bind (pattern new-declspecs) (parse-var-typespec)
  560.                             (if (parse-kw-p '=)
  561.                               ; Initialisierungsform angegeben.
  562.                               (let ((form (parse-form '=)))
  563.                                 (setq new-bindings (destructure pattern form))
  564.                               )
  565.                               ; keine Initialisierungsform angegeben.
  566.                               (setq new-bindings (default-bindings (destructure-vars pattern) new-declspecs))
  567.                             )
  568.                             (setq bindings (revappend new-bindings bindings))
  569.                             (setq declspecs (revappend new-declspecs declspecs))
  570.                         ) )
  571.                         (unless (parse-kw-p 'and) (return))
  572.                         (setq kw 'and)
  573.                       )
  574.                       (note-initialisation
  575.                         (make-loop-init
  576.                           :specform 'LET
  577.                           :bindings (nreverse bindings)
  578.                           :declspecs (nreverse declspecs)
  579.                           :everytime nil
  580.                           :requires-stepbefore seen-endtest
  581.                           :depends-preceding t
  582.                       ) )
  583.                    ))
  584.                    ((FOR AS)
  585.                     ; for-as ::= {for | as} for-as-clause {and [{for | as}] for-as-clause}*
  586.                     ; for-as-clause ::= var-typespec
  587.                     ;                   [{from | downfrom | upfrom} expr]
  588.                     ;                   [{to | downto | upto | below | above} expr]
  589.                     ;                   [by expr]
  590.                     ; for-as-clause ::= var-typespec {in | on} expr [by expr]
  591.                     ; for-as-clause ::= var-typespec = expr [then expr]
  592.                     ; for-as-clause ::= var-typespec across expr
  593.                     ; for-as-clause ::= var-typespec being {each | the}
  594.                     ;                   {hash-key[s] | hash-value[s]}
  595.                     ;                   {in | of} expr
  596.                     ;                   [using ( {hash-value | hash-key} var ) ]
  597.                     ; for-as-clause ::= var-typespec being {each | the}
  598.                     ;                   {symbol[s] | present-symbol[s] | internal-symbol[s] | external-symbol[s]}
  599.                     ;                   {in | of} expr
  600.                     (let ((bindings nil)
  601.                           (declspecs nil)
  602.                           (initialisations nil)
  603.                           (stepafter nil)
  604.                           (old-seen-endtest seen-endtest)
  605.                           (depends-preceding nil))
  606.                       (flet ((note-initialisation (initialisation)
  607.                                ; Aufrufe von note-initialisation mⁿssen temporΣr aufgehoben werden.
  608.                                (when (li-endtest-forms initialisation) (setq seen-endtest t))
  609.                                (push initialisation initialisations)
  610.                             ))
  611.                         (loop
  612.                           (multiple-value-bind (pattern new-declspecs) (parse-var-typespec)
  613.                             (let ((preposition (next-kw)))
  614.                               (case preposition
  615.                                 ((IN ON)
  616.                                  (pop body-rest)
  617.                                  (let ((start-form (parse-form preposition))
  618.                                        (step-function-form '(FUNCTION CDR))
  619.                                        (step-function-var nil))
  620.                                    (when (parse-kw-p 'by)
  621.                                      (setq step-function-form (parse-form 'by))
  622.                                    )
  623.                                    (unless (and (consp step-function-form)
  624.                                                 (eq (first step-function-form) 'FUNCTION)
  625.                                                 (consp (cdr step-function-form))
  626.                                                 (null (cddr step-function-form))
  627.                                                 (symbolp (second step-function-form))
  628.                                            )
  629.                                      (setq step-function-var (gensym))
  630.                                    )
  631.                                    (let ((var (gensym))) ; Hilfsvariable
  632.                                      (push `(,var ,start-form) bindings)
  633.                                      (when step-function-var
  634.                                        (push `(,step-function-var ,step-function-form) bindings)
  635.                                      )
  636.                                      (note-initialisation
  637.                                        (make-endtest `(WHEN (ENDP ,var) (LOOP-FINISH)))
  638.                                      )
  639.                                      (note-initialisation
  640.                                        (make-loop-init
  641.                                          :specform 'LET
  642.                                          :bindings (destructure pattern (if (eq preposition 'IN) `(CAR ,var) `,var))
  643.                                          :declspecs new-declspecs
  644.                                          :everytime t
  645.                                          :requires-stepbefore seen-endtest
  646.                                      ) )
  647.                                      (push
  648.                                        (list var
  649.                                              (if step-function-var
  650.                                                `(FUNCALL ,step-function-var ,var)
  651.                                                `(,(second step-function-form) ,var)
  652.                                        )     )
  653.                                        stepafter
  654.                                 )) ) )
  655.                                 (=
  656.                                  (pop body-rest)
  657.                                  (let* ((first-form (parse-form 'preposition))
  658.                                         (then-form first-form))
  659.                                    (when (parse-kw-p 'then)
  660.                                      (setq then-form (parse-form 'then))
  661.                                    )
  662.                                    (setq bindings
  663.                                      (revappend (destructure pattern first-form)
  664.                                                 bindings
  665.                                    ) )
  666.                                    (setq declspecs (revappend new-declspecs declspecs))
  667.                                    (unless (constantp first-form)
  668.                                      (setq seen-for-as-= t)
  669.                                      (setq depends-preceding t)
  670.                                    )
  671.                                    (unless (and (eql first-form then-form) (constantp then-form))
  672.                                      (setq stepafter (revappend (destructure pattern then-form) stepafter))
  673.                                 )) )
  674.                                 (ACROSS
  675.                                  (pop body-rest)
  676.                                  (let ((vector-form (parse-form preposition))
  677.                                        (vector-var (gensym))
  678.                                        (index-var (gensym)))
  679.                                    (push `(,vector-var ,vector-form) bindings)
  680.                                    (push `(,index-var 0) bindings)
  681.                                    (note-initialisation
  682.                                      (make-endtest `(WHEN (>= ,index-var (LENGTH ,vector-var)) (LOOP-FINISH)))
  683.                                    )
  684.                                    (note-initialisation
  685.                                      (make-loop-init
  686.                                        :specform 'LET
  687.                                        :bindings (destructure pattern `(AREF ,vector-var ,index-var))
  688.                                        :declspecs new-declspecs
  689.                                        :everytime t
  690.                                        :requires-stepbefore seen-endtest
  691.                                    ) )
  692.                                    (push (list index-var `(1+ ,index-var)) stepafter)
  693.                                 ))
  694.                                 (BEING
  695.                                  (pop body-rest)
  696.                                  (let ((plural (next-kw)))
  697.                                    (case plural
  698.                                      ((EACH THE) )
  699.                                      (t (loop-syntax-error 'being))
  700.                                    )
  701.                                    (pop body-rest)
  702.                                    (let ((preposition (next-kw)))
  703.                                      (case preposition
  704.                                        ((HASH-KEY HASH-VALUE
  705.                                          SYMBOL PRESENT-SYMBOL INTERNAL-SYMBOL EXTERNAL-SYMBOL
  706.                                         )
  707.                                         (when (eq plural 'THE)
  708.                                           (warn (DEUTSCH "~S: Nach ~S sollte ein Plural kommen, nicht ~A"
  709.                                                  ENGLISH "~S: After ~S a plural loop keyword is required, not ~A"
  710.                                                  FRANCAIS "~S : AprΦs ~S, on s'attend au pluriel et non ~A")
  711.                                                 'loop plural (symbol-name preposition)
  712.                                        )) )
  713.                                        ((HASH-KEYS HASH-VALUES
  714.                                          SYMBOLS PRESENT-SYMBOLS INTERNAL-SYMBOLS EXTERNAL-SYMBOLS
  715.                                         )
  716.                                         (when (eq plural 'EACH)
  717.                                           (warn (DEUTSCH "~S: Nach ~S sollte ein Singular kommen, nicht ~A"
  718.                                                  ENGLISH "~S: After ~S a singular loop keyword is required, not ~A"
  719.                                                  FRANCAIS "~S : AprΦs ~S, on s'attend au singulier et non ~A")
  720.                                                 'loop plural (symbol-name preposition)
  721.                                        )) )
  722.                                        (t (loop-syntax-error plural))
  723.                                      )
  724.                                      (pop body-rest)
  725.                                      (case (next-kw)
  726.                                        ((IN OF) )
  727.                                        (t (loop-syntax-error preposition))
  728.                                      )
  729.                                      (pop body-rest)
  730.                                      (let ((form (parse-form preposition)))
  731.                                        (case preposition
  732.                                          ((HASH-KEY HASH-KEYS HASH-VALUE HASH-VALUES)
  733.                                           (let ((other-pattern nil))
  734.                                             (when (parse-kw-p 'using)
  735.                                               (unless (and (consp body-rest)
  736.                                                            (consp (car body-rest))
  737.                                                            (consp (cdar body-rest))
  738.                                                            (null (cddar body-rest))
  739.                                                            (case (loop-keywordp (caar body-rest))
  740.                                                              ((HASH-KEY HASH-KEYS)
  741.                                                               (case preposition
  742.                                                                 ((HASH-VALUE HASH-VALUES) t) (t nil)
  743.                                                              ))
  744.                                                              ((HASH-VALUE HASH-VALUES)
  745.                                                               (case preposition
  746.                                                                 ((HASH-KEY HASH-KEYS) t) (t nil)
  747.                                                              ))
  748.                                                       )    )
  749.                                                 (loop-syntax-error 'using)
  750.                                               )
  751.                                               (setq other-pattern (second (pop body-rest)))
  752.                                             )
  753.                                             (let ((state-var (gensym))
  754.                                                   (nextp-var (gensym))
  755.                                                   (nextkey-var (gensym))
  756.                                                   (nextvalue-var (gensym)))
  757.                                               (multiple-value-bind (nextmain-var nextother-var)
  758.                                                 (case preposition
  759.                                                   ((HASH-KEY HASH-KEYS) (values nextkey-var nextvalue-var))
  760.                                                   ((HASH-VALUE HASH-VALUES) (values nextvalue-var nextkey-var))
  761.                                                 )
  762.                                                 (push `(,state-var (SYS::HASH-TABLE-ITERATOR ,form)) bindings)
  763.                                                 (note-initialisation
  764.                                                   (make-loop-init
  765.                                                     :specform 'MULTIPLE-VALUE-BIND
  766.                                                     :bindings `((,nextp-var ,nextkey-var ,nextvalue-var)
  767.                                                                 (SYS::HASH-TABLE-ITERATE ,state-var)
  768.                                                                )
  769.                                                     :declspecs (unless other-pattern `((IGNORE ,nextother-var)))
  770.                                                     :endtest-forms `((UNLESS ,nextp-var (LOOP-FINISH)))
  771.                                                     :everytime t
  772.                                                     :requires-stepbefore seen-endtest
  773.                                                 ) )
  774.                                                 (note-initialisation
  775.                                                   (make-loop-init
  776.                                                     :specform 'LET
  777.                                                     :bindings (destructure pattern nextmain-var)
  778.                                                     :declspecs new-declspecs
  779.                                                     :everytime t
  780.                                                     :requires-stepbefore seen-endtest
  781.                                                 ) )
  782.                                                 (when other-pattern
  783.                                                   (note-initialisation
  784.                                                     (make-loop-init
  785.                                                       :specform 'LET
  786.                                                       :bindings (destructure other-pattern nextother-var)
  787.                                                       :declspecs nil
  788.                                                       :everytime t
  789.                                                       :requires-stepbefore seen-endtest
  790.                                                 ) ) )
  791.                                          )) ) )
  792.                                          ((SYMBOL SYMBOLS PRESENT-SYMBOL PRESENT-SYMBOLS
  793.                                            INTERNAL-SYMBOL INTERNAL-SYMBOLS EXTERNAL-SYMBOL EXTERNAL-SYMBOLS
  794.                                           )
  795.                                           (let ((flags (case preposition
  796.                                                          ((SYMBOL SYMBOLS) '(:internal :external :inherited))
  797.                                                          ((PRESENT-SYMBOL PRESENT-SYMBOLS) '(:internal :external))
  798.                                                          ((INTERNAL-SYMBOL INTERNAL-SYMBOLS) '(:internal))
  799.                                                          ((EXTERNAL-SYMBOL EXTERNAL-SYMBOLS) '(:external))
  800.                                                 )      )
  801.                                                 (state-var (gensym))
  802.                                                 (nextp-var (gensym))
  803.                                                 (nextsym-var (gensym)))
  804.                                             (push `(,state-var (SYS::PACKAGE-ITERATOR ,form ',flags))
  805.                                                   bindings
  806.                                             )
  807.                                             (note-initialisation
  808.                                               (make-loop-init
  809.                                                 :specform 'MULTIPLE-VALUE-BIND
  810.                                                 :bindings `((,nextp-var ,nextsym-var)
  811.                                                             (SYS::PACKAGE-ITERATE ,state-var)
  812.                                                            )
  813.                                                 :declspecs nil
  814.                                                 :endtest-forms `((UNLESS ,nextp-var (LOOP-FINISH)))
  815.                                                 :everytime t
  816.                                                 :requires-stepbefore seen-endtest
  817.                                             ) )
  818.                                             (note-initialisation
  819.                                               (make-loop-init
  820.                                                 :specform 'LET
  821.                                                 :bindings (destructure pattern nextsym-var)
  822.                                                 :declspecs new-declspecs
  823.                                                 :everytime t
  824.                                                 :requires-stepbefore seen-endtest
  825.                                             ) )
  826.                                          ))
  827.                                 )) ) ) )
  828.                                 (t
  829.                                  (unless (symbolp pattern) (loop-syntax-error kw))
  830.                                  (let ((step-start-p nil)
  831.                                        (step-end-p nil)
  832.                                        (step-by-p nil)
  833.                                        step-start-form
  834.                                        step-end-form
  835.                                        step-by-form)
  836.                                    ; erste optionale Klausel:
  837.                                    (block nil
  838.                                      (case preposition
  839.                                        (FROM (setq step-start-p 't))
  840.                                        (UPFROM (setq step-start-p 'up))
  841.                                        (DOWNFROM (setq step-start-p 'down))
  842.                                        (t (return))
  843.                                      )
  844.                                      (pop body-rest)
  845.                                      (setq step-start-form (parse-form preposition))
  846.                                    )
  847.                                    ; zweite optionale Klausel:
  848.                                    (block nil
  849.                                      (setq preposition (next-kw))
  850.                                      (case preposition
  851.                                        (TO (setq step-end-p 't))
  852.                                        ((UPTO BELOW) (setq step-end-p 'up))
  853.                                        ((DOWNTO ABOVE) (setq step-end-p 'down))
  854.                                        (t (return))
  855.                                      )
  856.                                      (pop body-rest)
  857.                                      (setq step-end-form (parse-form preposition))
  858.                                    )
  859.                                    ; dritte optionale Klausel:
  860.                                    (when (parse-kw-p 'by)
  861.                                      (setq step-by-p t)
  862.                                      (setq step-by-form (parse-form 'by))
  863.                                    )
  864.                                    ; Iterationsrichtung bestimmen:
  865.                                    (let ((step-direction
  866.                                            (if (or (eq step-start-p 'down) (eq step-end-p 'down))
  867.                                              (if (or (eq step-start-p 'up) (eq step-end-p 'up))
  868.                                                (error (DEUTSCH "~S: Iterationsrichtung nach ~A unklar."
  869.                                                        ENGLISH "~S: questionable iteration direction after ~A"
  870.                                                        FRANCAIS "~S : On compte vers le haut ou vers le bas aprΦs ~A ?")
  871.                                                       'loop (symbol-name kw)
  872.                                                )
  873.                                                'down
  874.                                              )
  875.                                              'up
  876.                                         )) )
  877.                                      ; Startwert bestimmen:
  878.                                      (unless step-start-p
  879.                                        (if (eq step-direction 'down)
  880.                                          ; AbwΣrtsiteration ohne Startwert ist nicht erlaubt.
  881.                                          ; Die zweite optionale Klausel (d.h. preposition) mu▀ abwΣrts zeigen.
  882.                                          (error (DEUTSCH "~S: Zusammen mit ~A mu▀ FROM oder DOWNFROM angegeben werden."
  883.                                                  ENGLISH "~S: specifying ~A requires FROM or DOWNFROM"
  884.                                                  FRANCAIS "~S : ~A ne va qu'avec FROM ou DOWNFROM")
  885.                                                 'loop (symbol-name preposition)
  886.                                          )
  887.                                          ; AufwΣrtsiteration -> Startwert 0
  888.                                          (setq step-start-form '0)
  889.                                      ) )
  890.                                      (push `(,pattern ,step-start-form) bindings)
  891.                                      (setq declspecs (revappend new-declspecs declspecs))
  892.                                      ; Endwert bestimmen:
  893.                                      (when step-end-p
  894.                                        (unless (constantp step-end-form)
  895.                                          (let ((step-end-var (gensym)))
  896.                                            (push `(,step-end-var ,step-end-form) bindings)
  897.                                            (setq step-end-form step-end-var)
  898.                                      ) ) )
  899.                                      ; Schrittweite bestimmen:
  900.                                      (unless step-by-p (setq step-by-form '1))
  901.                                      (unless (constantp step-by-form)
  902.                                        (let ((step-by-var (gensym)))
  903.                                          (push `(,step-by-var ,step-by-form) bindings)
  904.                                          (setq step-by-form step-by-var)
  905.                                      ) )
  906.                                      ; Endtest bestimmen:
  907.                                      (when step-end-p
  908.                                        (let* ((compfun
  909.                                                 (if (eq step-direction 'up)
  910.                                                   (if (eq preposition 'below) '>= '>) ; up
  911.                                                   (if (eq preposition 'above) '<= '<) ; down
  912.                                               ) )
  913.                                               (endtest
  914.                                                 (if (and (constantp step-end-form) (zerop (eval step-end-form)))
  915.                                                   (case compfun
  916.                                                     (>= `(NOT (MINUSP ,pattern)) )
  917.                                                     (> `(PLUSP ,pattern) )
  918.                                                     (<= `(NOT (PLUSP ,pattern)) )
  919.                                                     (< `(MINUSP ,pattern) )
  920.                                                   )
  921.                                                   `(,compfun ,pattern ,step-end-form)
  922.                                              )) )
  923.                                          (note-initialisation
  924.                                            (make-endtest `(WHEN ,endtest (LOOP-FINISH)))
  925.                                      ) ) )
  926.                                      (push
  927.                                        (list pattern `(,(if (eq step-direction 'up) '+ '-) ,pattern ,step-by-form))
  928.                                        stepafter
  929.                                 )) ) )
  930.                           ) ) )
  931.                           (unless (parse-kw-p 'and) (return))
  932.                           (setq kw 'and)
  933.                           (case (next-kw) ((FOR AS) (pop body-rest)))
  934.                       ) )
  935.                       (when (setq stepafter (apply #'append (nreverse stepafter)))
  936.                         (push `(PSETQ ,@stepafter) stepafter-code)
  937.                       )
  938.                       (push 'NIL stepafter-code) ; Markierung fⁿr spΣtere Initialisierungen
  939.                       (note-initialisation
  940.                         (make-loop-init
  941.                           :specform 'LET
  942.                           :bindings (nreverse bindings)
  943.                           :declspecs (nreverse declspecs)
  944.                           :everytime nil
  945.                           :requires-stepbefore old-seen-endtest
  946.                           :depends-preceding depends-preceding
  947.                       ) )
  948.                       (dolist (initialisation (nreverse initialisations))
  949.                         (when (li-everytime initialisation)
  950.                           (setf (li-everytime initialisation) stepafter-code)
  951.                         )
  952.                         (note-initialisation initialisation)
  953.                       )
  954.                    ))
  955.                    ((REPEAT)
  956.                     (let ((form (parse-form kw))
  957.                           (var (gensym)))
  958.                       (note-initialisation
  959.                         (make-loop-init
  960.                           :specform 'LET
  961.                           :bindings `((,var ,form))
  962.                           :declspecs nil
  963.                           :everytime nil
  964.                           :requires-stepbefore seen-endtest
  965.                           :depends-preceding t
  966.                       ) )
  967.                       (note-initialisation
  968.                         (make-endtest `(UNLESS (PLUSP ,var) (LOOP-FINISH)))
  969.                       )
  970.                       (push `(SETQ ,var (1- ,var)) stepafter-code)
  971.                    ))
  972.                 ))
  973.                 (t (error (DEUTSCH "~S: Illegale Syntax bei ~S in ~S"
  974.                            ENGLISH "~S: illegal syntax near ~S in ~S"
  975.                            FRANCAIS "~S : syntaxe illΘgale prΦs de ~S dans ~S")
  976.                           'loop (first body-rest) *whole*
  977.                 )  )
  978.       ) ) ) ) )
  979.       ; Noch einige semantische Tests:
  980.       (setq results (delete-duplicates results :test #'equal))
  981.       (when (> (length results) 1)
  982.         (error (DEUTSCH "~S: Ergebnis der Schleife ~S nicht eindeutig spezifiziert."
  983.                 ENGLISH "~S: ambiguous result of loop ~S"
  984.                 FRANCAIS "~S : Le rΘsultat de la boucle ~S est ambigu.")
  985.                'loop *whole*
  986.       ) )
  987.       (unless (null results)
  988.         (push `(RETURN-FROM ,block-name ,@results) finally-code)
  989.       )
  990.       ; Initialisierungen abarbeiten und optimieren:
  991.       (let ((initialisations1 nil)
  992.             (initialisations2 nil))
  993.         (unless seen-for-as-=
  994.           (loop
  995.             (when (null initialisations) (return))
  996.             (let ((initialisation (first initialisations)))
  997.               (unless (li-everytime initialisation) (return))
  998.               ; letzte Initialiserungsklausel nach initialisations2 verschieben:
  999.               (pop initialisations)
  1000.               (push initialisation initialisations2)
  1001.         ) ) )
  1002.         ; `depends-preceding' backpropagation:
  1003.         (let ((later-depend nil))
  1004.           (dolist (initialisation initialisations)
  1005.             (when later-depend (setf (li-later-depend initialisation) t))
  1006.             (when (li-depends-preceding initialisation) (setq later-depend t))
  1007.         ) )
  1008.         (setq initialisations (nreverse initialisations))
  1009.         (loop
  1010.           (when (null initialisations) (return))
  1011.           (let* ((initialisation (pop initialisations))
  1012.                  (everytime (li-everytime initialisation))
  1013.                  (requires-stepbefore (li-requires-stepbefore initialisation))
  1014.                  (name (li-specform initialisation))
  1015.                  (bindings (li-bindings initialisation))
  1016.                  (declarations (li-declspecs initialisation))
  1017.                  (vars (case name (MULTIPLE-VALUE-BIND (first bindings)) (LET (mapcar #'first bindings))))
  1018.                  (initforms
  1019.                    (case name
  1020.                      (MULTIPLE-VALUE-BIND `((MULTIPLE-VALUE-SETQ ,@bindings)))
  1021.                      (LET `((SETQ ,@(apply #'append bindings))))
  1022.                      (t '())
  1023.                  ) )
  1024.                  (endtest-forms (li-endtest-forms initialisation)))
  1025.             (if requires-stepbefore
  1026.               ; wegen seen-for-as-= oder AREF nicht optimierbar
  1027.               (progn
  1028.                 (push
  1029.                   (make-loop-init
  1030.                     :specform 'LET
  1031.                     :bindings (default-bindings vars declarations)
  1032.                     :declspecs declarations
  1033.                   )
  1034.                   initialisations1
  1035.                 )
  1036.                 (if everytime
  1037.                   (if (li-later-depend initialisation)
  1038.                     (progn ; double code: initially-code and stepafter-code
  1039.                       (setq initially-code (revappend endtest-forms (revappend initforms initially-code)))
  1040.                       (setf (cdr everytime) (revappend endtest-forms (revappend initforms (cdr everytime))))
  1041.                     )
  1042.                     (setq stepbefore-code (revappend endtest-forms (revappend initforms stepbefore-code)))
  1043.                   )
  1044.                   (setq initially-code (revappend endtest-forms (revappend initforms initially-code)))
  1045.               ) )
  1046.               ; Initialisierungsklausel nach initialisations1 schaffen:
  1047.               (progn
  1048.                 (push
  1049.                   (make-loop-init
  1050.                     :specform name
  1051.                     :bindings bindings
  1052.                     :declspecs declarations
  1053.                   )
  1054.                   initialisations1
  1055.                 )
  1056.                 (if everytime
  1057.                   (progn
  1058.                     ; put the initforms into the stepafter-code only.
  1059.                     (setf (cdr everytime) (revappend initforms (cdr everytime)))
  1060.                     ; handle the endtest-forms.
  1061.                     (if (li-later-depend initialisation)
  1062.                       (progn ; double endtest: initially-code and stepafter-code
  1063.                         (setq initially-code (revappend endtest-forms initially-code))
  1064.                         (setf (cdr everytime) (revappend endtest-forms (cdr everytime)))
  1065.                       )
  1066.                       (setq stepbefore-code (revappend endtest-forms stepbefore-code))
  1067.                   ) )
  1068.                   (setq initially-code (revappend endtest-forms initially-code))
  1069.             ) ) )
  1070.         ) )
  1071.         (setq initialisations1 (nreverse initialisations1))
  1072.         (push
  1073.           (make-loop-init
  1074.             :specform 'LET
  1075.             :bindings
  1076.               `(,@(map 'list #'(lambda (var) `(,var NIL)) *helpvars*)
  1077.                 ,@(mapcar #'(lambda (var) `(,var NIL)) (delete-duplicates accu-vars-nil))
  1078.                 ,@(mapcar #'(lambda (var) `(,var 0)) (delete-duplicates accu-vars-0))
  1079.                )
  1080.             :declspecs
  1081.               (nreverse accu-declarations)
  1082.           )
  1083.           initialisations1
  1084.         )
  1085.         ;; Remove the NIL placeholders in stepafter-code.
  1086.         (setq stepafter-code (delete 'NIL stepafter-code))
  1087.         ;; If initially-code and stepafter-code both end in the same
  1088.         ;; forms, drag these forms across the label to stepbefore-code.
  1089.         (flet ((form-eq (form1 form2) ; Calling EQUAL on user-given forms would be wrong
  1090.                  (or (eql form1 form2)
  1091.                      (and (consp form1) (consp form2)
  1092.                           (eql (length form1) (length form2))
  1093.                           (or (eq (car form1) (car form2))
  1094.                               (and (case (length form1) ((1 3) t))
  1095.                                    (case (car form1) ((SETQ PSETQ) t))
  1096.                                    (case (car form2) ((SETQ PSETQ) t))
  1097.                           )   )
  1098.                           (every #'eq (cdr form1) (cdr form2))
  1099.               )) )   )
  1100.           (loop
  1101.             (unless (and (consp initially-code) (consp stepafter-code)
  1102.                          (form-eq (car initially-code) (car stepafter-code))
  1103.                     )
  1104.               (return)
  1105.             )
  1106.             (setq stepbefore-code (nconc stepbefore-code (list (pop stepafter-code))))
  1107.             (pop initially-code)
  1108.         ) )
  1109.         ;; Final macroexpansion.
  1110.         `(MACROLET ((LOOP-FINISH () (LOOP-FINISH-ERROR)))
  1111.            (BLOCK ,block-name
  1112.              ,(wrap-initialisations (nreverse initialisations1)
  1113.                 `(MACROLET ((LOOP-FINISH () '(GO END-LOOP)))
  1114.                    (TAGBODY
  1115.                      ,@(if initially-code `((PROGN ,@(nreverse initially-code))))
  1116.                      BEGIN-LOOP
  1117.                      ,@(if stepbefore-code `((PROGN ,@(nreverse stepbefore-code))))
  1118.                      ,(wrap-initialisations (nreverse initialisations2)
  1119.                         `(PROGN ,@(nreverse main-code))
  1120.                       )
  1121.                      ,@(if stepafter-code `((PROGN ,@(nreverse stepafter-code))))
  1122.                      (GO BEGIN-LOOP)
  1123.                      END-LOOP
  1124.                      ,@(mapcar #'(lambda (var) `(SETQ ,var (SYS::LIST-NREVERSE ,var)))
  1125.                                accu-vars-nreverse
  1126.                        )
  1127.                      (MACROLET ((LOOP-FINISH () (LOOP-FINISH-WARN) '(GO END-LOOP)))
  1128.                        ,@(nreverse finally-code)
  1129.                  ) ) )
  1130.               )
  1131.          ) )
  1132. ) ) ) )
  1133.  
  1134. ;; Der eigentliche Macro:
  1135.  
  1136. (defmacro loop (&whole whole &body body)
  1137.   (if (some #'loop-keywordp body)
  1138.     ; neue Form von LOOP
  1139.     (expand-loop whole body)
  1140.     ; alte Form von LOOP
  1141.     (let ((tag (gensym)))
  1142.       `(BLOCK NIL (TAGBODY ,tag ,@body (GO ,tag)))
  1143. ) ) )
  1144. (defmacro loop-finish (&whole whole)
  1145.   (error (DEUTSCH "~S ist nur aus ~S heraus m÷glich."
  1146.           ENGLISH "~S is possible only from within ~S"
  1147.           FRANCAIS "~S n'est possible qu'α l'intΘrieur de ~S.")
  1148.          whole 'loop
  1149. ) )
  1150. (defun loop-finish-warn ()
  1151.   (warn (DEUTSCH "Von der Verwendung von ~S in FINALLY-Klauseln wird abgeraten. Das kann nΣmlich zu Endlosschleifen fⁿhren."
  1152.          ENGLISH "Use of ~S in FINALLY clauses is deprecated because it can lead to infinite loops."
  1153.          FRANCAIS "On recommande de ne pas utiliser ~S dans des phrases FINALLY car cela peut amener α des boucles infinies.")
  1154.         '(loop-finish)
  1155. ) )
  1156. (defun loop-finish-error ()
  1157.   (error (DEUTSCH "~S ist hier nicht m÷glich."
  1158.           ENGLISH "~S is not possible here"
  1159.           FRANCAIS "~S n'est pas possible ici.")
  1160.          '(loop-finish)
  1161. ) )
  1162.  
  1163. )
  1164.  
  1165. ;; Run-Time-Support:
  1166.  
  1167. (defun max-if (x y)
  1168.   (if y (max x y) x)
  1169. )
  1170. (defun min-if (x y)
  1171.   (if y (min x y) x)
  1172. )
  1173.  
  1174.