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