home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / macros3.lsp < prev    next >
Lisp/Scheme  |  1996-04-15  |  13KB  |  323 lines
  1. (in-package "LISP")
  2. (export '(ethe letf letf*))
  3. (in-package "SYSTEM")
  4. ;-------------------------------------------------------------------------------
  5. ; Wie THE, nur daß auch im compilierten Code der Typtest durchgeführt wird.
  6. (defmacro ethe (typespec form)
  7.   (let ((g (gensym)))
  8.     `(THE ,typespec
  9.        (LET ((,g (MULTIPLE-VALUE-LIST ,form)))
  10.          (IF (SYS::%THE ,g ',typespec)
  11.            (VALUES-LIST ,g)
  12.            (ERROR-OF-TYPE 'ERROR ; 'TYPE-ERROR ??
  13.              #L{
  14.              DEUTSCH "Die Form ~S lieferte ~:[keine Werte~;~:*~{~S~^ ; ~}~] , das ist nicht vom Typ ~S."
  15.              ENGLISH "The form ~S yielded ~:[no values~;~:*~{~S~^ ; ~}~] , that's not of type ~S."
  16.              FRANCAIS "La forme ~S a rendu ~:[aucune valeur~;~:*~{~S~^ ; ~}~] , ceci n'est pas de type ~S."
  17.              }
  18.              ',form ,g ',typespec
  19. ) )  ) ) ) )
  20. ;-------------------------------------------------------------------------------
  21. ; Macro LETF / LETF* wie LET, LET*, nur daß als "Variable" beliebige Places
  22. ; (wie bei SETF) zugelassen sind, inklusive VALUES, VALUES-LIST.
  23.  
  24. ; (LETF ((A form)) ...) --> (LET ((A form)) ...)
  25.  
  26. ; (LETF (((CAR A) form)) ...)
  27. ;   --> (LET* ((#:G1 A)
  28. ;              (#:G2 (CAR #:G1))
  29. ;              (#:G3 form))
  30. ;         (UNWIND-PROTECT
  31. ;           (PROGN (SYSTEM::%RPLACA #:G1 #:G3) ...)
  32. ;           (SYSTEM::%RPLACA #:G1 #:G2)
  33. ;       ) )
  34.  
  35. ; (LETF (((VALUES A B) form)) ...) --> (MULTIPLE-VALUE-BIND (A B) form ...)
  36.  
  37. ; (LETF (((VALUES (CAR A) (CDR B)) form)) ...)
  38. ;   --> (LET* ((#:G1 A)
  39. ;              (#:G2 (CAR #:G1))
  40. ;              (#:G3 B)
  41. ;              (#:G4 (CDR #:G3)))
  42. ;         (MULTIPLE-VALUE-BIND (#:G5 #:G6) form
  43. ;           (UNWIND-PROTECT
  44. ;             (PROGN (SYSTEM::%RPLACA #:G1 #:G5) (SYSTEM::%RPLACD #:G3 #:G6)
  45. ;                    ...
  46. ;             )
  47. ;             (SYSTEM::%RPLACA #:G1 #:G2) (SYSTEM::%RPLACA #:G3 #:G4)
  48. ;       ) ) )
  49.  
  50. ; (LETF (((VALUES-LIST A) form)) ...)
  51. ;   --> (LET ((A (MULTIPLE-VALUE-LIST form))) ...)
  52.  
  53. (defmacro LETF* (bindlist &body body &environment env)
  54.   (multiple-value-bind (body-rest declarations)
  55.       (SYSTEM::PARSE-BODY body nil env)
  56.     (let ((declare (if declarations `((DECLARE ,@declarations)) '())))
  57.       (values (expand-LETF* bindlist declare body-rest))
  58. ) ) )
  59.  
  60. ; expandiert ein LETF*, liefert die Expansion und
  61. ; T, falls diese Expansion mit einem LET* anfängt, dessen Bindungsliste
  62. ; erweitert werden darf.
  63. (defun expand-LETF* (bindlist declare body)
  64.   (if (atom bindlist)
  65.     (if bindlist
  66.       (error-of-type 'program-error
  67.         #L{
  68.         DEUTSCH "Dotted List im Code von LETF*, endet mit ~S"
  69.         ENGLISH "LETF* code contains a dotted list, ending with ~S"
  70.         FRANCAIS "Dans le code de LETF*, occurence d'une paire pointée terminée en ~S"
  71.         }
  72.         bindlist
  73.       )
  74.       (values `(LET* () ,@declare ,@body) t)
  75.     )
  76.     (let ((bind (car bindlist)) place form)
  77.       (if (atom bind) (setq place bind form nil)
  78.         (if (and (consp (cdr bind)) (null (cddr bind)))
  79.           (progn
  80.             (setq place (car bind) form (cadr bind))
  81.             (when (and (consp place) (eq (car place) 'VALUES-LIST) (eql (length place) 2))
  82.               (setq place (second place) form `(MULTIPLE-VALUE-LIST ,form))
  83.             )
  84.             (loop
  85.               (if (and (consp place) (eq (car place) 'THE) (eql (length place) 3))
  86.                 (setq place (third place) form `(THE ,(second place) ,form))
  87.                 (return)
  88.           ) ) )
  89.           (error-of-type 'program-error
  90.             #L{
  91.             DEUTSCH "Falsche Syntax in Bindung zu LETF* : ~S"
  92.             ENGLISH "illegal syntax in LETF* binding: ~S"
  93.             FRANCAIS "Syntaxe illégale dans une liaison pour LETF* : ~S"
  94.             }
  95.             bind
  96.       ) ) )
  97.       (multiple-value-bind (rest-expanded flag)
  98.           (expand-LETF* (cdr bindlist) declare body)
  99.         (if (atom place)
  100.           (values
  101.             (if flag
  102.               `(LET* ,(cons (list place form) (cadr rest-expanded))
  103.                  ,@(cddr rest-expanded)
  104.                )
  105.               `(LET* ((,place ,form)) ,@declare ,rest-expanded)
  106.             )
  107.             t
  108.           )
  109.           (if (eq (car place) 'VALUES)
  110.             (if (every #'symbolp place)
  111.               (values
  112.                 `(MULTIPLE-VALUE-BIND ,(cdr place) ,form ,@declare ,rest-expanded)
  113.                 nil
  114.               )
  115.               (values
  116.                 (do ((bindlist nil)
  117.                      (storetemps nil)
  118.                      (stores1 nil)
  119.                      (stores2 nil)
  120.                      (subplacesr (cdr place)))
  121.                     ((atom subplacesr)
  122.                      `(LET* ,(nreverse bindlist)
  123.                         ,@declare
  124.                         (MULTIPLE-VALUE-BIND ,(nreverse storetemps) ,form
  125.                           ,@declare
  126.                           (UNWIND-PROTECT
  127.                             (PROGN ,@(nreverse stores1) ,rest-expanded)
  128.                             ,@(nreverse stores2)
  129.                     ) ) ) )
  130.                   (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  131.                       (get-setf-method (pop subplacesr))
  132.                     (setq bindlist
  133.                       (cons (list (first SM3) SM5)
  134.                             (nreconc (mapcar #'list SM1 SM2) bindlist)
  135.                     ) )
  136.                     (let ((storetemp (gensym)))
  137.                       (setq storetemps (cons storetemp storetemps))
  138.                       (setq stores1 (cons (subst storetemp (first SM3) SM4) stores1))
  139.                     )
  140.                     (setq stores2 (cons SM4 stores2))
  141.                 ) )
  142.                 t
  143.             ) )
  144.             (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place)
  145.               (let ((formvar (gensym)))
  146.                 (values
  147.                   `(LET* (,.(mapcar #'list SM1 SM2)
  148.                           (,(first SM3) ,SM5)
  149.                           (,formvar ,form))
  150.                      ,@declare
  151.                      (UNWIND-PROTECT
  152.                        (PROGN ,(subst formvar (first SM3) SM4) ,rest-expanded)
  153.                        ,SM4
  154.                    ) )
  155.                   t
  156.             ) ) )
  157. ) ) ) ) ) )
  158.  
  159. (defmacro LETF (bindlist &body body &environment env)
  160.   (multiple-value-bind (body-rest declarations)
  161.       (SYSTEM::PARSE-BODY body nil env)
  162.     (let ((declare (if declarations `((DECLARE ,@declarations)) '()))
  163.           (let-list nil))
  164.       (multiple-value-bind (let*-list let/let*-list uwp-store1 uwp-store2)
  165.           (expand-LETF bindlist)
  166.         ; mehrfach folgendes anwenden:
  167.         ; endet let*-list mit (#:G form) und kommt in let/let*-list (var #:G)
  168.         ; vor, so dürfen beide gestrichen werden, und dafür kommt (var form)
  169.         ; an den Anfang von let-list.
  170.         (setq let*-list (nreverse let*-list))
  171.         (loop
  172.           (unless (and (consp let*-list)
  173.                        (let ((last (caar let*-list)))
  174.                          (and (symbolp last) (null (symbol-package last))
  175.                               (dolist (bind let/let*-list nil)
  176.                                 (when (eq (second bind) last)
  177.                                   (push (list (first bind) (second (car let*-list)))
  178.                                         let-list
  179.                                   )
  180.                                   (setq let/let*-list
  181.                                     (delete last let/let*-list :key #'second
  182.                                             :test #'eq :count 1
  183.                                   ) )
  184.                                   (setq let*-list (cdr let*-list))
  185.                                   (return t)
  186.                   )    ) )    ) )
  187.             (return)
  188.         ) )
  189.         (setq let*-list (nreverse let*-list))
  190.         ; Nun muß folgendes gemacht werden:
  191.         ; 1. Die Bindungen von let*-list mit LETF* aktivieren,
  192.         ; 2. die Bindungen von let-list mit LET aktivieren,
  193.         ; 3. in beliebiger Reihenfolge:
  194.         ;    a. die Bindungen von let/let*-list mit LET oder LET* aktivieren,
  195.         ;    b. die Bindungen von uwp-store1 mit UNWIND-PROTECT aktivieren
  196.         ;       und danach mit uwp-store2 deaktivieren.
  197.         ; Beispielsweise:
  198. #|      `(LETF* ,let*-list
  199.            ,@declare
  200.            (LET ,let-list
  201.              ,@declare
  202.              (LET* ,let/let*-list
  203.                ,@declare
  204.                `(UNWIND-PROTECT (PROGN ,@uwp-store1 ,@body-rest) ,@uwp-store2)
  205.          ) ) )
  206. |#
  207.         (let ((body body-rest) ; eine Formenliste ohne Deklarationen
  208.               (1form nil)) ; zeigt an, ob body aus einer einzigen Form besteht
  209.           (when uwp-store1
  210.             (setq body `((UNWIND-PROTECT (PROGN ,@uwp-store1 ,@body) ,@uwp-store2))
  211.                   1form t
  212.           ) )
  213.           (when let/let*-list
  214.             (setq body `((LET* ,let/let*-list ,@declare ,@body)) 1form t)
  215.           )
  216.           (when let-list
  217.             (setq body `((LET ,let-list ,@declare ,@body)) 1form t)
  218.           )
  219.           (when let*-list
  220.             (setq body `((LETF* ,let*-list ,@declare ,@body)) 1form t)
  221.           )
  222.           (if (and 1form (or (null declare) (not (eq (caar body) 'unwind-protect))))
  223.             ; eine Form, keine Deklarationen oder fängt mit letf*/let/let* an
  224.             (car body)
  225.             ; allgemein
  226.             `(LET () ,@declare (PROGN ,@body))
  227. ) ) ) ) ) )
  228.  
  229. ; expandiert ein LETF, liefert:
  230. ; eine Bindungsliste für LETF*,
  231. ; eine Bindungsliste für LET/LET* (Reihenfolge der Bindung darin beliebig),
  232. ; eine Liste von Bindungsanweisungen, eine Liste von Entbindungsanweisungen
  233. ; (beide gleich lang).
  234. (defun expand-LETF (bindlist)
  235.   (if (atom bindlist)
  236.     (if bindlist
  237.       (error-of-type 'program-error
  238.         #L{
  239.         DEUTSCH "Dotted List im Code von LETF, endet mit ~S"
  240.         ENGLISH "LETF code contains a dotted list, ending with ~S"
  241.         FRANCAIS "Dans le code de LETF, occurence d'une paire pointée terminée en ~S"
  242.         }
  243.         bindlist
  244.       )
  245.       (values '() '() '() '())
  246.     )
  247.     (let ((bind (car bindlist)) place form)
  248.       (if (atom bind) (setq place bind form nil)
  249.         (if (and (consp (cdr bind)) (null (cddr bind)))
  250.           (progn
  251.             (setq place (car bind) form (cadr bind))
  252.             (when (and (consp place) (eq (car place) 'VALUES-LIST) (eql (length place) 2))
  253.               (setq place (second place) form `(MULTIPLE-VALUE-LIST ,form))
  254.             )
  255.             (loop
  256.               (if (and (consp place) (eq (car place) 'THE) (eql (length place) 3))
  257.                 (setq place (third place) form `(THE ,(second place) ,form))
  258.                 (return)
  259.           ) ) )
  260.           (error-of-type 'program-error
  261.             #L{
  262.             DEUTSCH "Falsche Syntax in Bindung zu LETF : ~S"
  263.             ENGLISH "illegal syntax in LETF binding: ~S"
  264.             FRANCAIS "Syntaxe illégale dans une liaison pour LETF : ~S"
  265.             }
  266.             bind
  267.       ) ) )
  268.       (multiple-value-bind (L1 L2 L3 L4) (expand-LETF (cdr bindlist))
  269.         (if (atom place)
  270.           (let ((g (gensym)))
  271.             (values (cons (list g form) L1) (cons (list place g) L2) L3 L4)
  272.           )
  273.           (if (eq (car place) 'VALUES)
  274.             (if (every #'symbolp place)
  275.               (let ((gs (mapcar #'(lambda (subplace)
  276.                                     (declare (ignore subplace))
  277.                                     (gensym)
  278.                                   )
  279.                                 (cdr place)
  280.                    ))   )
  281.                 (values
  282.                   (cons (list (cons 'VALUES gs) form) L1)
  283.                   (nconc (mapcar #'list (cdr place) gs) L2)
  284.                   L3
  285.                   L4
  286.               ) )
  287.               (do ((bindlist nil)
  288.                    (storetemps nil)
  289.                    (stores1 nil)
  290.                    (stores2 nil)
  291.                    (subplacesr (cdr place)))
  292.                   ((atom subplacesr)
  293.                    (values
  294.                      (nreconc bindlist
  295.                               (cons (list (cons 'VALUES storetemps) form) L1)
  296.                      )
  297.                      L2
  298.                      (nreconc stores1 L3)
  299.                      (nreconc stores2 L4)
  300.                   ))
  301.                 (multiple-value-bind (SM1 SM2 SM3 SM4 SM5)
  302.                     (get-setf-method (pop subplacesr))
  303.                   (setq bindlist
  304.                     (cons (list (first SM3) SM5)
  305.                           (nreconc (mapcar #'list SM1 SM2) bindlist)
  306.                   ) )
  307.                   (let ((storetemp (gensym)))
  308.                     (setq storetemps (cons storetemp storetemps))
  309.                     (setq stores1 (cons (subst storetemp (first SM3) SM4) stores1))
  310.                   )
  311.                   (setq stores2 (cons SM4 stores2))
  312.             ) ) )
  313.             (multiple-value-bind (SM1 SM2 SM3 SM4 SM5) (get-setf-method place)
  314.               (let ((g (gensym)))
  315.                 (values
  316.                   `(,.(mapcar #'list SM1 SM2) (,(first SM3) ,SM5) (,g ,form))
  317.                   L2
  318.                   (cons (subst g (first SM3) SM4) L3)
  319.                   (cons SM4 L4)
  320.             ) ) )
  321. ) ) ) ) ) )
  322.  
  323.