/[guile]/guile/guile-core/lang/elisp/transform.scm
ViewVC logotype

Diff of /guile/guile-core/lang/elisp/transform.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by ossau, Fri Oct 19 14:43:38 2001 UTC revision 1.2 by ossau, Tue Jan 22 23:46:01 2002 UTC
# Line 0  Line 1 
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))

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26