blob: 77dfa3ff976f748328f12404cf321065e0d88b79 (
plain)
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
|
;;; swank-macrostep.lisp -- fancy macro-expansion via macrostep.el
;;
;; Authors: Luís Oliveira <luismbo@gmail.com>
;; Jon Oddie <j.j.oddie@gmail.com>
;;
;; License: Public Domain
(defpackage swank-macrostep
(:use cl swank)
(:import-from swank
#:*macroexpand-printer-bindings*
#:with-buffer-syntax
#:with-bindings
#:to-string
#:macroexpand-all
#:compiler-macroexpand-1
#:defslimefun
#:collect-macro-forms)
(:export #:macrostep-expand-1
#:macro-form-p))
(in-package #:swank-macrostep)
(defslimefun macrostep-expand-1 (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form (read-from-string string)))
(multiple-value-bind (expansion error-message)
(expand-form-once form compiler-macros? context)
(if error-message
`(:error ,error-message)
(multiple-value-bind (macros compiler-macros)
(collect-macro-forms-in-context expansion context)
(let* ((all-macros (append macros compiler-macros))
(pretty-expansion (pprint-to-string expansion))
(positions (collect-form-positions expansion
pretty-expansion
all-macros))
(subform-info
(loop
for form in all-macros
for (start end) in positions
when (and start end)
collect (let ((op-name (to-string (first form)))
(op-type
(if (member form macros)
:macro
:compiler-macro)))
(list op-name
op-type
start)))))
`(:ok ,pretty-expansion ,subform-info))))))))
(defun expand-form-once (form compiler-macros? context)
(multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(if expanded?
(values expansion nil)
(if (not compiler-macros?)
(values nil "Not a macro form")
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(if expanded?
(values expansion nil)
(values nil "Not a macro or compiler-macro form")))))))
(defslimefun macro-form-p (string compiler-macros? context)
(with-buffer-syntax ()
(let ((form
(handler-case
(read-from-string string)
(error (condition)
(unless (debug-on-swank-error)
(return-from macro-form-p
`(:error ,(format nil "Read error: ~A" condition))))))))
`(:ok ,(macro-form-type form compiler-macros? context)))))
(defun macro-form-type (form compiler-macros? context)
(cond
((or (not (consp form))
(not (symbolp (car form))))
nil)
((multiple-value-bind (expansion expanded?)
(macroexpand-1-in-context form context)
(declare (ignore expansion))
expanded?)
:macro)
((and compiler-macros?
(multiple-value-bind (expansion expanded?)
(compiler-macroexpand-1 form)
(declare (ignore expansion))
expanded?))
:compiler-macro)
(t
nil)))
;;;; Hacks to support macro-expansion within local context
(defparameter *macrostep-tag* (gensym))
(defparameter *macrostep-placeholder* '*macrostep-placeholder*)
(define-condition expansion-in-context-failed (simple-error)
())
(defmacro throw-expansion (form &environment env)
(throw *macrostep-tag* (macroexpand-1 form env)))
(defmacro throw-collected-macro-forms (form &environment env)
(throw *macrostep-tag* (collect-macro-forms form env)))
(defun macroexpand-1-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-expansion ,form) context)
(error ()
(macroexpand-1 form))))
(defun collect-macro-forms-in-context (form context)
(handler-case
(macroexpand-and-catch
`(throw-collected-macro-forms ,form) context)
(error ()
(collect-macro-forms form))))
(defun macroexpand-and-catch (form context)
(catch *macrostep-tag*
(macroexpand-all (enclose-form-in-context form context))
(error 'expansion-in-context-failed)))
(defun enclose-form-in-context (form context)
(with-buffer-syntax ()
(destructuring-bind (prefix suffix) context
(let* ((placeholder-form
(read-from-string
(concatenate
'string
prefix (prin1-to-string *macrostep-placeholder*) suffix)))
(substituted-form (subst form *macrostep-placeholder*
placeholder-form)))
(if (not (equal placeholder-form substituted-form))
substituted-form
(error 'expansion-in-context-failed))))))
;;;; Tracking Pretty Printer
(defun marker-char-p (char)
(<= #xe000 (char-code char) #xe8ff))
(defun make-marker-char (id)
;; using the private-use characters U+E000..U+F8FF as markers, so
;; that's our upper limit for how many we can use.
(assert (<= 0 id #x8ff))
(code-char (+ #xe000 id)))
(defun marker-char-id (char)
(assert (marker-char-p char))
(- (char-code char) #xe000))
(defparameter +whitespace+ (mapcar #'code-char '(9 13 10 32)))
(defun whitespacep (char)
(member char +whitespace+))
(defun pprint-to-string (object &optional pprint-dispatch)
(let ((*print-pprint-dispatch* (or pprint-dispatch *print-pprint-dispatch*)))
(with-bindings *macroexpand-printer-bindings*
(to-string object))))
#-clisp
(defun collect-form-positions (expansion printed-expansion forms)
(loop for (start end)
in (collect-marker-positions
(pprint-to-string expansion (make-tracking-pprint-dispatch forms))
(length forms))
collect (when (and start end)
(list (find-non-whitespace-position printed-expansion start)
(find-non-whitespace-position printed-expansion end)))))
;; The pprint-dispatch table constructed by
;; MAKE-TRACKING-PPRINT-DISPATCH causes an infinite loop and stack
;; overflow under CLISP version 2.49. Make the COLLECT-FORM-POSITIONS
;; entry point a no-op in thi case, so that basic macro-expansion will
;; still work (without detection of inner macro forms)
#+clisp
(defun collect-form-positions (expansion printed-expansion forms)
nil)
(defun make-tracking-pprint-dispatch (forms)
(let ((original-table *print-pprint-dispatch*)
(table (copy-pprint-dispatch)))
(flet ((maybe-write-marker (position stream)
(when position
(write-char (make-marker-char position) stream))))
(set-pprint-dispatch 'cons
(lambda (stream cons)
(let ((pos (position cons forms)))
(maybe-write-marker pos stream)
;; delegate printing to the original table.
(funcall (pprint-dispatch cons original-table)
stream
cons)
(maybe-write-marker pos stream)))
most-positive-fixnum
table))
table))
(defun collect-marker-positions (string position-count)
(let ((positions (make-array position-count :initial-element nil)))
(loop with p = 0
for char across string
unless (whitespacep char)
do (if (marker-char-p char)
(push p (aref positions (marker-char-id char)))
(incf p)))
(map 'list #'reverse positions)))
(defun find-non-whitespace-position (string position)
(loop with non-whitespace-position = -1
for i from 0 and char across string
unless (whitespacep char)
do (incf non-whitespace-position)
until (eql non-whitespace-position position)
finally (return i)))
(provide :swank-macrostep)
|
