1 |
|
(define-module (lang elisp transform) |
2 |
|
#:use-module (lang elisp internals trace) |
3 |
|
#:use-module (lang elisp internals fset) |
4 |
|
#:use-module (lang elisp internals evaluation) |
5 |
|
#:use-module (ice-9 session) |
6 |
|
#:export (transformer)) |
7 |
|
|
8 |
|
(define interactive-spec (make-fluid)) |
9 |
|
|
10 |
|
;;; {S-expressions} |
11 |
|
;;; |
12 |
|
|
13 |
|
(define (syntax-error x) |
14 |
|
(error "Syntax error in expression" x)) |
15 |
|
|
16 |
|
;; Should be made mutating instead of constructing |
17 |
|
;; |
18 |
|
(define (transformer x) |
19 |
|
(cond ((null? x) '()) |
20 |
|
((not (pair? x)) x) |
21 |
|
((and (pair? (car x)) |
22 |
|
(eq? (caar x) 'quasiquote)) |
23 |
|
(transformer (car x))) |
24 |
|
((symbol? (car x)) |
25 |
|
(case (car x) |
26 |
|
((@fop @bind define-module use-modules use-syntax) x) |
27 |
|
; Escape to Scheme syntax |
28 |
|
((scheme) (cons 'begin (cdr x))) |
29 |
|
; Should be handled in reader |
30 |
|
((quote function) (cons 'quote (cars->nil (cdr x)))) |
31 |
|
((quasiquote) (m-quasiquote x '())) |
32 |
|
((nil-cond) (transform-1 x)) |
33 |
|
((let) (m-let x '())) |
34 |
|
((let*) (m-let* x '())) |
35 |
|
((if) (m-if x '())) |
36 |
|
((and) (m-and x '())) |
37 |
|
((or) (m-or x '())) |
38 |
|
((while) (m-while x '())) |
39 |
|
;((while) (cons macro-while (cdr x))) |
40 |
|
((prog1) (m-prog1 x '())) |
41 |
|
((prog2) (m-prog2 x '())) |
42 |
|
((progn begin) (cons 'begin (map transformer (cdr x)))) |
43 |
|
((cond) (m-cond x '())) |
44 |
|
((lambda) (transform-lambda/interactive x '<elisp-lambda>)) |
45 |
|
((defun) (m-defun x '())) |
46 |
|
((defmacro) (m-defmacro x '())) |
47 |
|
((setq) (m-setq x '())) |
48 |
|
((defvar) (m-defvar x '())) |
49 |
|
((defconst) (m-defconst x '())) |
50 |
|
((interactive) (fluid-set! interactive-spec x) #f) |
51 |
|
((unwind-protect) (m-unwind-protect x '())) |
52 |
|
(else (transform-application x)))) |
53 |
|
(else (syntax-error x)))) |
54 |
|
|
55 |
|
(define (m-unwind-protect exp env) |
56 |
|
(trc 'unwind-protect (cadr exp)) |
57 |
|
`(let ((%--throw-args #f)) |
58 |
|
(catch #t |
59 |
|
(lambda () |
60 |
|
,(transformer (cadr exp))) |
61 |
|
(lambda args |
62 |
|
(set! %--throw-args args))) |
63 |
|
,@(transform-list (cddr exp)) |
64 |
|
(if %--throw-args |
65 |
|
(apply throw %--throw-args)))) |
66 |
|
|
67 |
|
(define (m-quasiquote exp env) |
68 |
|
(cons 'quasiquote |
69 |
|
(map transform-inside-qq (cdr exp)))) |
70 |
|
|
71 |
|
(define (transform-inside-qq x) |
72 |
|
(trc 'transform-inside-qq x) |
73 |
|
(cond ((not (pair? x)) x) |
74 |
|
((symbol? (car x)) |
75 |
|
(case (car x) |
76 |
|
((unquote) (list 'unquote (transformer (cadr x)))) |
77 |
|
((unquote-splicing) (list 'unquote-splicing (transformer (cadr x)))) |
78 |
|
(else (cons (car x) (map transform-inside-qq (cdr x)))))) |
79 |
|
(else |
80 |
|
(cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x)))))) |
81 |
|
|
82 |
|
(define (transform-1 x) |
83 |
|
(cons (car x) (map transformer (cdr x)))) |
84 |
|
|
85 |
|
(define (transform-2 x) |
86 |
|
(cons (car x) |
87 |
|
(cons (cadr x) |
88 |
|
(map transformer (cddr x))))) |
89 |
|
|
90 |
|
(define (transform-3 x) |
91 |
|
(cons (car x) |
92 |
|
(cons (cadr x) |
93 |
|
(cons (caddr x) |
94 |
|
(map transformer (cdddr x)))))) |
95 |
|
|
96 |
|
(define (transform-list x) |
97 |
|
(map transformer x)) |
98 |
|
|
99 |
|
;;; Parses a list of elisp formals, e.g. (x y &optional b &rest r) and |
100 |
|
;;; returns three values: (i) list of symbols for required arguments, |
101 |
|
;;; (ii) list of symbols for optional arguments, (iii) rest symbol, or |
102 |
|
;;; #f if there is no rest argument. |
103 |
|
(define (parse-formals formals) |
104 |
|
(letrec ((do-required |
105 |
|
(lambda (required formals) |
106 |
|
(if (null? formals) |
107 |
|
(values (reverse required) '() #f) |
108 |
|
(let ((next-sym (car formals))) |
109 |
|
(cond ((not (symbol? next-sym)) |
110 |
|
(error "Bad formals (non-symbol in required list)")) |
111 |
|
((eq? next-sym '&optional) |
112 |
|
(do-optional required '() (cdr formals))) |
113 |
|
((eq? next-sym '&rest) |
114 |
|
(do-rest required '() (cdr formals))) |
115 |
|
(else |
116 |
|
(do-required (cons next-sym required) |
117 |
|
(cdr formals)))))))) |
118 |
|
(do-optional |
119 |
|
(lambda (required optional formals) |
120 |
|
(if (null? formals) |
121 |
|
(values (reverse required) (reverse optional) #f) |
122 |
|
(let ((next-sym (car formals))) |
123 |
|
(cond ((not (symbol? next-sym)) |
124 |
|
(error "Bad formals (non-symbol in optional list)")) |
125 |
|
((eq? next-sym '&rest) |
126 |
|
(do-rest required optional (cdr formals))) |
127 |
|
(else |
128 |
|
(do-optional required |
129 |
|
(cons next-sym optional) |
130 |
|
(cdr formals)))))))) |
131 |
|
(do-rest |
132 |
|
(lambda (required optional formals) |
133 |
|
(if (= (length formals) 1) |
134 |
|
(let ((next-sym (car formals))) |
135 |
|
(if (symbol? next-sym) |
136 |
|
(values (reverse required) (reverse optional) next-sym) |
137 |
|
(error "Bad formals (non-symbol rest formal)"))) |
138 |
|
(error "Bad formals (more than one rest formal)"))))) |
139 |
|
|
140 |
|
(do-required '() (cond ((list? formals) |
141 |
|
formals) |
142 |
|
((symbol? formals) |
143 |
|
(list '&rest formals)) |
144 |
|
(else |
145 |
|
(error "Bad formals (not a list or a single symbol)")))))) |
146 |
|
|
147 |
|
(define (transform-lambda/interactive exp name) |
148 |
|
(fluid-set! interactive-spec #f) |
149 |
|
(let* ((x (transform-lambda exp)) |
150 |
|
(is (fluid-ref interactive-spec))) |
151 |
|
`(let ((%--lambda ,x)) |
152 |
|
(set-procedure-property! %--lambda 'name ',name) |
153 |
|
(set! (,not-subr? %--lambda) #t) |
154 |
|
,@(if is |
155 |
|
`((set! (,interactive-specification %--lambda) ',is)) |
156 |
|
'()) |
157 |
|
%--lambda))) |
158 |
|
|
159 |
|
(define (transform-lambda exp) |
160 |
|
(call-with-values (lambda () (parse-formals (cadr exp))) |
161 |
|
(lambda (required optional rest) |
162 |
|
(let ((num-required (length required)) |
163 |
|
(num-optional (length optional))) |
164 |
|
`(lambda %--args |
165 |
|
(let ((%--num-args (length %--args))) |
166 |
|
(cond ((< %--num-args ,num-required) |
167 |
|
(error "Wrong number of args (not enough required args)")) |
168 |
|
,@(if rest |
169 |
|
'() |
170 |
|
`(((> %--num-args ,(+ num-required num-optional)) |
171 |
|
(error "Wrong number of args (too many args)")))) |
172 |
|
(else |
173 |
|
(@bind ,(append (map (lambda (i) |
174 |
|
(list (list-ref required i) |
175 |
|
`(list-ref %--args ,i))) |
176 |
|
(iota num-required)) |
177 |
|
(map (lambda (i) |
178 |
|
(let ((i+nr (+ i num-required))) |
179 |
|
(list (list-ref optional i) |
180 |
|
`(if (> %--num-args ,i+nr) |
181 |
|
(list-ref %--args ,i+nr) |
182 |
|
#f)))) |
183 |
|
(iota num-optional)) |
184 |
|
(if rest |
185 |
|
(list (list rest |
186 |
|
`(if (> %--num-args |
187 |
|
,(+ num-required |
188 |
|
num-optional)) |
189 |
|
(list-tail %--args |
190 |
|
,(+ num-required |
191 |
|
num-optional)) |
192 |
|
'()))) |
193 |
|
'())) |
194 |
|
,@(transform-list (cddr exp))))))) |
195 |
|
)))) |
196 |
|
|
197 |
|
(define (m-defun exp env) |
198 |
|
(trc 'defun (cadr exp)) |
199 |
|
`(begin (,fset ',(cadr exp) |
200 |
|
,(transform-lambda/interactive (cdr exp) |
201 |
|
(symbol-append '<elisp-defun: |
202 |
|
(cadr exp) |
203 |
|
'>))) |
204 |
|
',(cadr exp))) |
205 |
|
|
206 |
|
(define (m-defmacro exp env) |
207 |
|
(trc 'defmacro (cadr exp)) |
208 |
|
(call-with-values (lambda () (parse-formals (caddr exp))) |
209 |
|
(lambda (required optional rest) |
210 |
|
(let ((num-required (length required)) |
211 |
|
(num-optional (length optional))) |
212 |
|
`(begin (,fset ',(cadr exp) |
213 |
|
(procedure->memoizing-macro |
214 |
|
(lambda (exp1 env1) |
215 |
|
(,trc 'using ',(cadr exp)) |
216 |
|
(let* ((%--args (cdr exp1)) |
217 |
|
(%--num-args (length %--args))) |
218 |
|
(cond ((< %--num-args ,num-required) |
219 |
|
(error "Wrong number of args (not enough required args)")) |
220 |
|
,@(if rest |
221 |
|
'() |
222 |
|
`(((> %--num-args ,(+ num-required num-optional)) |
223 |
|
(error "Wrong number of args (too many args)")))) |
224 |
|
(else (,transformer |
225 |
|
(@bind ,(append (map (lambda (i) |
226 |
|
(list (list-ref required i) |
227 |
|
`(list-ref %--args ,i))) |
228 |
|
(iota num-required)) |
229 |
|
(map (lambda (i) |
230 |
|
(let ((i+nr (+ i num-required))) |
231 |
|
(list (list-ref optional i) |
232 |
|
`(if (> %--num-args ,i+nr) |
233 |
|
(list-ref %--args ,i+nr) |
234 |
|
#f)))) |
235 |
|
(iota num-optional)) |
236 |
|
(if rest |
237 |
|
(list (list rest |
238 |
|
`(if (> %--num-args |
239 |
|
,(+ num-required |
240 |
|
num-optional)) |
241 |
|
(list-tail %--args |
242 |
|
,(+ num-required |
243 |
|
num-optional)) |
244 |
|
'()))) |
245 |
|
'())) |
246 |
|
,@(transform-list (cdddr exp))))))))))))))) |
247 |
|
|
248 |
|
(define (transform-application x) |
249 |
|
`(@fop ,(car x) |
250 |
|
(,transformer-macro ,@(cdr x)))) |
251 |
|
|
252 |
|
(define transformer-macro |
253 |
|
(procedure->memoizing-macro |
254 |
|
(lambda (exp env) |
255 |
|
(cons 'list (map transformer (cdr exp)))))) |
256 |
|
|
257 |
|
; (cons '@fop |
258 |
|
; (cons (car x) |
259 |
|
; (map transformer (cdr x))))) |
260 |
|
|
261 |
|
(define (cars->nil ls) |
262 |
|
(cond ((not (pair? ls)) ls) |
263 |
|
((null? (car ls)) (cons '() (cars->nil (cdr ls)))) |
264 |
|
(else (cons (cars->nil (car ls)) |
265 |
|
(cars->nil (cdr ls)))))) |
266 |
|
|
267 |
|
;;; {Special forms} |
268 |
|
;;; |
269 |
|
|
270 |
|
(define (m-setq exp env) |
271 |
|
(cons 'begin |
272 |
|
(let loop ((sets (cdr exp)) (last-sym #f)) |
273 |
|
(if (null? sets) |
274 |
|
(list last-sym) |
275 |
|
(cons `(module-define! ,the-elisp-module |
276 |
|
',(car sets) |
277 |
|
,(transformer (cadr sets))) |
278 |
|
(loop (cddr sets) (car sets))))))) |
279 |
|
|
280 |
|
;(define (m-setq exp env) |
281 |
|
; (let* ((binder (car (last-pair env))) |
282 |
|
; (varvals (let loop ((ls (cdr exp))) |
283 |
|
; (if (null? ls) |
284 |
|
; '() |
285 |
|
; ;; Ensure existence only at macro expansion time |
286 |
|
; (let ((var (or (binder (car ls) #f) |
287 |
|
; (binder (car ls) #t)))) |
288 |
|
; (if (not (variable-bound? var)) |
289 |
|
; (variable-set! var #f)) |
290 |
|
; (cons (list 'set! (car ls) (transformer (cadr ls))) |
291 |
|
; (loop (cddr ls)))))))) |
292 |
|
; (cond ((null? varvals) '()) |
293 |
|
; ((null? (cdr varvals)) (car varvals)) |
294 |
|
; (else (cons 'begin varvals))))) |
295 |
|
|
296 |
|
(define (m-let exp env) |
297 |
|
`(@bind ,(map (lambda (binding) |
298 |
|
(trc 'let binding) |
299 |
|
(if (pair? binding) |
300 |
|
`(,(car binding) ,(transformer (cadr binding))) |
301 |
|
`(,binding #f))) |
302 |
|
(cadr exp)) |
303 |
|
,@(transform-list (cddr exp)))) |
304 |
|
|
305 |
|
(define (m-let* exp env) |
306 |
|
(if (null? (cadr exp)) |
307 |
|
`(begin ,@(transform-list (cddr exp))) |
308 |
|
(car (let loop ((bindings (cadr exp))) |
309 |
|
(if (null? bindings) |
310 |
|
(transform-list (cddr exp)) |
311 |
|
`((@bind (,(let ((binding (car bindings))) |
312 |
|
(if (pair? binding) |
313 |
|
`(,(car binding) ,(transformer (cadr binding))) |
314 |
|
`(,binding #f)))) |
315 |
|
,@(loop (cdr bindings))))))))) |
316 |
|
|
317 |
|
(define (m-prog1 exp env) |
318 |
|
`(,let ((%res1 ,(transformer (cadr exp)))) |
319 |
|
,@(transform-list (cddr exp)) |
320 |
|
%res1)) |
321 |
|
|
322 |
|
(define (m-prog2 exp env) |
323 |
|
`(begin ,(transformer (cadr exp)) |
324 |
|
(,let ((%res2 ,(transformer (caddr exp)))) |
325 |
|
,@(transform-list (cdddr exp)) |
326 |
|
%res2))) |
327 |
|
|
328 |
|
(define <-- *unspecified*) |
329 |
|
|
330 |
|
(define (m-if exp env) |
331 |
|
(let ((else-case (cdddr exp))) |
332 |
|
(cond ((null? else-case) |
333 |
|
`(nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) #f)) |
334 |
|
((null? (cdr else-case)) |
335 |
|
`(nil-cond ,(transformer (cadr exp)) |
336 |
|
,(transformer (caddr exp)) |
337 |
|
,(transformer (car else-case)))) |
338 |
|
(else |
339 |
|
`(nil-cond ,(transformer (cadr exp)) |
340 |
|
,(transformer (caddr exp)) |
341 |
|
(begin ,@(transform-list else-case))))))) |
342 |
|
|
343 |
|
(define (m-and exp env) |
344 |
|
(cond ((null? (cdr exp)) #t) |
345 |
|
((null? (cddr exp)) (transformer (cadr exp))) |
346 |
|
(else |
347 |
|
(cons 'nil-cond |
348 |
|
(let loop ((args (cdr exp))) |
349 |
|
(if (null? (cdr args)) |
350 |
|
(list (transformer (car args))) |
351 |
|
(cons (list 'not (transformer (car args))) |
352 |
|
(cons #f |
353 |
|
(loop (cdr args)))))))))) |
354 |
|
|
355 |
|
(define (m-or exp env) |
356 |
|
(cond ((null? (cdr exp)) #f) |
357 |
|
((null? (cddr exp)) (transformer (cadr exp))) |
358 |
|
(else |
359 |
|
(cons 'nil-cond |
360 |
|
(let loop ((args (cdr exp))) |
361 |
|
(if (null? (cdr args)) |
362 |
|
(list (transformer (car args))) |
363 |
|
(cons (transformer (car args)) |
364 |
|
(cons <-- |
365 |
|
(loop (cdr args)))))))))) |
366 |
|
|
367 |
|
(define m-cond |
368 |
|
(lambda (exp env) |
369 |
|
(if (null? (cdr exp)) |
370 |
|
#f |
371 |
|
(cons |
372 |
|
'nil-cond |
373 |
|
(let loop ((clauses (cdr exp))) |
374 |
|
(if (null? clauses) |
375 |
|
'(#f) |
376 |
|
(let ((clause (car clauses))) |
377 |
|
(if (eq? (car clause) #t) |
378 |
|
(cond ((null? (cdr clause)) '(t)) |
379 |
|
((null? (cddr clause)) |
380 |
|
(list (transformer (cadr clause)))) |
381 |
|
(else `((begin ,@(transform-list (cdr clause)))))) |
382 |
|
(cons (transformer (car clause)) |
383 |
|
(cons (cond ((null? (cdr clause)) <--) |
384 |
|
((null? (cddr clause)) |
385 |
|
(transformer (cadr clause))) |
386 |
|
(else |
387 |
|
`(begin ,@(transform-list (cdr clause))))) |
388 |
|
(loop (cdr clauses)))))))))))) |
389 |
|
|
390 |
|
(define (m-while exp env) |
391 |
|
`(,let %while () |
392 |
|
(nil-cond ,(transformer (cadr exp)) |
393 |
|
(begin ,@(transform-list (cddr exp)) (%while)) |
394 |
|
#f))) |
395 |
|
|
396 |
|
(define (m-defvar exp env) |
397 |
|
(trc 'defvar (cadr exp)) |
398 |
|
(if (null? (cddr exp)) |
399 |
|
`',(cadr exp) |
400 |
|
`(begin (if (not (defined? ',(cadr exp))) |
401 |
|
(,macro-setq ,(cadr exp) ,(caddr exp))) |
402 |
|
',(cadr exp)))) |
403 |
|
|
404 |
|
(define (m-defconst exp env) |
405 |
|
(trc 'defconst (cadr exp)) |
406 |
|
`(begin ,(m-setq (list (car exp) (cadr exp) (caddr exp)) env) |
407 |
|
',(cadr exp))) |
408 |
|
|
409 |
|
;(export-mmacros |
410 |
|
; '(setq defun let let* if and or cond while prog1 prog2 progn) |
411 |
|
; (list m-setq m-defun m-let m-let* m-if m-and m-or m-cond m-while m-prog1 m-prog2 begin)) |
412 |
|
|
413 |
|
(define macro-setq (procedure->memoizing-macro m-setq)) |
414 |
|
(define macro-while (procedure->memoizing-macro m-while)) |