1 (define-module (lang elisp primitives syntax)
2 #:use-module (lang elisp internals evaluation)
3 #:use-module (lang elisp internals fset)
4 #:use-module (lang elisp internals lambda)
5 #:use-module (lang elisp internals set)
6 #:use-module (lang elisp internals trace)
7 #:use-module (lang elisp transform))
9 ;;; Define Emacs Lisp special forms as macros. This is more flexible
10 ;;; than handling them specially in the translator: allows them to be
11 ;;; redefined, and hopefully allows better source location tracking.
15 (define (setq exp env)
17 (let loop ((sets (cdr exp)))
20 (cons `(,set (,quote ,(car sets)) ,(transformer (cadr sets)))
21 (loop (cddr sets)))))))
24 (procedure->memoizing-macro setq))
27 (procedure->memoizing-macro
29 (trc 'defvar (cadr exp))
30 (if (null? (cddr exp))
32 `(,begin (,if (,not (,defined? (,quote ,(cadr exp))))
33 ,(setq (list (car exp) (cadr exp) (caddr exp)) env))
34 (,quote ,(cadr exp)))))))
37 (procedure->memoizing-macro
39 (trc 'defconst (cadr exp))
40 `(,begin ,(setq (list (car exp) (cadr exp) (caddr exp)) env)
41 (,quote ,(cadr exp))))))
43 ;;; {lambda, function and macro definitions}
46 (procedure->memoizing-macro
48 (transform-lambda/interactive exp '<elisp-lambda>))))
51 (procedure->memoizing-macro
53 (trc 'defun (cadr exp))
54 `(,begin (,fset (,quote ,(cadr exp))
55 ,(transform-lambda/interactive (cdr exp)
56 (symbol-append '<elisp-defun:
59 (,quote ,(cadr exp))))))
62 (procedure->memoizing-macro
64 (fluid-set! interactive-spec exp)
68 (procedure->memoizing-macro
70 (trc 'defmacro (cadr exp))
71 (call-with-values (lambda () (parse-formals (caddr exp)))
72 (lambda (required optional rest)
73 (let ((num-required (length required))
74 (num-optional (length optional)))
75 `(,begin (,fset (,quote ,(cadr exp))
76 (,procedure->memoizing-macro
78 (,trc (,quote using) (,quote ,(cadr exp)))
79 (,let* ((%--args (,cdr exp1))
80 (%--num-args (,length %--args)))
81 (,cond ((,< %--num-args ,num-required)
82 (,error "Wrong number of args (not enough required args)"))
85 `(((,> %--num-args ,(+ num-required num-optional))
86 (,error "Wrong number of args (too many args)"))))
88 (, @bind ,(append (map (lambda (i)
89 (list (list-ref required i)
90 `(,list-ref %--args ,i)))
93 (let ((i+nr (+ i num-required)))
94 (list (list-ref optional i)
95 `(,if (,> %--num-args ,i+nr)
96 (,list-ref %--args ,i+nr)
101 `(,if (,> %--num-args
109 ,@(map transformer (cdddr exp)))))))))))))))))
114 (procedure->memoizing-macro
116 `(,begin ,@(map transformer (cdr exp))))))
119 (procedure->memoizing-macro
121 `(,let ((%--res1 ,(transformer (cadr exp))))
122 ,@(map transformer (cddr exp))
126 (procedure->memoizing-macro
128 `(,begin ,(transformer (cadr exp))
129 (,let ((%--res2 ,(transformer (caddr exp))))
130 ,@(map transformer (cdddr exp))
136 (procedure->memoizing-macro
138 (let ((else-case (cdddr exp)))
139 (cond ((null? else-case)
140 `(,nil-cond ,(transformer (cadr exp)) ,(transformer (caddr exp)) ,%nil))
141 ((null? (cdr else-case))
142 `(,nil-cond ,(transformer (cadr exp))
143 ,(transformer (caddr exp))
144 ,(transformer (car else-case))))
146 `(,nil-cond ,(transformer (cadr exp))
147 ,(transformer (caddr exp))
148 (,begin ,@(map transformer else-case)))))))))
151 (procedure->memoizing-macro
153 (cond ((null? (cdr exp)) #t)
154 ((null? (cddr exp)) (transformer (cadr exp)))
157 (let loop ((args (cdr exp)))
158 (if (null? (cdr args))
159 (list (transformer (car args)))
160 (cons (list not (transformer (car args)))
162 (loop (cdr args))))))))))))
164 ;;; NIL-COND expressions have the form:
166 ;;; (nil-cond COND VAL COND VAL ... ELSEVAL)
168 ;;; The CONDs are evaluated in order until one of them returns true
169 ;;; (in the Elisp sense, so not including empty lists). If a COND
170 ;;; returns true, its corresponding VAL is evaluated and returned,
171 ;;; except if that VAL is the unspecified value, in which case the
172 ;;; result of evaluating the COND is returned. If none of the COND's
173 ;;; returns true, ELSEVAL is evaluated and its value returned.
175 (define <-- *unspecified*)
178 (procedure->memoizing-macro
180 (cond ((null? (cdr exp)) %nil)
181 ((null? (cddr exp)) (transformer (cadr exp)))
184 (let loop ((args (cdr exp)))
185 (if (null? (cdr args))
186 (list (transformer (car args)))
187 (cons (transformer (car args))
189 (loop (cdr args))))))))))))
192 (procedure->memoizing-macro
194 (if (null? (cdr exp))
198 (let loop ((clauses (cdr exp)))
201 (let ((clause (car clauses)))
202 (if (eq? (car clause) #t)
203 (cond ((null? (cdr clause)) (list #t))
204 ((null? (cddr clause))
205 (list (transformer (cadr clause))))
206 (else `((,begin ,@(map transformer (cdr clause))))))
207 (cons (transformer (car clause))
208 (cons (cond ((null? (cdr clause)) <--)
209 ((null? (cddr clause))
210 (transformer (cadr clause)))
212 `(,begin ,@(map transformer (cdr clause)))))
213 (loop (cdr clauses)))))))))))))
216 (procedure->memoizing-macro
218 `((,letrec ((%--while (,lambda ()
219 (,nil-cond ,(transformer (cadr exp))
220 (,begin ,@(map transformer (cddr exp))
228 (procedure->memoizing-macro
230 `(, @bind ,(map (lambda (binding)
233 `(,(car binding) ,(transformer (cadr binding)))
236 ,@(map transformer (cddr exp))))))
239 (procedure->memoizing-macro
241 (if (null? (cadr exp))
242 `(,begin ,@(map transformer (cddr exp)))
243 (car (let loop ((bindings (cadr exp)))
245 (map transformer (cddr exp))
246 `((, @bind (,(let ((binding (car bindings)))
248 `(,(car binding) ,(transformer (cadr binding)))
250 ,@(loop (cdr bindings)))))))))))
252 ;;; {Exception handling}
254 (fset 'unwind-protect
255 (procedure->memoizing-macro
257 (trc 'unwind-protect (cadr exp))
258 `(,let ((%--throw-args #f))
261 ,(transformer (cadr exp)))
263 (,set! %--throw-args args)))
264 ,@(map transformer (cddr exp))
266 (,apply ,throw %--throw-args))))))