home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / clisp-li.000 / clisp-li / clisp-1996-07-22 / src / defmacro.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1995-04-11  |  28.6 KB  |  640 lines
  1. ;;;; File DEFMACRO.LSP
  2. ;;; Macro DEFMACRO und einige Hilfsfunktionen fⁿr komplizierte Macros.
  3. ;;; 1. 9. 1988
  4. ;;; Adaptiert an DEFTYPE am 10.6.1989
  5.  
  6. (in-package "SYSTEM")
  7.  
  8. ;; Import aus CONTROL.Q:
  9.  
  10. #| (SYSTEM::PARSE-BODY body &optional docstring-allowed env)
  11.    expandiert die ersten Formen in der Formenliste body (im Macroexpansions-
  12.    Environment env), entdeckt dabei auftretende Deklarationen (und falls
  13.    docstring-allowed=T, auch einen Docstring) und liefert drei Werte:
  14.    1. body-rest, die restlichen Formen,
  15.    2. declspec-list, eine Liste der aufgetretenen Decl-Specs,
  16.    3. docstring, ein aufgetretener Docstring oder NIL.
  17. |#
  18. #| (SYSTEM::KEYWORD-TEST arglist kwlist)
  19.    testet, ob arglist (eine paarige Keyword/Value-Liste) nur Keywords
  20.    enthΣlt, die auch in der Liste kwlist vorkommen, oder aber ein
  21.    Keyword/Value-Paar :ALLOW-OTHER-KEYS mit Value /= NIL enthΣlt.
  22.    Wenn nein, wird ein Error ausgel÷st.
  23. |#
  24. #| (keyword-test arglist kwlist) ⁿberprⁿft, ob in arglist (eine Liste
  25. von Keyword/Value-Paaren) nur Keywords vorkommen, die in kwlist vorkommen,
  26. oder ein Keyword/Value-Paar mit Keyword = :ALLOW-OTHER-KEYS und Value /= NIL
  27. vorkommt. Sollte dies nicht der Fall sein, wird eine Errormeldung ausgegeben.
  28.  
  29. (defun keyword-test (arglist kwlist)
  30.   (let ((unallowed-arglistr nil)
  31.         (allow-other-keys-flag nil))
  32.     (do ((arglistr arglist (cddr arglistr)))
  33.         ((null arglistr))
  34.       (if (eq (first arglistr) ':ALLOW-OTHER-KEYS)
  35.           (if (second arglistr) (setq allow-other-keys-flag t))
  36.           (do ((kw (first arglistr))
  37.                (kwlistr kwlist (cdr kwlistr)))
  38.               ((or (null kwlistr) (eq kw (first kwlistr)))
  39.                (if (and (null kwlistr) (null unallowed-arglistr))
  40.                    (setq unallowed-arglistr arglistr)
  41.     ) )   )   ))
  42.     (unless allow-other-keys-flag
  43.       (if unallowed-arglistr
  44.         (cerror (DEUTSCH "Beide werden ⁿbergangen."
  45.                  ENGLISH "It will be ignored."
  46.                  FRANCAIS "Ignorer les deux.")
  47.                 (DEUTSCH "UnzulΣssiges Keyword ~S mit Wert ~S"
  48.                  ENGLISH "Invalid keyword-value-pair: ~S ~S"
  49.                  FRANCAIS "Mot-clΘ illΘgal ~S, valeur ~S")
  50.                 (first unallowed-arglistr) (second unallowed-arglistr)
  51.     ) ) )
  52. ) )
  53. ; Definition in Assembler siehe CONTROL.Q
  54. |#
  55.  
  56. (defun macro-call-error (macro-form)
  57.   (error-of-type 'program-error
  58.     (DEUTSCH "Der Macro ~S kann nicht mit ~S Argumenten aufgerufen werden: ~S"
  59.      ENGLISH "The macro ~S may not be called with ~S arguments"
  60.      FRANCAIS "Le macro ~S ne peut pas Ωtre appelΘ avec ~S arguments : ~S")
  61.     (car macro-form) (1- (length macro-form)) macro-form
  62. ) )
  63.  
  64. (proclaim '(special
  65.         %restp ; gibt an, ob &REST/&BODY/&KEY angegeben wurde,
  66.                ; also ob die Argumentanzahl unbeschrΣnkt ist.
  67.  
  68.         %min-args ; gibt die Anzahl der notwendigen Argumente an
  69.  
  70.         %arg-count ; gibt die Anzahl der Einzelargumente an
  71.                    ; (notwendige und optionale Argumente, zusammengezΣhlt)
  72.  
  73.         %let-list ; umgedrehte Liste der Bindungen, die mit LET* zu machen sind
  74.  
  75.         %keyword-tests ; Liste der KEYWORD-TEST - Aufrufe, die einzubinden sind
  76.  
  77.         %default-form ; Default-Form fⁿr optionale und Keyword-Argumente,
  78.                    ; bei denen keine Default-Form angegeben ist.
  79.                    ; =NIL normalerweise, = (QUOTE *) fⁿr DEFTYPE.
  80. )          )
  81. #|
  82. (ANALYZE1 lambdalist accessexp name wholevar)
  83. analysiert eine Macro-Lambdaliste (ohne &ENVIRONMENT). accessexp ist der
  84. Ausdruck, der die Argumente liefert, die mit dieser Lambdaliste zu matchen
  85. sind.
  86.  
  87. (ANALYZE-REST lambdalistr restexp name)
  88. analysiert den Teil einer Macro-Lambdaliste, der nach &REST/&BODY kommt.
  89. restexp ist der Ausdruck, der die Argumente liefert, die mit diesem
  90. Listenrest zu matchen sind.
  91.  
  92. (ANALYZE-KEY lambdalistr restvar name)
  93. analysiert den Teil einer Macro-Lambdaliste, der nach &KEY kommt.
  94. restvar ist das Symbol, das die restlichen Argumente enthalten wird.
  95.  
  96. (ANALYZE-AUX lambdalistr name)
  97. analysiert den Teil einer Macro-Lambdaliste, der nach &AUX kommt.
  98.  
  99. (REMOVE-ENV-ARG lambdalist name)
  100. entfernt das Paar &ENVIRONMENT/Symbol aus einer Macro-Lambdaliste,
  101. liefert zwei Werte: die verkⁿrzte Lambdaliste und das als Environment zu
  102. verwendende Symbol (oder die Lambdaliste selbst und NIL, falls &ENVIRONMENT
  103. nicht auftritt).
  104.  
  105. (MAKE-LENGTH-TEST symbol)
  106. kreiert aus %restp, %min-args, %arg-count eine Testform, die bei Auswertung
  107. anzeigt, ob der Inhalt der Variablen symbol als Aufruferform zum Macro
  108. dienen kann.
  109.  
  110. (MAKE-MACRO-EXPANSION macrodef)
  111. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  112. 1. den Macro-Expander als Programmtext (FUNCTION ... (LAMBDA ...)),
  113. 2. name, ein Symbol,
  114. 3. lambdalist,
  115. 4. docstring (oder NIL, wenn keiner da).
  116.  
  117. (MAKE-MACRO-EXPANDERCONS macrodef)
  118. liefert zu einer Macrodefinition macrodef = (name lambdalist . body)
  119. das fⁿrs FENV bestimmte Cons (SYSTEM::MACRO . expander).
  120. |#
  121.  
  122. (%proclaim-constant 'macro-missing-value (list 'macro-missing-value))
  123. ; einmaliges Objekt
  124.  
  125. (%putd 'analyze-aux
  126.   (function analyze-aux
  127.     (lambda (lambdalistr name)
  128.       (do ((listr lambdalistr (cdr listr)))
  129.           ((atom listr)
  130.            (if listr
  131.              (cerror (DEUTSCH "Der Teil danach wird ignoriert."
  132.                       ENGLISH "The rest of the lambda list will be ignored."
  133.                       FRANCAIS "Ignorer ce qui suit.")
  134.                      (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt einen Punkt nach &AUX."
  135.                       ENGLISH "The lambda list of macro ~S contains a dot after &AUX."
  136.                       FRANCAIS "La liste lambda du macro ~S contient un point aprΦs &AUX.")
  137.                      name
  138.           )) )
  139.         (cond ((symbolp (car listr)) (setq %let-list (cons `(,(car listr) nil) %let-list)))
  140.               ((atom (car listr))
  141.                (error-of-type 'program-error
  142.                  (DEUTSCH "Im Macro ~S ist als &AUX-Variable nicht verwendbar: ~S"
  143.                   ENGLISH "in macro ~S: ~S may not be used as &AUX variable."
  144.                   FRANCAIS "Dans le macro ~S, l'utilisation de ~S n'est pas possible comme variable &AUX.")
  145.                  name (car listr)
  146.               ))
  147.               (t (setq %let-list
  148.                    (cons `(,(caar listr) ,(cadar listr)) %let-list)
  149.   ) ) ) )     )  )
  150. )
  151.  
  152. (%putd 'analyze-key
  153.   (function analyze-key
  154.     (lambda (lambdalistr restvar name &aux (otherkeysforbidden t) (kwlist nil))
  155.       (do ((listr lambdalistr (cdr listr))
  156.            (next)
  157.            (kw)
  158.            (svar)
  159.            (g))
  160.           ((atom listr)
  161.            (if listr
  162.              (cerror (DEUTSCH "Der Teil danach wird ignoriert."
  163.                       ENGLISH "The rest of the lambda list will be ignored."
  164.                       FRANCAIS "Ignorer ce qui suit.")
  165.                      (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt einen Punkt nach &KEY."
  166.                       ENGLISH "The lambda list of macro ~S contains a dot after &KEY."
  167.                       FRANCAIS "La liste lambda du macro ~S contient un point aprΦs &KEY.")
  168.                      name
  169.           )) )
  170.         (setq next (car listr))
  171.         (cond ((eq next '&ALLOW-OTHER-KEYS) (setq otherkeysforbidden nil))
  172.               ((eq next '&AUX) (return-from nil (analyze-aux (cdr listr) name)))
  173.               ((or (eq next '&ENVIRONMENT) (eq next '&WHOLE) (eq next '&OPTIONAL)
  174.                    (eq next '&REST) (eq next '&BODY) (eq next '&KEY)
  175.                )
  176.                (cerror (DEUTSCH "Es wird ignoriert."
  177.                         ENGLISH "It will be ignored."
  178.                         FRANCAIS "Ignorer ce qui suit.")
  179.                        (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ein ~S an falscher Stelle."
  180.                         ENGLISH "The lambda list of macro ~S contains a badly placed ~S."
  181.                         FRANCAIS "La liste lambda du macro ~S contient un ~S mal placΘ.")
  182.                        name next
  183.               ))
  184.               (t
  185.                 (if %default-form
  186.                   (cond ((symbolp next) (setq next (list next %default-form)))
  187.                         ((and (consp next) (eql (length next) 1))
  188.                          (setq next (list (car next) %default-form))
  189.                 ) )     )
  190.                 (cond ((symbolp next)
  191.                        (setq kw (intern (symbol-name next) *keyword-package*))
  192.                        (setq %let-list
  193.                          (cons `(,next (GETF ,restvar ,kw NIL)) %let-list)
  194.                        )
  195.                        (setq kwlist (cons kw kwlist))
  196.                       )
  197.                       ((atom next)
  198.                        (cerror (DEUTSCH "Es wird ignoriert."
  199.                                 ENGLISH "It will be ignored."
  200.                                 FRANCAIS "Il sera ignorΘ.")
  201.                                (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt folgendes unpassende Element: ~S"
  202.                                 ENGLISH "The lambda list of macro ~S contains the invalid element ~S"
  203.                                 FRANCAIS "La liste lambda du macro ~S contient cet ΘlΘment inadmissible : ~S")
  204.                                name next
  205.                       ))
  206.                       ((symbolp (car next))
  207.                        (setq kw (intern (symbol-name (car next)) *keyword-package*))
  208.                        (setq %let-list
  209.                          (cons `(,(car next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  210.                                %let-list
  211.                        ) )
  212.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  213.                                     (third next)
  214.                                     nil
  215.                        )          )
  216.                        (setq %let-list
  217.                          (cons
  218.                            (if svar
  219.                              `(,svar (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  220.                                        (PROGN (SETQ ,(car next) ,(cadr next)) NIL)
  221.                                        T
  222.                               )      )
  223.                              `(,(car next) (IF (EQ ,(car next) MACRO-MISSING-VALUE)
  224.                                              ,(cadr next)
  225.                                              ,(car next)
  226.                               )            )
  227.                            )
  228.                            %let-list
  229.                        ) )
  230.                        (setq kwlist (cons kw kwlist))
  231.                       )
  232.                       ((not (and (consp (car next)) (keywordp (caar next)) (consp (cdar next))))
  233.                        (cerror (DEUTSCH "Es wird ignoriert."
  234.                                 ENGLISH "It will be ignored."
  235.                                 FRANCAIS "Elle sera ignorΘe.")
  236.                                (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt eine unzulΣssige Keywordspezifikation: ~S"
  237.                                 ENGLISH "The lambda list of macro ~S contains an invalid keyword specification ~S"
  238.                                 FRANCAIS "La liste lambda du macro ~S contient une spΘcification de mot-clΘ inadmissible : ~S")
  239.                                name (car next)
  240.                       ))
  241.                       ((symbolp (cadar next))
  242.                        (setq kw (caar next))
  243.                        (setq %let-list
  244.                          (cons `(,(cadar next) (GETF ,restvar ,kw MACRO-MISSING-VALUE))
  245.                            %let-list
  246.                        ) )
  247.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  248.                                     (third next)
  249.                                     nil
  250.                        )          )
  251.                        (setq %let-list
  252.                          (cons
  253.                            (if svar
  254.                              `(,svar (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  255.                                        (PROGN (SETQ ,(cadar next) ,(cadr next)) NIL)
  256.                                        T
  257.                               )      )
  258.                              `(,(cadar next) (IF (EQ ,(cadar next) MACRO-MISSING-VALUE)
  259.                                              ,(cadr next)
  260.                                              ,(cadar next)
  261.                               )            )
  262.                            )
  263.                            %let-list
  264.                        ) )
  265.                        (setq kwlist (cons kw kwlist))
  266.                       )
  267.                       (t
  268.                        (setq kw (caar next))
  269.                        (setq g (gensym))
  270.                        (setq %let-list
  271.                          (cons `(,g (GETF ,restvar ,kw MACRO-MISSING-VALUE)) %let-list)
  272.                        )
  273.                        (setq svar (if (and (cddr next) (symbolp (third next)))
  274.                                     (third next)
  275.                                     nil
  276.                        )          )
  277.                        (setq %let-list
  278.                          (cons
  279.                            (if svar
  280.                              `(,svar (IF (EQ ,g MACRO-MISSING-VALUE)
  281.                                        (PROGN (SETQ ,g ,(cadr next)) NIL)
  282.                                        T
  283.                               )      )
  284.                              `(,g (IF (EQ ,g MACRO-MISSING-VALUE)
  285.                                     ,(cadr next)
  286.                                     ,(cadar next)
  287.                               )   )
  288.                            )
  289.                            %let-list
  290.                        ) )
  291.                        (setq kwlist (cons kw kwlist))
  292.                        (let ((%min-args 0) (%arg-count 0) (%restp nil) (%default-form nil))
  293.                          (analyze1 (cadar next) g name g)
  294.                       ))
  295.               ) )
  296.       ) )
  297.       (if otherkeysforbidden
  298.         (setq %keyword-tests
  299.           (cons `(KEYWORD-TEST ,restvar ',kwlist) %keyword-tests)
  300.       ) )
  301.   ) )
  302. )
  303.  
  304. (%putd 'analyze-rest
  305.   (function analyze-rest
  306.     (lambda (lambdalistr restexp name)
  307.       (if (atom lambdalistr)
  308.         (error-of-type 'program-error
  309.           (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt keine Variable nach &REST/&BODY."
  310.            ENGLISH "The lambda list of macro ~S is missing a variable after &REST/&BODY."
  311.            FRANCAIS "Il manque une variable aprΦs &REST/BODY dans la liste lambda du macro ~S.")
  312.           name
  313.       ) )
  314.       (unless (symbolp (car lambdalistr))
  315.         (error-of-type 'program-error
  316.           (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt eine unzulΣssige Variable nach &REST/&BODY: ~S"
  317.            ENGLISH "The lambda list of macro ~S contains an illegal variable after &REST/&BODY: ~S"
  318.            FRANCAIS "La liste lambda du macro ~S contient une variable indamissible aprΦs &REST/BODY : ~S")
  319.           name (car lambdalistr)
  320.       ) )
  321.       (let ((restvar (car lambdalistr))
  322.             (listr (cdr lambdalistr)))
  323.         (setq %restp t)
  324.         (setq %let-list (cons `(,restvar ,restexp) %let-list))
  325.         (cond ((null listr))
  326.               ((atom listr)
  327.                (cerror (DEUTSCH "Der Teil danach wird ignoriert."
  328.                         ENGLISH "The rest of the lambda list will be ignored."
  329.                         FRANCAIS "Ignorer ce qui suit.")
  330.                        (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt einen Punkt an falscher Stelle."
  331.                         ENGLISH "The lambda list of macro ~S contains a misplaced dot."
  332.                         FRANCAIS "La liste lambda du macro ~S contient un point mal placΘ.")
  333.                        name
  334.               ))
  335.               ((eq (car listr) '&KEY) (analyze-key (cdr listr) restvar name))
  336.               ((eq (car listr) '&AUX) (analyze-aux (cdr listr) name))
  337.               (t (cerror (DEUTSCH "Dieser ganze Teil wird ignoriert."
  338.                           ENGLISH "They will be ignored."
  339.                           FRANCAIS "Ignorer cette partie.")
  340.                          (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ⁿberflⁿssige Elemente: ~S"
  341.                           ENGLISH "The lambda list of macro ~S contains superfluous elements: ~S"
  342.                           FRANCAIS "La liste lambda du macro ~S contient des ΘlΘments superflus : ~S")
  343.                          name listr
  344.   ) ) ) )     )  )
  345. )
  346.  
  347. (%putd 'cons-car
  348.   (function cons-car
  349.     (lambda (exp &aux h)
  350.       (if
  351.         (and
  352.           (consp exp)
  353.           (setq h
  354.             (assoc (car exp)
  355.               '((car . caar) (cdr . cadr)
  356.                 (caar . caaar) (cadr . caadr) (cdar . cadar) (cddr . caddr)
  357.                 (caaar . caaaar) (caadr . caaadr) (cadar . caadar) (caddr . caaddr)
  358.                 (cdaar . cadaar) (cdadr . cadadr) (cddar . caddar) (cdddr . cadddr)
  359.                 (cddddr . fifth)
  360.         ) ) )  )
  361.         (cons (cdr h) (cdr exp))
  362.         (list 'car exp)
  363.   ) ) )
  364. )
  365.  
  366. (%putd 'cons-cdr
  367.   (function cons-cdr
  368.     (lambda (exp &aux h)
  369.       (if
  370.         (and
  371.           (consp exp)
  372.           (setq h
  373.             (assoc (car exp)
  374.               '((car . cdar) (cdr . cddr)
  375.                 (caar . cdaar) (cadr . cdadr) (cdar . cddar) (cddr . cdddr)
  376.                 (caaar . cdaaar) (caadr . cdaadr) (cadar . cdadar) (caddr . cdaddr)
  377.                 (cdaar . cddaar) (cdadr . cddadr) (cddar . cdddar) (cdddr . cddddr)
  378.         ) ) )  )
  379.         (cons (cdr h) (cdr exp))
  380.         (list 'cdr exp)
  381.   ) ) )
  382. )
  383.  
  384. (%putd 'analyze1
  385.   (function analyze1
  386.     (lambda (lambdalist accessexp name wholevar)
  387.       (do ((listr lambdalist (cdr listr))
  388.            (withinoptional nil)
  389.            (item)
  390.            (g))
  391.           ((atom listr)
  392.            (when listr
  393.              (unless (symbolp listr)
  394.                (error-of-type 'program-error
  395.                  (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt eine unzulΣssige &REST-Variable: ~S"
  396.                   ENGLISH "The lambda list of macro ~S contains an illegal &REST variable: ~S"
  397.                   FRANCAIS "La liste lambda du macro ~S contient une variable &REST inadmissible : ~S")
  398.                  name listr
  399.              ) )
  400.              (setq %let-list (cons `(,listr ,accessexp) %let-list))
  401.              (setq %restp t)
  402.           ))
  403.         (setq item (car listr))
  404.         (cond ((eq item '&WHOLE)
  405.                (if (and wholevar (cdr listr) (symbolp (cadr listr)))
  406.                  (progn
  407.                    (setq %let-list (cons `(,(cadr listr) ,wholevar) %let-list))
  408.                    (setq listr (cdr listr))
  409.                  )
  410.                  (error-of-type 'program-error
  411.                    (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ein unzulΣssiges &WHOLE: ~S"
  412.                     ENGLISH "The lambda list of macro ~S contains an invalid &WHOLE: ~S"
  413.                     FRANCAIS "La liste lambda du macro ~S contient un &WHOLE inadmissible : ~S")
  414.                    name listr
  415.               )) )
  416.               ((eq item '&OPTIONAL)
  417.                (if withinoptional
  418.                  (cerror (DEUTSCH "Es wird ignoriert."
  419.                           ENGLISH "It will be ignored."
  420.                           FRANCAIS "L'ignorer.")
  421.                          (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ein ⁿberflⁿssiges ~S."
  422.                           ENGLISH "The lambda list of macro ~S contains a superfluous ~S."
  423.                           FRANCAIS "La liste lambda du macro ~S contient un ~S superflu.")
  424.                          name item
  425.                ) )
  426.                (setq withinoptional t)
  427.               )
  428.               ((or (eq item '&REST) (eq item '&BODY))
  429.                (return-from nil (analyze-rest (cdr listr) accessexp name))
  430.               )
  431.               ((eq item '&KEY)
  432.                (setq g (gensym))
  433.                (setq %restp t)
  434.                (setq %let-list (cons `(,g ,accessexp) %let-list))
  435.                (return-from nil (analyze-key (cdr listr) g name))
  436.               )
  437.               ((eq item '&ALLOW-OTHER-KEYS)
  438.                (cerror (DEUTSCH "Es wird ignoriert."
  439.                         ENGLISH "It will be ignored."
  440.                         FRANCAIS "L'ignorer.")
  441.                        (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ~S vor &KEY."
  442.                         ENGLISH "The lambda list of macro ~S contains ~S before &KEY."
  443.                         FRANCAIS "La liste lambda du macro ~S contient ~S avant &KEY.")
  444.                        name item
  445.               ))
  446.               ((eq item '&ENVIRONMENT)
  447.                (cerror (DEUTSCH "Es wird ignoriert."
  448.                         ENGLISH "It will be ignored."
  449.                         FRANCAIS "L'ignorer.")
  450.                        (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ~S, was hier unzulΣssig ist."
  451.                         ENGLISH "The lambda list of macro ~S contains ~S which is illegal here."
  452.                         FRANCAIS "La liste lambda du macro ~S contient ~S qui est inadmissible ici.")
  453.                        name item
  454.               ))
  455.               ((eq item '&AUX)
  456.                (return-from nil (analyze-aux (cdr listr) name))
  457.               )
  458.               (withinoptional
  459.                (setq %arg-count (1+ %arg-count))
  460.                (if %default-form
  461.                  (cond ((symbolp item) (setq item (list item %default-form)))
  462.                        ((and (consp item) (eql (length item) 1))
  463.                         (setq item (list (car item) %default-form))
  464.                ) )     )
  465.                (cond ((symbolp item)
  466.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  467.                      )
  468.                      ((atom item)
  469.                       #1=
  470.                       (error-of-type 'program-error
  471.                         (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt ein unzulΣssiges Element: ~S"
  472.                          ENGLISH "The lambda list of macro ~S contains an invalid element ~S"
  473.                          FRANCAIS "La liste lambda du macro ~S contient un ΘlΘment inadmissible : ~S")
  474.                         name item
  475.                      ))
  476.                      ((symbolp (car item))
  477.                       (setq %let-list
  478.                         (cons `(,(car item) (IF ,accessexp
  479.                                               ,(cons-car accessexp)
  480.                                               ,(if (consp (cdr item)) (cadr item) 'NIL)
  481.                                )            )
  482.                           %let-list
  483.                       ) )
  484.                       (when (and (consp (cdr item)) (consp (cddr item)))
  485.                         (unless (symbolp (caddr item))
  486.                           (error-of-type 'program-error
  487.                             (DEUTSCH "Die Lambdaliste des Macros ~S enthΣlt eine unzulΣssige supplied-Variable: ~S"
  488.                              ENGLISH "The lambda list of macro ~S contains an invalid supplied-variable ~S"
  489.                              FRANCAIS "La liste lambda du macro ~S contient une ½supplied-variable╗ indamissible : ~S")
  490.                             name (caddr item)
  491.                         ) )
  492.                         (setq %let-list
  493.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  494.                      )) )
  495.                      (t
  496.                       (setq g (gensym))
  497.                       (setq %let-list
  498.                         (cons `(,g ,(if (consp (cdr item))
  499.                                       `(IF ,accessexp
  500.                                          ,(cons-car accessexp)
  501.                                          ,(cadr item)
  502.                                        )
  503.                                       (cons-car accessexp)
  504.                                )    )
  505.                           %let-list
  506.                       ) )
  507.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  508.                         (analyze1 (car item) g name g)
  509.                       )
  510.                       (if (consp (cddr item))
  511.                         (setq %let-list
  512.                           (cons `(,(caddr item) (NOT (NULL ,accessexp))) %let-list)
  513.                )     )) )
  514.                (setq accessexp (cons-cdr accessexp))
  515.               )
  516.               (t ; notwendige Argumente
  517.                (setq %min-args (1+ %min-args))
  518.                (setq %arg-count (1+ %arg-count))
  519.                (cond ((symbolp item)
  520.                       (setq %let-list (cons `(,item ,(cons-car accessexp)) %let-list))
  521.                      )
  522.                      ((atom item)
  523.                       #1# ; (error-of-type ... name item), s.o.
  524.                      )
  525.                      (t
  526.                       (let ((%min-args 0) (%arg-count 0) (%restp nil))
  527.                         (analyze1 item (cons-car accessexp) name (cons-car accessexp))
  528.                )     ))
  529.                (setq accessexp (cons-cdr accessexp))
  530.   ) ) ) )     )
  531. )
  532.  
  533. (%putd 'remove-env-arg
  534.   (function remove-env-arg
  535.     (lambda (lambdalist name)
  536.       (do ((listr lambdalist (cdr listr)))
  537.           ((atom listr) (values lambdalist nil))
  538.         (if (eq (car listr) '&ENVIRONMENT)
  539.           (if (and (consp (cdr listr)) (symbolp (cadr listr)) (cadr listr))
  540.             ; &ENVIRONMENT gefunden
  541.             (return
  542.               (values
  543.                 (do ((l1 lambdalist (cdr l1)) ; lambdalist ohne &ENVIRONMENT/Symbol
  544.                      (l2 nil (cons (car l1) l2)))
  545.                     ((eq (car l1) '&ENVIRONMENT)
  546.                      (nreconc l2 (cddr l1))
  547.                 )   )
  548.                 (cadr listr)
  549.             ) )
  550.             (error-of-type 'program-error
  551.               (DEUTSCH "In der Lambdaliste des Macros ~S mu▀ nach &ENVIRONMENT ein Symbol (nicht NIL) folgen: ~S"
  552.                ENGLISH "In the lambda list of macro ~S, &ENVIRONMENT must be followed by a non-NIL symbol: ~S"
  553.                FRANCAIS "Dans la liste lambda du macro ~S, &ENVIRONMENT doit Ωtre suivi par un symbole autre que NIL : ~S")
  554.               name lambdalist
  555.           ) )
  556.   ) ) ) )
  557. )
  558.  
  559. (%putd 'make-length-test
  560.   (function make-length-test
  561.     (lambda (var &optional (header 1))
  562.       (cond ((and (zerop %min-args) %restp) NIL)
  563.             ((zerop %min-args) `(> (LENGTH ,var) ,(+ header %arg-count)))
  564.             (%restp `(< (LENGTH ,var) ,(+ header %min-args)))
  565.             ((= %min-args %arg-count) `(/= (LENGTH ,var) ,(+ header %min-args)))
  566.             (t `(NOT (<= ,(+ header %min-args) (LENGTH ,var) ,(+ header %arg-count))))
  567.   ) ) )
  568. )
  569.  
  570. (%putd 'make-macro-expansion
  571.   (function make-macro-expansion
  572.     (lambda (macrodef)
  573.       (if (atom macrodef)
  574.         (error-of-type 'program-error
  575.           (DEUTSCH "Daraus kann kein Macro definiert werden: ~S"
  576.            ENGLISH "Cannot define a macro from that: ~S"
  577.            FRANCAIS "Aucun macro n'est dΘfinissable α partir de ~S")
  578.           macrodef
  579.       ) )
  580.       (unless (symbolp (car macrodef))
  581.         (error-of-type 'program-error
  582.           (DEUTSCH "Der Name eines Macros mu▀ ein Symbol sein, nicht: ~S"
  583.            ENGLISH "The name of a macro must be a symbol, not ~S"
  584.            FRANCAIS "Le nom d'un macro doit Ωtre un symbole et non ~S")
  585.           (car macrodef)
  586.       ) )
  587.       (if (atom (cdr macrodef))
  588.         (error-of-type 'program-error
  589.           (DEUTSCH "Der Macro ~S hat keine Lambdaliste."
  590.            ENGLISH "Macro ~S is missing a lambda list."
  591.            FRANCAIS "Le macro ~S ne possΦde pas de liste lambda.")
  592.           (car macrodef)
  593.       ) )
  594.       (let ((name (car macrodef))
  595.             (lambdalist (cadr macrodef))
  596.             (body (cddr macrodef))
  597.            )
  598.         (multiple-value-bind (body-rest declarations docstring)
  599.                              (parse-body body t) ; globales Environment!
  600.           (if declarations (setq declarations (list (cons 'DECLARE declarations))))
  601.           (multiple-value-bind (newlambdalist envvar)
  602.                                (remove-env-arg lambdalist name)
  603.             (let ((%arg-count 0) (%min-args 0) (%restp nil)
  604.                   (%let-list nil) (%keyword-tests nil) (%default-form nil))
  605.               (analyze1 newlambdalist '(CDR <MACRO-FORM>) name '<MACRO-FORM>)
  606.               (let ((lengthtest (make-length-test '<MACRO-FORM>))
  607.                     (mainform `(LET* ,(nreverse %let-list)
  608.                                  ,@declarations
  609.                                  ,@(nreverse %keyword-tests)
  610.                                  ,@body-rest
  611.                    ))          )
  612.                 (if lengthtest
  613.                   (setq mainform
  614.                     `(IF ,lengthtest
  615.                        (MACRO-CALL-ERROR <MACRO-FORM>)
  616.                        ,mainform
  617.                 ) )  )
  618.                 (values
  619.                   `(FUNCTION ,name
  620.                      (LAMBDA (<MACRO-FORM> &OPTIONAL ,(or envvar '<ENV-ARG>))
  621.                        (DECLARE (CONS <MACRO-FORM>))
  622.                        ,@(if envvar
  623.                            declarations ; enthΣlt evtl. ein (declare (ignore envvar))
  624.                            '((DECLARE (IGNORE <ENV-ARG>)))
  625.                          )
  626.                        ,@(if docstring (list docstring))
  627.                        (BLOCK ,name ,mainform)
  628.                    ) )
  629.                   name
  630.                   lambdalist
  631.                   docstring
  632.   ) ) ) ) ) ) ) )
  633. )
  634.  
  635. (%putd 'make-macro-expandercons
  636.   (function make-macro-expandercons
  637.     (lambda (macrodef)
  638.       (cons 'MACRO (eval (make-macro-expansion macrodef)))
  639. ) ) )
  640.