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