blob: 7c4c5a30c98e05087ad6d7c30acd7aa37dfa1c9f (
plain) (
blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
(in-package #:quasiquote-2.0)
(defun read-n-chars (stream char)
(let (new-char
(n 0))
(loop
(setf new-char (read-char stream nil :eof t))
(if (not (char= new-char char))
(progn (unread-char new-char stream)
(return n))
(incf n)))))
(defmacro define-dig-reader (name symbol)
`(defun ,name (stream char)
(let ((depth (1+ (read-n-chars stream char))))
(if (equal 1 depth)
(list ',symbol (read stream t nil t))
(list ',symbol
depth
(read stream t nil t))))))
(define-dig-reader dig-reader dig)
(define-dig-reader odig-reader odig)
(defun expect-char (char stream)
(let ((new-char (read-char stream t nil t)))
(if (char= char new-char)
t
(unread-char new-char stream))))
(defun guess-injector-name (opaque-p macro-p all-p splicing-p)
(intern (concatenate 'string
(if opaque-p "O" "")
(if macro-p "MACRO-" "")
(if splicing-p "SPLICE" "INJECT")
(if all-p "-ALL" ""))
"QUASIQUOTE-2.0"))
(defun inject-reader (stream char)
(let ((anti-depth (1+ (read-n-chars stream char)))
(extended-syntax (expect-char #\! stream)))
(let ((injector-name (if (not extended-syntax)
(guess-injector-name nil nil nil (expect-char #\@ stream))
(guess-injector-name (expect-char #\o stream)
(expect-char #\m stream)
(expect-char #\a stream)
(expect-char #\@ stream)))))
`(,injector-name ,@(if (not (equal 1 anti-depth)) `(,anti-depth))
,(read stream t nil t)))))
(defvar *previous-readtables* nil)
(defun %enable-quasiquote-2.0 ()
(push *readtable*
*previous-readtables*)
(setq *readtable* (copy-readtable))
(set-macro-character #\` #'dig-reader)
(set-macro-character #\, #'inject-reader)
(values))
(defun %disable-quasiquote-2.0 ()
(if *previous-readtables*
(setf *readtable* (pop *previous-readtables*))
(setf *readtable* (copy-readtable nil)))
(values))
(defmacro enable-quasiquote-2.0 ()
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%enable-quasiquote-2.0)))
(defmacro disable-quasiquote-2.0 ()
`(eval-when (:compile-toplevel :load-toplevel :execute)
(%disable-quasiquote-2.0)))
|
