Commit 032b99c2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

fare-quasiquote-readtable, using named-readtables.

parent d0288343
*.fasl
*.*fsl
;;; -*- Lisp -*-
(asdf:defsystem :fare-quasiquote-readtable
:depends-on (:named-readtables :fare-matcher)
:components ((:file "quasiquote-readtable")))
......@@ -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))))))
......
;;; -*- 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)
......@@ -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)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment