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