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 / backquot.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1996-07-20  |  12.6 KB  |  325 lines
  1. ;;;; Backquote-Readmacro
  2. ;;;; Michael Stoll
  3. ;;;; umgeschrieben im Juli/August von Bruno Haible
  4. ;;;; rekursives Backquote 16.-17.8.1989
  5. ;;;; an die ⁿbliche Semantik fⁿr rekursives Backquote angepa▀t am 24.5.1992
  6.  
  7. (in-package "SYSTEM")
  8.  
  9. (proclaim '(special *backquote-level*))
  10. ; NIL oder Anzahl der erlaubten Kommata
  11. ; Wird beim Top-Level-Einsprung in den Reader an NIL gebunden.
  12.  
  13. (proclaim '(special *nsplice-fun*))
  14. (setq *nsplice-fun* 'NCONC) ; Funktion, die ein NSPLICE ausfⁿhrt
  15. ; (Wird an 'APPEND gebunden fⁿr die Produktion der Ausgabe-Form in
  16. ; verschachtelten Backquotes.)
  17.  
  18. ; Bug: Bei verschachtelten Backquotes werden manche Teilformen mehrfach
  19. ; ausgewertet (nΣmlich z.B. in der ersten Evaluation Formen, die fⁿrs
  20. ; Ausgeben vor der zweiten Evaluation n÷tig sind) und sollten deshalb
  21. ; seiteneffektfrei sein.
  22.  
  23. (defun \`-reader (stream char)
  24.   (declare (ignore char))
  25.   (let* ((*backquote-level* (1+ (or *backquote-level* 0)))
  26.          (skel (read stream t nil t))
  27.          (form (list 'BACKQUOTE
  28.                      (remove-backquote-third skel)
  29.                      (backquote-1 (unquote-level skel))
  30.         ))     )
  31.     (when (= *backquote-level* 1) (setq form (elim-unquote-dummy form)))
  32.     form
  33. ) )
  34.  
  35. (defun \,-reader (stream char &aux (c (peek-char nil stream)))
  36.   (declare (ignore char))
  37.   (cond ((null *backquote-level*)
  38.          (error-of-type 'error
  39.            (DEUTSCH "~S: Komma darf nur innerhalb von Backquote auftreten."
  40.             ENGLISH "~S: comma is illegal outside of backquote"
  41.             FRANCAIS "~S : Une virgule ne peut apparaεtre qu'α l'intΘrieur d'un ½backquote╗.")
  42.            'read
  43.         ))
  44.         ((zerop *backquote-level*)
  45.          (error-of-type 'error
  46.            (DEUTSCH "~S: Es dⁿrfen nicht mehr Kommata als Backquotes auftreten."
  47.             ENGLISH "~S: more commas out than backquotes in, is illegal"
  48.             FRANCAIS "~S : Il ne peut y avoir plus de virgules que de ½backquote╗.")
  49.            'read
  50.         ))
  51.         (t (let ((*backquote-level* (1- *backquote-level*)))
  52.              (cond ((eql c #\@)
  53.                     (read-char stream)
  54.                     (list 'SPLICE (list 'UNQUOTE (read stream t nil t)))
  55.                    )
  56.                    ((eql c #\.)
  57.                     (read-char stream)
  58.                     (list 'NSPLICE (list 'UNQUOTE (read stream t nil t)))
  59.                    )
  60.                    (t (list 'UNQUOTE (read stream t nil t)))
  61. ) )     )  ) )
  62.  
  63. ;(set-macro-character #\` #'\`-reader)
  64. ;(set-macro-character #\, #'\,-reader)
  65.  
  66. ; Hilfsfunktionen fⁿr Macros, die in Backquote-Formen expandieren.
  67. ; (Funktioniert nur mit einfach verschachtelten Backquote-Formen.)
  68. (defun add-backquote (skel)
  69.   (list 'BACKQUOTE
  70.         (remove-backquote-third skel)
  71.         (backquote-1 (unquote-level skel))
  72. ) )
  73. (defun add-unquote (skel)
  74.   (list 'UNQUOTE skel)
  75. )
  76.  
  77. ; Ausgabe von ...                              als ...
  78. ; (backquote original-form [expanded-form])    `original-form
  79. ; (splice (unquote form))                      ,@form
  80. ; (splice form)                                ,@'form
  81. ; (nsplice (unquote form))                     ,.form
  82. ; (nsplice form)                               ,.'form
  83. ; (unquote form)                               ,form
  84.  
  85. ;(defmacro backquote (original-form expanded-form)
  86. ;  (declare (ignore original-form))
  87. ;  expanded-form
  88. ;)
  89.  
  90. (defun remove-backquote-third (skel)
  91.   (cond ((atom skel)
  92.          (if (simple-vector-p skel)
  93.            (map 'vector #'remove-backquote-third skel)
  94.            skel
  95.         ))
  96.         ((and (eq (car skel) 'BACKQUOTE) (consp (cdr skel)))
  97.          (list 'BACKQUOTE (second skel)) ; ohne drittes Element der Liste
  98.         )
  99.         (t (cons (remove-backquote-third (car skel))
  100.                  (remove-backquote-third (cdr skel))
  101. ) )     )  )
  102.  
  103. ; ersetzt UNQUOTE-DUMMY durch UNQUOTE.
  104. (defun elim-unquote-dummy (skel)
  105.   (if (atom skel)
  106.     (cond ((eq skel 'UNQUOTE-DUMMY) 'UNQUOTE)
  107.           ((simple-vector-p skel) (map 'vector #'elim-unquote-dummy skel))
  108.           (t skel)
  109.     )
  110.     (let* ((car (car skel)) (newcar (elim-unquote-dummy car))
  111.            (cdr (cdr skel)) (newcdr (elim-unquote-dummy cdr)))
  112.       (if (and (eq car newcar) (eq cdr newcdr))
  113.         skel
  114.         (cons newcar newcdr)
  115. ) ) ) )
  116.  
  117. ;; wandelt im "Skelett" skel alle UNQUOTEs der Stufe level+1 (d.h. innerhalb
  118. ;; von level-fachem UNQUOTE) in UNQUOTE-VALUE um.
  119. (defun unquote-level (skel &optional (level 0))
  120.   (if (atom skel)
  121.     (if (simple-vector-p skel)
  122.       (map 'vector #'(lambda (subskel) (unquote-level subskel level)) skel)
  123.       skel
  124.     )
  125.     ; skel ist ein Cons
  126.     (cond ((and (eq (first skel) 'UNQUOTE) (consp (rest skel)))
  127.            (if (zerop level)
  128.              (list 'UNQUOTE-VALUE (second skel))
  129.              (let ((weiteres (unquote-level (second skel) (1- level))))
  130.                ; Vereinfache (UNQUOTE weiteres):
  131.                (if (and (consp weiteres) (eq (car weiteres) 'QUOTE)
  132.                         (consp (second weiteres))
  133.                         (eq (car (second weiteres)) 'UNQUOTE-VALUE)
  134.                    )
  135.                  ; (UNQUOTE (QUOTE (UNQUOTE-VALUE ...))) -> (UNQUOTE-VALUE ...)
  136.                  (second weiteres)
  137.                  (list 'UNQUOTE weiteres)
  138.           )) ) )
  139.           ((and (eq (first skel) 'BACKQUOTE) (consp (rest skel)))
  140.            (list* 'BACKQUOTE
  141.                   (unquote-level (second skel) (1+ level))
  142.                   (if (consp (cddr skel))
  143.                     (list (unquote-level (third skel) level))
  144.                     nil
  145.           ))      )
  146.           (t ; CAR-CDR-Rekursion
  147.             (cons (unquote-level (car skel) level)
  148.                   (unquote-level (cdr skel) level)
  149. ) ) )     ) )
  150.  
  151. ;; stellt fest, ob eine Form zu mehreren expandieren kann.
  152. (defun splicing-p (skel)
  153.   (and (consp skel)
  154.        (let ((h (first skel))) (or (eq h 'splice) (eq h 'nsplice)))
  155. ) )
  156.  
  157. ;; wandelt "Skelett" skel (mit UNQUOTE-VALUEs etc.) in passenden Code um.
  158. (defun backquote-1 (skel)
  159.   (if (atom skel)
  160.     (cond ((or (and (symbolp skel) (constantp skel) (eq skel (symbol-value skel)))
  161.                (numberp skel)
  162.                (stringp skel)
  163.                (bit-vector-p skel)
  164.            )
  165.            ; Konstanten, die zu sich selbst evaluieren, bleiben unverΣndert
  166.            skel
  167.           )
  168.           ((simple-vector-p skel)
  169.            ; Vektoren:
  170.            ; #(... item ...) -> (VECTOR ... item ...)
  171.            ; #(... ,@form ...) ->
  172.            ;   (MULTIPLE-VALUE-CALL #'VECTOR ... (VALUES-LIST form) ...)
  173.            (if (some #'splicing-p skel)
  174.              (list* 'MULTIPLE-VALUE-CALL
  175.                     '(FUNCTION VECTOR)
  176.                     (map 'list
  177.                          #'(lambda (subskel)
  178.                              (if (splicing-p subskel)
  179.                                (if (and (consp (second subskel))
  180.                                         (eq (first (second subskel)) 'UNQUOTE-VALUE)
  181.                                    )
  182.                                  (list 'VALUES-LIST (backquote-1 (second subskel)))
  183.                                  ; SPLICE bzw. NSPLICE fⁿr spΣter aufheben
  184.                                  (backquote-cons (backquote-1 (first subskel))
  185.                                                  (backquote-1 (rest subskel))
  186.                                ) )
  187.                                (list 'VALUES (backquote-1 subskel))
  188.                            ) )
  189.                          skel
  190.              )      )
  191.              (let ((einzelne (map 'list #'backquote-1 skel)))
  192.                (if (every #'constantp einzelne)
  193.                  ; alle Teile konstant -> sofort zusammensetzen
  194.                  (list 'QUOTE (map 'vector #'eval einzelne))
  195.                  (cons 'VECTOR einzelne)
  196.              ) )
  197.           ))
  198.           (t
  199.            ; sonstige Atome A in 'A umwandeln
  200.            (list 'QUOTE skel)
  201.     )     )
  202.     (cond ((eq (first skel) 'unquote-value)
  203.            ; ,form im richtigen Level wird zu form
  204.            (second skel)
  205.           )
  206.           ((eq (first skel) 'splice)
  207.            ; ,@form ist verboten
  208.            (error-of-type 'error
  209.              (DEUTSCH "Die Syntax ,@form ist nur innerhalb von Listen erlaubt."
  210.               ENGLISH "The syntax ,@form is valid only in lists"
  211.               FRANCAIS "La syntaxe ,@form n'est permise qu'α l'intΘrieur d'une liste.")
  212.           ))
  213.           ((eq (first skel) 'nsplice)
  214.            ; ,.form ist verboten
  215.            (error-of-type 'error
  216.              (DEUTSCH "Die Syntax ,.form ist nur innerhalb von Listen erlaubt."
  217.               ENGLISH "The syntax ,.form is valid only in lists"
  218.               FRANCAIS "La syntaxe ,.form n'est permise qu'α l'intΘrieur d'une liste.")
  219.           ))
  220.           ((and (eq (first skel) 'backquote) (consp (rest skel)))
  221.            ; verschachtelte Backquotes
  222.            (list* 'LIST
  223.                   ''BACKQUOTE
  224.                   (let ((*nsplice-fun* 'APPEND)) (backquote-1 (second skel)))
  225.                   (if (consp (cddr skel))
  226.                     (list (backquote-1 (third skel)))
  227.                     nil
  228.           ))      )
  229.           ((and (consp (first skel))
  230.                 (eq (first (first skel)) 'splice)
  231.            )
  232.            ; (  ... ,@EXPR ...  ) behandeln
  233.            (if (and (consp (second (first skel)))
  234.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  235.                )
  236.              (backquote-append (backquote-1 (second (first skel)))
  237.                                (backquote-1 (rest skel))
  238.              )
  239.              ; SPLICE fⁿr spΣter aufheben
  240.              (backquote-cons
  241.                (backquote-cons (backquote-1 (first (first skel)))
  242.                                (backquote-1 (rest (first skel)))
  243.                )
  244.                (backquote-1 (rest skel))
  245.           )) )
  246.           ((and (consp (first skel))
  247.                 (eq (first (first skel)) 'nsplice)
  248.            )
  249.            ; (  ... ,.EXPR ...  ) behandeln
  250.            (if (and (consp (second (first skel)))
  251.                     (eq (first (second (first skel))) 'UNQUOTE-VALUE)
  252.                )
  253.              (let ((erstes (backquote-1 (second (first skel))))
  254.                    (weiteres (backquote-1 (rest skel))))
  255.                ; (NCONC erstes weiteres) vereinfachen
  256.                (cond ((null weiteres)
  257.                       ; (NCONC expr NIL) -> (NCONC expr) -> expr
  258.                       (if (splicing-p erstes)
  259.                         (list *nsplice-fun* erstes)
  260.                         erstes
  261.                      ))
  262.                      ((and (consp weiteres) (eq (first weiteres) *nsplice-fun*))
  263.                       ; (NCONC expr (NCONC . rest)) -> (NCONC expr . rest)
  264.                       (list* *nsplice-fun* erstes (rest weiteres)) )
  265.                      (t (list *nsplice-fun* erstes weiteres))
  266.              ) )
  267.              ; NSPLICE fⁿr spΣter aufheben
  268.              (backquote-cons
  269.                (backquote-cons (backquote-1 (first (first skel)))
  270.                                (backquote-1 (rest (first skel)))
  271.                )
  272.                (backquote-1 (rest skel))
  273.           )) )
  274.           (t ; sonst CAR und CDR zusammensetzen
  275.              (backquote-cons (backquote-1 (first skel)) (backquote-1 (rest skel)))
  276.           )
  277. ) ) )
  278.  
  279. ; Liefert die Form, die das Append-Ergebnis der Formen erstes und weiteres
  280. ; ergibt.
  281. (defun backquote-append (erstes weiteres)
  282.   ; (APPEND erstes weiteres) vereinfachen
  283.   (cond ((null weiteres)
  284.          ; (APPEND expr NIL) -> (APPEND expr) -> expr
  285.          (if (splicing-p erstes)
  286.            (list 'APPEND erstes)
  287.            erstes
  288.         ))
  289.         ((and (consp weiteres) (eq (first weiteres) 'append))
  290.          ; (APPEND expr (APPEND . rest)) -> (APPEND expr . rest)
  291.          (list* 'APPEND erstes (rest weiteres)) )
  292.         (t (list 'APPEND erstes weiteres))
  293. ) )
  294.  
  295. ; Liefert die Form, die das Cons-Ergebnis der Formen erstes und weiteres
  296. ; ergibt.
  297. (defun backquote-cons (erstes weiteres)
  298.   ; (CONS erstes weiteres) vereinfachen
  299.   (cond ((and (constantp erstes) (constantp weiteres))
  300.          ; beide Teile konstant -> sofort zusammensetzen
  301.          (setq erstes (eval erstes))
  302.          (setq weiteres (eval weiteres))
  303.          (list 'QUOTE
  304.            (cons (if (eq erstes 'UNQUOTE) 'UNQUOTE-DUMMY erstes) weiteres)
  305.         ))
  306.         ((null weiteres)
  307.          ; (CONS expr NIL) -> (LIST expr)
  308.          (list 'LIST erstes)
  309.         )
  310.         ((atom weiteres)
  311.          (list 'CONS erstes weiteres) ; ohne Vereinfachung
  312.         )
  313.         ((eq (first weiteres) 'LIST)
  314.          ; (CONS expr (LIST . rest)) -> (LIST expr . rest)
  315.          (list* 'LIST erstes (rest weiteres))
  316.         )
  317.         ((or (eq (first weiteres) 'LIST*) (eq (first weiteres) 'CONS))
  318.          ; (CONS expr (LIST* . rest)) -> (LIST* expr . rest)
  319.          ; (CONS expr1 (CONS expr2 expr3)) -> (LIST* expr1 expr2 expr3)
  320.          (list* 'LIST* erstes (rest weiteres))
  321.         )
  322.         (t (list 'CONS erstes weiteres)) ; ohne Vereinfachung
  323. ) )
  324.  
  325.