home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / macros1.lsp < prev    next >
Lisp/Scheme  |  1996-04-15  |  20KB  |  598 lines
  1. ;;;; Definitionen für Kontrollstrukturen etc.
  2. ;;;; 29. 4. 1988, 3. 9. 1988
  3.  
  4. (in-package "LISP")
  5. (export '(mapcap maplap))
  6. (in-package "SYSTEM")
  7.  
  8. (defmacro defvar (symbol &optional (initial-value nil svar) docstring)
  9.   (unless (symbolp symbol)
  10.     (error-of-type 'program-error
  11.       #L{
  12.       DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  13.       ENGLISH "~S: non-symbol ~S can't be a variable"
  14.       FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S"
  15.       }
  16.       'defvar symbol
  17.   ) )
  18.   (if (constantp symbol)
  19.     (error-of-type 'program-error
  20.       #L{
  21.       DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  22.       ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  23.       FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  24.       }
  25.       'defvar symbol
  26.   ) )
  27.   `(LET ()
  28.      (PROCLAIM '(SPECIAL ,symbol))
  29.      ,@(if svar
  30.          `((UNLESS (BOUNDP ',symbol) (SET ',symbol ,initial-value)))
  31.        )
  32.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  33.      ',symbol
  34.    )
  35. )
  36.  
  37. (defmacro defparameter (symbol initial-value &optional docstring)
  38.   (unless (symbolp symbol)
  39.     (error-of-type 'program-error
  40.       #L{
  41.       DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  42.       ENGLISH "~S: non-symbol ~S can't be a variable"
  43.       FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S."
  44.       }
  45.       'defparameter symbol
  46.   ) )
  47.   (if (constantp symbol)
  48.     (error-of-type 'program-error
  49.       #L{
  50.       DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  51.       ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  52.       FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  53.       }
  54.       'defparameter symbol
  55.   ) )
  56.   `(LET ()
  57.      (PROCLAIM '(SPECIAL ,symbol))
  58.      (SET ',symbol ,initial-value)
  59.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  60.      ',symbol
  61.    )
  62. )
  63.  
  64. (defmacro defconstant (&whole form symbol initial-value &optional docstring)
  65.   (unless (symbolp symbol)
  66.     (error-of-type 'program-error
  67.       #L{
  68.       DEUTSCH "~S: Nur Symbole können als Konstanten definiert werden, nicht ~S"
  69.       ENGLISH "~S: non-symbol ~S can't be a defined constant"
  70.       FRANCAIS "~S : Seuls les symboles peuvent servir de constante et non ~S."
  71.       }
  72.       'defconstant symbol
  73.   ) )
  74.   (let ((initial-var (gensym)))
  75.     `(LET ()
  76.        (EVAL-WHEN (COMPILE)
  77.          (COMPILER::C-PROCLAIM-CONSTANT ',symbol ',initial-value)
  78.        )
  79.        (LET ((,initial-var ,initial-value))
  80.          (IF (CONSTANTP ',symbol)
  81.            (UNLESS (CONSTANT-EQL ,initial-value ,initial-var (SYMBOL-VALUE ',symbol))
  82.              (CONSTANT-WARNING ',symbol ',form)
  83.          ) )
  84.          (SYS::%PROCLAIM-CONSTANT ',symbol ,initial-var)
  85.          ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  86.          ',symbol
  87.      ) )
  88. ) )
  89. ; For inhibiting warnings about redefining constants when the old and the new
  90. ; value are the same string / bit vector:
  91. (defmacro constant-eql (new-form new-value old-value)
  92.   (declare (ignore new-form))
  93.   `(EQL ,new-value ,old-value)
  94. )
  95. ; If new-value is known to be an immutable string / bit vector and old-value
  96. ; is the same string / bit vector, this can return T by using EQUAL instead of
  97. ; EQL.
  98. (defun loose-constant-eql (new-value old-value)
  99.   (and (equal (type-of new-value) (type-of old-value))
  100.        (equal new-value old-value)
  101. ) )
  102. ; The redefinition warning.
  103. (defun constant-warning (symbol form)
  104.   (warn 
  105.    #L{
  106.    DEUTSCH "In ~S wird die Konstante ~S umdefiniert. Ihr alter Wert war ~S."
  107.    ENGLISH "~S redefines the constant ~S. Its old value was ~S."
  108.    FRANCAIS "~S redéfinit la constante ~S. Son ancienne valeur était ~S."
  109.    }
  110.    form symbol (symbol-value symbol)
  111. ) )
  112.  
  113. (sys::%put 'and 'sys::macro
  114.   (sys::macro-expander and (&body args)
  115.     (cond ((null args) T)
  116.           ((null (cdr args)) (car args))
  117.           (t (let ((L (mapcar #'(lambda (x) `((NOT ,x) NIL) ) args)))
  118.                (rplaca (last L) `(T ,(car (last args))))
  119.                (cons 'COND L)
  120.   ) )     )  )
  121. )
  122.  
  123. (sys::%put 'or 'sys::macro
  124.   (sys::macro-expander or (&body args)
  125.     (cond ((null args) NIL)
  126.           ((null (cdr args)) (car args))
  127.           (t (let ((L (mapcar #'list args)))
  128.                (rplaca (last L) `(T ,(car (last args))))
  129.                (cons 'COND L)
  130.   ) )     )  )
  131. )
  132.  
  133. (sys::%put 'prog1 'sys::macro
  134.   (sys::macro-expander prog1 (form1 &rest moreforms)
  135.     (let ((g (gensym)))
  136.       `(LET ((,g ,form1)) ,@moreforms ,g)
  137.   ) )
  138. )
  139.  
  140. (sys::%put 'prog2 'sys::macro
  141.   (sys::macro-expander prog2 (form1 form2 &rest moreforms)
  142.     (let ((g (gensym)))
  143.       `(LET () (PROGN ,form1 (LET ((,g ,form2)) ,@moreforms ,g)))
  144.   ) )
  145. )
  146.  
  147. (sys::%put 'when 'sys::macro
  148.   (sys::macro-expander when (test &body forms)
  149.     `(IF ,test (PROGN ,@forms))
  150.   )
  151. )
  152.  
  153. (sys::%put 'unless 'sys::macro
  154.   (sys::macro-expander unless (test &body forms)
  155.     `(IF (NOT ,test) (PROGN ,@forms))
  156.   )
  157. )
  158.  
  159. (defmacro return (&optional return-value)
  160.   `(RETURN-FROM NIL ,return-value)
  161. )
  162.  
  163. (defmacro loop (&body body)
  164.   (let ((tag (gensym)))
  165.     `(BLOCK NIL (TAGBODY ,tag ,@body (GO ,tag)))
  166. ) )
  167.  
  168. (defun do/do*-expand (varclauselist exitclause body env do let psetq)
  169.   (when (atom exitclause)
  170.     (error-of-type 'program-error
  171.       #L{
  172.       DEUTSCH "Exitclause in ~S muß Liste sein."
  173.       ENGLISH "exit clause in ~S must be a list"
  174.       FRANCAIS "La clause de sortie dans ~S doit être une liste."
  175.       }
  176.       do
  177.   ) )
  178.   (let ((bindlist nil)
  179.         (reinitlist nil)
  180.         (testtag (gensym))
  181.         (exittag (gensym)))
  182.     (multiple-value-bind (body-rest declarations doc)
  183.                          (sys::parse-body body nil env)
  184.       (declare (ignore doc))
  185.       (if declarations
  186.         (setq declarations (list (cons 'DECLARE declarations)))
  187.       )
  188.       (loop
  189.         (when (atom varclauselist) (return))
  190.         (let ((varclause (first varclauselist)))
  191.           (setq varclauselist (rest varclauselist))
  192.           (cond ((atom varclause)
  193.                  (setq bindlist (cons varclause bindlist))
  194.                 )
  195.                 ((atom (cdr varclause))
  196.                  (setq bindlist (cons (first varclause) bindlist))
  197.                 )
  198.                 ((atom (cddr varclause))
  199.                  (setq bindlist (cons varclause bindlist))
  200.                 )
  201.                 (t (setq bindlist
  202.                      (cons (list (first varclause) (second varclause))
  203.                            bindlist
  204.                    ) )
  205.                    (setq reinitlist
  206.                      (list* (third varclause) (first varclause) reinitlist)
  207.       ) ) )     )  )
  208.       `(BLOCK NIL
  209.          (,let ,(nreverse bindlist)
  210.            ,@declarations
  211.            (TAGBODY
  212.              ,testtag
  213.              (IF ,(first exitclause) (GO ,exittag))
  214.              ,@body-rest
  215.              (,psetq ,@(nreverse reinitlist))
  216.              (GO ,testtag)
  217.              ,exittag
  218.              (RETURN-FROM NIL (PROGN ,@(rest exitclause)))
  219.        ) ) )
  220. ) ) )
  221.  
  222. (fmakunbound 'do)
  223. (defmacro do (varclauselist exitclause &body body &environment env)
  224.   (do/do*-expand varclauselist exitclause body env 'DO 'LET 'PSETQ)
  225. )
  226.  
  227. (defmacro do* (varclauselist exitclause &body body &environment env)
  228.   (do/do*-expand varclauselist exitclause body env 'DO* 'LET* 'SETQ)
  229. )
  230.  
  231. (defmacro dolist ((var listform &optional resultform) &body body &environment env)
  232.   (multiple-value-bind (body-rest declarations)
  233.                        (sys::parse-body body nil env)
  234.     (let ((g (gensym)))
  235.       `(DO* ((,g ,listform (CDR ,g))
  236.              (,var NIL))
  237.             ((ENDP ,g)
  238.              ,(if (constantp resultform)
  239.                ; Ist resultform konstant, so ist es /= var. Daher braucht var
  240.                ; während Auswertung von resultform nicht an NIL gebunden zu sein:
  241.                `,resultform
  242.                `(LET ((,var NIL))
  243.                   (DECLARE (IGNORABLE ,var) ,@declarations)
  244.                   ,resultform
  245.                 )
  246.               )
  247.             )
  248.          (DECLARE (LIST ,g) ,@declarations)
  249.          (SETQ ,var (CAR ,g))
  250.          ,@body-rest
  251.        )
  252. ) ) )
  253.  
  254. (fmakunbound 'dotimes)
  255. (defmacro dotimes ((var countform &optional resultform) &body body &environment env)
  256.   (multiple-value-bind (body-rest declarations)
  257.                        (sys::parse-body body nil env)
  258.     (if declarations
  259.       (setq declarations (list (cons 'DECLARE declarations)))
  260.     )
  261.     (if (constantp countform)
  262.       `(DO ((,var 0 (1+ ,var)))
  263.            ((>= ,var ,countform) ,resultform)
  264.          ,@declarations
  265.          ,@body-rest
  266.        )
  267.       (let ((g (gensym)))
  268.         `(DO ((,var 0 (1+ ,var))
  269.               (,g ,countform))
  270.              ((>= ,var ,g) ,resultform)
  271.            ,@declarations
  272.            ,@body-rest
  273. ) ) ) )  )
  274.  
  275. (sys::%put 'psetq 'sys::macro
  276.   (sys::macro-expander psetq (&whole form &rest args)
  277.     (do* ((setlist nil)
  278.           (bindlist nil)
  279.           (arglist args (cddr arglist)))
  280.          ((null arglist)
  281.           (setq setlist (cons 'NIL setlist))
  282.           (cons 'LET (cons (nreverse bindlist) (nreverse setlist)))
  283.          )
  284.       (if (null (cdr arglist))
  285.         (error-of-type 'program-error
  286.           #L{
  287.           DEUTSCH "~S mit einer ungeraden Anzahl von Argumenten aufgerufen: ~S"
  288.           ENGLISH "~S called with an odd number of arguments: ~S"
  289.           FRANCAIS "~S fut appellé avec un nombre impair d'arguments : ~S"
  290.           }
  291.           'psetq form
  292.       ) )
  293.       (let ((g (gensym)))
  294.         (setq setlist (cons `(SETQ ,(first arglist) ,g) setlist))
  295.         (setq bindlist (cons `(,g ,(second arglist)) bindlist))
  296.   ) ) )
  297. )
  298.  
  299. (sys::%put 'multiple-value-list 'sys::macro
  300.   (sys::macro-expander multiple-value-list (form)
  301.     `(MULTIPLE-VALUE-CALL #'LIST ,form)
  302.   )
  303. )
  304.  
  305. (sys::%put 'multiple-value-bind 'sys::macro
  306.   (sys::macro-expander multiple-value-bind (varlist form &body body)
  307.     (let ((g (gensym))
  308.           (poplist nil))
  309.       (dolist (var varlist) (setq poplist (cons `(,var (POP ,g)) poplist)))
  310.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)) ,@(nreverse poplist))
  311.          ,@body
  312.   ) )  )
  313. )
  314.  
  315. (sys::%put 'multiple-value-setq 'sys::macro
  316.   (sys::macro-expander multiple-value-setq (varlist form)
  317.     (let ((g (gensym))
  318.           (poplist nil))
  319.       (dolist (var varlist) (setq poplist (cons `(SETQ ,var (POP ,g)) poplist)))
  320.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)))
  321.          ,(if poplist `(PROG1 ,@(nreverse poplist)) NIL)
  322.   ) )  )
  323. )
  324.  
  325. (sys::%put 'locally 'sys::macro
  326.   (sys::macro-expander locally (&body body)
  327.     `(LET () ,@body)
  328.   )
  329. )
  330.  
  331. (defmacro case (keyform &body body)
  332.            ;; Common LISP, S. 117
  333.   (let ((var (gensym)))
  334.     `(LET ((,var ,keyform))
  335.        (COND
  336.          ,@(maplist
  337.              #'(lambda (remaining-clauses)
  338.                  (let ((clause (first remaining-clauses))
  339.                        (remaining-clauses (rest remaining-clauses)))
  340.                    (unless (consp clause)
  341.                      (error-of-type 'program-error
  342.                        #L{
  343.                        DEUTSCH "~S: Keylist fehlt."
  344.                        ENGLISH "~S: missing key list"
  345.                        FRANCAIS "~S : la liste d'objects-clé manque."
  346.                        }
  347.                        'case
  348.                    ) )
  349.                    (let ((keys (first clause)))
  350.                      `(,(cond ((or (eq keys 'T) (eq keys 'OTHERWISE))
  351.                                (if remaining-clauses
  352.                                  (error-of-type 'program-error
  353.                                    #L{
  354.                                    DEUTSCH "~S: Die ~S-Klausel muß die letzte sein."
  355.                                    ENGLISH "~S: the ~S clause must be the last one"
  356.                                    FRANCAIS "~S : La clause ~S doit être la dernière."
  357.                                    }
  358.                                    'case keys
  359.                                  )
  360.                                  'T
  361.                               ))
  362.                               ((listp keys) `(MEMBER ,var ',keys))
  363.                               (t `(EQL ,var ',keys))
  364.                         )
  365.                        ,@(rest clause)
  366.                ) ) )  )
  367.              body
  368. ) )  ) )   )
  369.  
  370. (defmacro prog (varlist &body body &environment env)
  371.   (multiple-value-bind (body-rest declarations)
  372.                        (sys::parse-body body nil env)
  373.     (if declarations
  374.       (setq declarations (list (cons 'DECLARE declarations)))
  375.     )
  376.     `(BLOCK NIL
  377.        (LET ,varlist
  378.          ,@declarations
  379.          (TAGBODY ,@body-rest)
  380. ) )  ) )
  381.  
  382. (defmacro prog* (varlist &body body &environment env)
  383.   (multiple-value-bind (body-rest declarations)
  384.                        (sys::parse-body body nil env)
  385.     (if declarations
  386.       (setq declarations (list (cons 'DECLARE declarations)))
  387.     )
  388.     `(BLOCK NIL
  389.        (LET* ,varlist
  390.          ,@declarations
  391.          (TAGBODY ,@body-rest)
  392. ) )  ) )
  393.  
  394.  
  395. ;;; Macro-Expander für COND:
  396.  
  397. #|
  398. ;; Dieser hier ist zwar kürzer, aber er reduziert COND auf OR,
  399. ;; das seinerseits wieder auf COND reduziert, ...
  400. (sys::%put 'cond 'sys::macro
  401.   (sys::macro-expander cond (&body clauses)
  402.     (ifify clauses)
  403.   )
  404. )
  405. ; macht eine clauselist von COND zu verschachtelten IFs und ORs.
  406. (defun ifify (clauselist)
  407.   (cond ((null clauselist) NIL)
  408.         ((atom clauselist)
  409.          (error-of-type 'program-error
  410.            #L{
  411.            DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  412.            ENGLISH "Not a list of COND clauses: ~S"
  413.            FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  414.            }
  415.            clauselist
  416.         ))
  417.         ((atom (car clauselist))
  418.          (error-of-type 'program-error
  419.            #L{
  420.            DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  421.            ENGLISH "The atom ~S must not be used as a COND clause."
  422.            FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  423.            }
  424.            (car clauselist)
  425.         ))
  426.         (t (let ((ifif (ifify (cdr clauselist))))
  427.              (if (cdar clauselist)
  428.                ; mindestens zweielementige Klausel
  429.                (if (constantp (caar clauselist))
  430.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  431.                    (if (cddar clauselist)
  432.                      `(PROGN ,@(cdar clauselist))
  433.                      (cadar clauselist)
  434.                    )
  435.                    ifif
  436.                  )
  437.                  `(IF ,(caar clauselist)
  438.                     ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  439.                     ,ifif
  440.                   )
  441.                )
  442.                ; einelementige Klausel
  443.                (if (constantp (caar clauselist))
  444.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  445.                    (caar clauselist)
  446.                    ifif
  447.                  )
  448.                  `(OR ,(caar clauselist) ,ifif)
  449. ) )     )  ) ) )
  450. |#
  451.  
  452. ;; Noch einfacher ginge es auch so:
  453. #|
  454. (sys::%put 'cond 'sys::macro
  455.   (sys::macro-expander cond (&body clauses)
  456.     (cond ((null clauses) 'NIL)
  457.           ((atom clauses)
  458.            (error-of-type 'program-error
  459.              #L{
  460.              DEUTSCH "Dotted List im Code von COND, endet mit ~S"
  461.              ENGLISH "COND code contains a dotted list, ending with ~S"
  462.              FRANCAIS "Occurence d'une paire pointée dans le code de COND, terminée en : ~S."
  463.              }
  464.              clauses
  465.           ))
  466.           (t (let ((clause (car clauses)))
  467.                (if (atom clause)
  468.                  (error-of-type 'program-error
  469.                    #L{
  470.                    DEUTSCH "COND-Klausel ohne Test: ~S"
  471.                    ENGLISH "COND clause without test: ~S"
  472.                    FRANCAIS "Clause COND sans aucun test : ~S"
  473.                    }
  474.                    clause
  475.                  )
  476.                  (let ((test (car clause)))
  477.                    (if (cdr clause)
  478.                      `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  479.                      `(OR ,test (COND ,@(cdr clauses)))
  480. ) ) )     )  ) ) ) )
  481. |#
  482.  
  483. ;; Dieser hier reduziert COND etwas umständlicher auf IF-Folgen:
  484. (sys::%put 'cond 'sys::macro
  485.   (sys::macro-expander cond (&body clauses)
  486.     (let ((g (gensym)))
  487.       (multiple-value-bind (ifif needed-g) (ifify clauses g)
  488.         (if needed-g
  489.           `(LET (,g) ,ifif)
  490.           ifif
  491.   ) ) ) )
  492. )
  493. ; macht eine clauselist von COND zu verschachtelten IFs.
  494. ; Zwei Werte: die neue Form, und ob die Dummyvariable g benutzt wurde.
  495. (defun ifify (clauselist g)
  496.   (cond ((null clauselist) (values NIL nil))
  497.         ((atom clauselist)
  498.          (error-of-type 'program-error
  499.            #L{
  500.            DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  501.            ENGLISH "Not a list of COND clauses: ~S"
  502.            FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  503.            }
  504.            clauselist
  505.         ))
  506.         ((atom (car clauselist))
  507.          (error-of-type 'program-error
  508.            #L{
  509.            DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  510.            ENGLISH "The atom ~S must not be used as a COND clause."
  511.            FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  512.            }
  513.            (car clauselist)
  514.         ))
  515.         (t (multiple-value-bind (ifif needed-g) (ifify (cdr clauselist) g)
  516.              (if (cdar clauselist)
  517.                ; mindestens zweielementige Klausel
  518.                (if (constantp (caar clauselist))
  519.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  520.                    (if (cddar clauselist)
  521.                      (values `(PROGN ,@(cdar clauselist)) nil)
  522.                      (values (cadar clauselist) nil)
  523.                    )
  524.                    (values ifif needed-g)
  525.                  )
  526.                  (values
  527.                    `(IF ,(caar clauselist)
  528.                         ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  529.                         ,ifif
  530.                     )
  531.                    needed-g
  532.                ) )
  533.                ; einelementige Klausel
  534.                (if (constantp (caar clauselist))
  535.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  536.                    (values (caar clauselist) nil)
  537.                    (values ifif needed-g)
  538.                  )
  539.                  (if (atom (caar clauselist))
  540.                    (values ; ein Atom produziert nur einen Wert und darf
  541.                      `(IF ,(caar clauselist) ; mehrfach hintereinander
  542.                           ,(caar clauselist) ; ausgewertet werden!
  543.                           ,ifif
  544.                       )
  545.                      needed-g
  546.                    )
  547.                    (values
  548.                      `(IF (SETQ ,g ,(caar clauselist)) ,g ,ifif)
  549.                      t
  550. ) )     )  ) ) ) ) )
  551.  
  552. ;;; Mapping (Kapitel 7.8.4)
  553.  
  554. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  555. ; (mapcap fun &rest lists) ==  (apply #'append (apply #'mapcar fun lists))
  556. (defun mapcap (fun &rest lists &aux (L nil))
  557.   (loop
  558.     (setq L
  559.       (nconc
  560.         (reverse
  561.           (apply fun
  562.             (maplist #'(lambda (listsr)
  563.                          (if (atom (car listsr))
  564.                            (return)
  565.                            (pop (car listsr))
  566.                        ) )
  567.                      lists
  568.         ) ) )
  569.         L
  570.       )
  571.   ) )
  572.   (sys::list-nreverse L)
  573. )
  574.  
  575. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  576. ; (maplap fun &rest lists) == (apply #'append (apply #'maplist fun lists))
  577. (defun maplap (fun &rest lists &aux (L nil))
  578.   (loop
  579.     (setq L
  580.       (nconc
  581.         (reverse
  582.           (apply fun
  583.             (maplist #'(lambda (listsr)
  584.                          (if (atom (car listsr))
  585.                            (return)
  586.                            (prog1
  587.                              (car listsr)
  588.                              (setf (car listsr) (cdr (car listsr)))
  589.                        ) ) )
  590.                      lists
  591.         ) ) )
  592.         L
  593.       )
  594.   ) )
  595.   (sys::list-nreverse L)
  596. )
  597.  
  598.