about summary refs log tree commit diff
path: root/quasiquote-2.0.lisp
blob: 9ce0425d56af33b0d320646a2611053083852ca6 (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
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
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
;;;; quasiquote-2.0.lisp

(in-package #:quasiquote-2.0)

(defparameter *env* nil)

(defmacro nonsense-error (str)
  `(error ,(concatenate 'string
			str
			" appears as a bare, non DIG-enclosed form. "
			"For now I don't know how to make sense of this.")))

(defmacro define-nonsense-when-bare (name)
  `(defmacro ,name (n-or-form &optional form)
     (declare (ignore n-or-form form))
     (nonsense-error ,(string name))))

(define-nonsense-when-bare inject)
(define-nonsense-when-bare oinject)
(define-nonsense-when-bare splice)
(define-nonsense-when-bare osplice)
(define-nonsense-when-bare macro-inject)

(defparameter *depth* 0)


(defparameter *injectors* nil)

;; (defmacro with-injector-parsed (form)
;;   `(let ((kwd (intern (string 

(defun reset-injectors ()
  (setf *injectors* nil))

(defparameter *known-injectors* '(inject splice oinject osplice
				  macro-inject omacro-inject
				  macro-splice omacro-splice
				  macro-inject-all omacro-inject-all
				  macro-splice-all omacro-splice-all))

(defun injector-form-p (form)
  (and (consp form)
       (find (car form) *known-injectors* :test #'eq)))

(defun injector-level (form)
  (if (equal 2 (length form))
      1
      (cadr form)))

(defun injector-subform (form)
  (if (equal 2 (length form))
      (values (cdr form) '(cdr))
      (values (cddr form) '(cddr))))

(defparameter *opaque-injectors* '(odig oinject osplice omacro-inject))

(defun transparent-p (form)
  (not (find (car form) *opaque-injectors* :test #'eq)))

(defun look-into-injector (form path)
  (let ((*depth* (- *depth* (injector-level form))))
    (multiple-value-bind (subform subpath) (injector-subform form)
      (search-all-active-sites subform (append subpath path) nil))))

(defparameter *known-diggers* '(dig odig))

(defun dig-form-p (form)
  (and (consp form)
       (find (car form) *known-diggers* :test #'eq)))

(defun look-into-dig (form path)
  (let ((*depth* (+ *depth* (injector-level form))))
    (multiple-value-bind (subform subpath) (injector-subform form)
      (search-all-active-sites subform (append subpath path) nil))))

(defun handle-macro-1 (form)
  (if (atom form)
      (error "Sorry, symbol-macros are not implemented for now")
      (let ((fun (macro-function (car form) *env*)))
	(if (not fun)
	    (error "The subform of MACRO-1 injector is supposed to be macro, perhaps, something went wrong..."))
	(macroexpand-1 form *env*))))

(defun handle-macro-all (form)
  (if (atom form)
      (error "Sorry, symbol-macros are not implemented for now")
      (macroexpand form *env*)))


(defparameter *macro-handlers* `((macro-inject . ,#'handle-macro-1)
				 (omacro-inject . ,#'handle-macro-1)
				 (macro-splice . ,#'handle-macro-1)
				 (omacro-splice . ,#'handle-macro-1)
				 (macro-inject-all . ,#'handle-macro-all)
				 (omacro-inject-all . ,#'handle-macro-all)
				 (macro-splice-all . ,#'handle-macro-all)
				 (omacro-splice-all . ,#'handle-macro-all)))

(defun get-macro-handler (sym)
  (or (cdr (assoc sym *macro-handlers*))
      (error "Don't know how to handle this macro injector: ~a" sym)))

	

(defun macroexpand-macroinjector (place)
  (if (not (splicing-injector (car place)))
      (progn (setf (car place) (funcall (get-macro-handler (caar place))
					(car (injector-subform (car place)))))
	     nil)
      (let ((new-forms (funcall (get-macro-handler (caar place))
				(car (injector-subform (car place))))))
	(cond ((not new-forms)
	       (setf *void-filter-needed* t
		     (car place) *void-elt*))
	      ((atom new-forms) (error "We need to splice the macroexpansion, but got atom: ~a" new-forms))
	      (t (setf (car place) (car new-forms))
		 (let ((tail (cdr place)))
		   (setf (cdr place) (cdr new-forms)
			 (cdr (last new-forms)) tail))))
	t)))
	    

(defun search-all-active-sites (form path toplevel-p)
  ;; (format t "SEARCH-ALL-ACTIVE-SITES: got form ~a~%" form)
  (if (not form)
      nil
      (if toplevel-p
	  (cond ((atom (car form)) :just-quote-it!)
		((injector-form-p (car form)) (if (equal *depth* (injector-level (car form)))
						  :just-form-it!
						  (if (transparent-p (car form))
						      (look-into-injector (car form) (cons 'car path)))))
		((dig-form-p (car form))
		 ;; (format t "Got dig form ~a~%" form)
		 (if (transparent-p (car form))
		     (look-into-dig (car form) (cons 'car path))))
		(t (search-all-active-sites (car form) (cons 'car path) nil)
		   (search-all-active-sites (cdr form) (cons 'cdr path) nil)))
	  (when (consp form)
	    (cond ((dig-form-p (car form))
		   ;; (format t "Got dig form ~a~%" form)
		   (if (transparent-p (car form))
		       (look-into-dig (car form) (cons 'car path))))
		  ((injector-form-p (car form))
		   ;; (format t "Got injector form ~a ~a ~a~%" form *depth* (injector-level (car form)))
		   (if (equal *depth* (injector-level (car form)))
		       (if (macro-injector-p (car form))
			   (progn (macroexpand-macroinjector form)
				  (return-from search-all-active-sites
				    (search-all-active-sites form path nil)))
			   (progn (push (cons form (cons 'car path)) *injectors*)
				  nil))
		       (if (transparent-p (car form))
			   (look-into-injector (car form) (cons 'car path)))))
		  (t (search-all-active-sites (car form) (cons 'car path) nil)))
	    (search-all-active-sites (cdr form) (cons 'cdr path) nil)))))

	  
	      
(defun codewalk-dig-form (form)
  (reset-injectors)
  (let ((it (search-all-active-sites form nil t)))
    (values (nreverse *injectors*) it)))

(defun %codewalk-dig-form (form)
  (if (not (dig-form-p form))
      (error "Supposed to be called on dig form")
      (let ((*depth* (+ (injector-level form) *depth*)))
	(codewalk-dig-form (injector-subform form)))))

(defun path->setfable (path var)
  (let ((res var))
    ;; First element is artifact of extra CAR-ing
    (dolist (spec (cdr (reverse path)))
      (setf res (list spec res)))
    res))

(defun tree->cons-code (tree)
  (if (atom tree)
      `(quote ,tree)
      `(cons ,(tree->cons-code (car tree))
	     ,(tree->cons-code (cdr tree)))))

(defparameter *known-splicers* '(splice osplice
				 macro-splice omacro-splice
				 macro-splice-all omacro-splice-all))

(defun splicing-injector (form)
  (and (consp form)
       (find (car form) *known-splicers* :test #'eq)))

(defparameter *known-macro-injectors* '(macro-inject omacro-inject
					macro-splice omacro-splice
					macro-inject-all omacro-inject-all
					macro-splice-all omacro-splice-all
					))

(defun macro-injector-p (form)
  (and (consp form)
       (find (car form) *known-macro-injectors* :test #'eq)))

(defparameter *void-elt* nil)
(defparameter *void-filter-needed* nil)

(defun filter-out-voids (lst void-sym)
  (let (caars cadrs cdars cddrs)
    ;; search for all occurences of VOID
    (labels ((rec (x)
	       (if (consp x)
		   (progn (cond ((consp (car x))
				 (cond ((eq void-sym (caar x)) (push x caars))
				       ((eq void-sym (cdar x)) (push x cdars))))
				((consp (cdr x))
				 (cond ((eq void-sym (cadr x)) (push x cadrs))
				       ((eq void-sym (cddr x)) (push x cddrs)))))
			  (rec (car x))
			  (rec (cdr x))))))
      (rec lst))
    (if (or cdars cddrs)
	(error "Void sym found on CDR position, which should not have happened"))
    ;; destructively transform LST
    (dolist (elt caars)
      (setf (car elt) (cdar elt)))
    (dolist (elt cadrs)
      (setf (cdr elt) (cddr elt)))
    ;; check that we indeed filtered-out all VOIDs
    (labels ((rec (x)
	       (if (not (atom x))
		   (progn (rec (car x))
			  (rec (cdr x)))
		   (if (eq void-sym x)
		       (error "Not all VOIDs were filtered")))))
      (rec lst))
    lst))

(defun transform-dig-form (form)
  (let ((the-form (copy-tree form)))
    (let ((*void-filter-needed* nil)
	  (*void-elt* (gensym "VOID")))
      (multiple-value-bind (site-paths cmd) (%codewalk-dig-form the-form)
	(cond ((eq cmd :just-quote-it!)
	       `(quote ,(car (injector-subform the-form))))
	      ((eq cmd :just-form-it!)
	       (car (injector-subform (car (injector-subform the-form)))))
	      (t (let ((cons-code (if (not site-paths)
				      (tree->cons-code (car (injector-subform the-form)))
				      (really-transform-dig-form the-form site-paths))))
		   (if (not *void-filter-needed*)
		       cons-code
		       `(filter-out-voids ,cons-code ',*void-elt*)))))))))

(defmacro make-list-form (o!-n form)
  (let ((g!-n (gensym "N"))
	(g!-i (gensym "I"))
	(g!-res (gensym "RES")))
    `(let ((,g!-n ,o!-n)
	   (,g!-res nil))
       (dotimes (,g!-i ,g!-n)
	 (push ,form ,g!-res))
       (nreverse ,g!-res))))

(defun mk-splicing-injector-let (x)
  `(let ((it ,(car (injector-subform x))))
     (assert (listp it))
     (copy-list it)))



(defun mk-splicing-injector-setf (path g!-list g!-splicee)
  (assert (eq 'car (car path)))
  (let ((g!-rest (gensym "REST")))
    `(let ((,g!-rest ,(path->setfable (cons 'cdr (cdr path)) g!-list)))
       (assert (or (not ,g!-rest) (consp ,g!-rest)))
       (if (not ,g!-splicee)
	   (setf ,(path->setfable (cdr path) g!-list)
		 ,g!-rest)
	   (progn (setf ,(path->setfable (cdr path) g!-list) ,g!-splicee)
		  (setf (cdr (last ,g!-splicee)) ,g!-rest))))))


(defun really-transform-dig-form (the-form site-paths)
  (let ((gensyms (make-list-form (length site-paths) (gensym "INJECTEE"))))
    (let ((g!-list (gensym "LIST")))
      (let ((lets nil)
	    (splicing-setfs nil)
	    (setfs nil))
	(do ((site-path site-paths (cdr site-path))
	     (gensym gensyms (cdr gensym)))
	    ((not site-path))
	  (destructuring-bind (site . path) (car site-path)
	    (push `(,(car gensym) ,(if (not (splicing-injector (car site)))
				       (car (injector-subform (car site)))
				       (mk-splicing-injector-let (car site))))
		  lets)
	    (if (not (splicing-injector (car site)))
		(push `(setf ,(path->setfable path g!-list) ,(car gensym)) setfs)
		(push (mk-splicing-injector-setf path g!-list (car gensym)) splicing-setfs))
	    (setf (car site) nil)))
	`(let ,(nreverse lets)
	   (let ((,g!-list ,(tree->cons-code (car (injector-subform the-form)))))
	     ,@(nreverse setfs)
	     ;; we apply splicing setf in reverse order for them not to bork the paths of each other
	     ,@splicing-setfs
	     ,g!-list))))))


;; There are few types of recursive injection that may happen:
;;   * compile-time injection:
;;     (dig (inject (dig (inject a)))) -- this type will be handled automatically by subsequent macroexpansions
;;   * run-time injection:
;;     (dig (dig (inject 2 a)))
;;     and A is '(dig (inject 3 'foo)) -- this one we guard against ? (probably, first we just ignore it
;;     -- do not warn about it, and then it wont really happen.
;;   * macroexpanded compile-time injection:
;;     (dig (inject (my-macro a b c))),
;;     where MY-MACRO expands into, say (splice (list 'a 'b 'c))
;;     This is *not* handled automatically, and therefore we must do it by hand.

      
;; OK, now how to implement splicing ?
;;   (dig (a (splice (list b c)) d))
;; should transform into code that yields
;;   (a b c d)
;; what this code is?
;;   (let ((#:a (copy-list (list b c))))
;;     (let ((#:res (cons 'a nil 'd)))
;;       ;; all non-splicing injects go here, as they do not spoil the path-structure
;;       (setf (cdr #:res) #:a)
;;       (setf (cdr (last #:a)) (cdr (cdr #:res)))
;;       #:res)))


;; How this macroexpansion should work in general?
;;   * We go over the cons-tree, keeping track of the depth level, which is
;;   controlled by DIG's
;;   * Once we find the INJECT with matching level, we remember the place, where
;;     this happens
;;   * We have two special cases:
;;     * cons-tree is an atom
;;     * cons-tree is just a single INJECT