fare-quasiquote-readtable, using named-readtables.

diff --git a/.gitignore b/.gitignore
new file mode 100644 (file)
index 0000000..0b6535f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+*.fasl
+*.*fsl

diff --git a/fare-quasiquote-readtable.asd b/fare-quasiquote-readtable.asd
new file mode 100644 (file)
index 0000000..f7a0be0
--- /dev/null
+++ b/fare-quasiquote-readtable.asd
@@ -0,0 +1,5 @@
+;;; -*- Lisp -*-
+
+(asdf:defsystem :fare-quasiquote-readtable
+  :depends-on (:named-readtables :fare-matcher)
+  :components ((:file "quasiquote-readtable")))

diff --git a/pp-quasiquote.lisp b/pp-quasiquote.lisp
index 0576d0b..ddee99b 100644 (file)
--- a/pp-quasiquote.lisp
+++ b/pp-quasiquote.lisp
@@ -10,12 +10,11 @@
 (defun unparse-quasiquote-1 (form splicing)
   (ecase splicing
     ((nil)
-     `(unquote ,form))
+     (list 'unquote form))
     (:append
-     `((unquote-splicing ,form)))
+     (list (list 'unquote-splicing form)))
     (:nconc
-     `((unquote-nsplicing ,form)))
-    ))
+     (list (list 'unquote-nsplicing form)))))
 
 (defun unparse-quasiquote (form &optional splicing)
   "Given a lisp form containing the magic functions LIST, LIST*,
@@ -62,8 +61,8 @@
          ((and (consp (cadr form))
                (member (caadr form) *quasiquote-tokens*))
           (unparse-quasiquote-1 form splicing))
-         (t (cons (unparse-quasiquote `(cl:quote ,(caadr form)))
-                  (unparse-quasiquote `(cl:quote ,(cdadr form)))))))
+         (t (cons (unparse-quasiquote (list 'cl:quote (caadr form)))
+                  (unparse-quasiquote (list 'cl:quote (cdadr form)))))))
       (t
        (unparse-quasiquote-1 form splicing))))))
 

diff --git a/quasiquote-readtable.lisp b/quasiquote-readtable.lisp
new file mode 100644 (file)
index 0000000..944536a
--- /dev/null
+++ b/quasiquote-readtable.lisp
@@ -0,0 +1,20 @@
+;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; named readtables for fare-quasiquote
+;;; Copyright (c) 2011-2011 Fahree Reedaw <fare@tunes.org>
+;;; See README.quasiquote
+
+#+xcvb (module (:depends-on ("quasiquote" (:asdf "named-readtables"))))
+
+(in-package :fare-quasiquote)
+
+(eval-now
+  (named-readtables:defreadtable :fare-quasiquote-mixin
+    (:macro-char #\` #'read-read-time-backquote)
+    (:macro-char #\, #'read-comma)
+    (:macro-char #\# :dispatch)
+    (:dispatch-macro-char #\# #\( #'read-hash-paren))
+
+  (named-readtables:defreadtable :fare-quasiquote
+    (:fuze :standard :fare-quasiquote-mixin)))
+
+;; (in-readtable :fare-quasiquote-standard)

diff --git a/quasiquote.lisp b/quasiquote.lisp
index ca94c94..8b811e7 100644 (file)
--- a/quasiquote.lisp
+++ b/quasiquote.lisp
@@ -295,43 +295,40 @@ of the result of the top operation applied to the expression"
        (make-unquote (list 'n-vector n (quasiquote-expand contents)))
        (n-vector n contents))))
 
-(defun enable-quasiquote (&key expansion-time (readtable *readtable*))
+(defun read-read-time-backquote (stream char)
+  (declare (ignore char))
+  (values (macroexpand-1 (read-quasiquote stream))))
+(defun read-macroexpand-time-backquote (stream char)
+  (declare (ignore char))
+  (read-quasiquote stream))
+(defun read-backquote (stream char)
+  #-quasiquote-at-macro-expansion-time (read-read-time-backquote stream char)
+  #+quasiquote-at-macro-expansion-time (read-macroexpand-time-backquote stream char))
+(defun backquote-reader (expansion-time)
   (ecase expansion-time
-    ((read macroexpand))
-    ((nil)
-     (setf expansion-time
-           #-quasiquote-at-macro-expansion-time 'read
-           #+quasiquote-at-macro-expansion-time 'macroexpand)))
-  (set-macro-character
-   #\` (ecase expansion-time
-         ((read)
-          #'(lambda (stream char)
-              (declare (ignore char))
-              (values (macroexpand-1 (read-quasiquote stream)))))
-         ((macroexpand)
-          #'(lambda (stream char)
-              (declare (ignore char))
-              (read-quasiquote stream))))
-   nil readtable)
-  (set-macro-character
-   #\, #'(lambda (stream char)
-          (declare (ignore char))
-          (case (peek-char nil stream t nil t)
-            ((#\@)
-             (read-char stream t nil t)
-             (read-unquote-splicing stream))
-            ((#\.)
-             (read-char stream t nil t)
-             (read-unquote-nsplicing stream))
-            (otherwise (read-unquote stream))))
-   nil readtable)
+    ((read) #'read-read-time-backquote)
+    ((macroexpand) #'read-macroexpand-time-backquote)
+    ((nil) #'read-backquote)))
+(defun read-comma (stream char)
+  (declare (ignore char))
+  (case (peek-char nil stream t nil t)
+    ((#\@)
+     (read-char stream t nil t)
+     (read-unquote-splicing stream))
+    ((#\.)
+     (read-char stream t nil t)
+     (read-unquote-nsplicing stream))
+    (otherwise (read-unquote stream))))
+(defun read-hash-paren (stream subchar arg)
+  (declare (ignore subchar))
+  (read-vector stream arg))
+
+(defun enable-quasiquote (&key expansion-time (readtable *readtable*))
+  (set-macro-character #\` (backquote-reader expansion-time) nil readtable)
+  (set-macro-character #\, #'read-comma nil readtable)
   (when (eq expansion-time 'read)
-    (set-dispatch-macro-character
-     #\# #\(
-     #'(lambda (stream subchar arg)
-         (declare (ignore subchar))
-         (read-vector stream arg))
-     readtable))
+    (set-dispatch-macro-character #\# #\( #'read-hash-paren readtable))
   t)
 
 ;;(trace quasiquote-expand quasiquote-expand-0 quasiquote-expand-1 expand-unquote)
+