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