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