/[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.5 by ossau, Mon Feb 4 21:13:46 2002 UTC revision 1.6 by ossau, Fri Feb 8 11:50:51 2002 UTC
# Line 5  Line 5 
5    #:use-module (ice-9 session)    #:use-module (ice-9 session)
6    #:export (transformer transform))    #:export (transformer transform))
7    
8  ;;; {S-expressions}  ;;; A note on the difference between `(transform-* (cdr x))' and `(map
9    ;;; transform-* (cdr x))'.
10  ;;;  ;;;
11    ;;; In most cases, none, as most of the transform-* functions are
12    ;;; recursive.
13    ;;;
14    ;;; However, if (cdr x) is not a proper list, the `map' version will
15    ;;; signal an error immediately, whereas the non-`map' version will
16    ;;; produce a similarly improper list as its transformed output.  In
17    ;;; some cases, improper lists are allowed, so at least these cases
18    ;;; require non-`map'.
19    ;;;
20    ;;; Therefore we use the non-`map' approach in most cases below, but
21    ;;; `map' in transform-application, since in the application case we
22    ;;; know that `(func arg . args)' is an error.  It would probably be
23    ;;; better for the transform-application case to check for an improper
24    ;;; list explicitly and signal a more explicit error.
25    
26  (define (syntax-error x)  (define (syntax-error x)
27    (error "Syntax error in expression" x))    (error "Syntax error in expression" x))
28    
29  ;; Should be made mutating instead of constructing  (define-macro (scheme exp . module)
30  ;;    (let ((m (resolve-module (if (null? module)
31                                   '(guile-user)
32                                   (car module)))))
33        (let ((x `(,eval (,quote ,exp) ,m)))
34          (write x)
35          (newline)
36          x)))
37    
38  (define (transformer x)  (define (transformer x)
39      (cond ((pair? x)
40             (cond ((symbol? (car x))
41                    (case (car x)
42                      ;; Allow module-related forms through intact.
43                      ((define-module use-modules use-syntax)
44                       x)
45                      ;; Escape to Scheme.
46                      ((scheme)
47                       (cons-source x scheme (cdr x)))
48                      ;; Quoting.
49                      ((quote function)
50                       (cons-source x quote (transform-quote (cdr x))))
51                      ((quasiquote)
52                       (cons-source x quasiquote (transform-quasiquote (cdr x))))
53                      ;; Anything else is a function or macro application.
54                      (else (transform-application x))))
55                   ((and (pair? (car x))
56                         (eq? (caar x) 'quasiquote))
57                    (transformer (car x)))
58                   (else (syntax-error x))))
59            (else
60             (transform-datum x))))
61    
62    (define (transform-datum x)
63    (cond ((eq? x 'nil) %nil)    (cond ((eq? x 'nil) %nil)
64          ((eq? x 't) #t)          ((eq? x 't) #t)
65          ((null? x) %nil)          ;; Could add other translations here, notably `?A' -> 65 etc.
66          ((not (pair? x)) x)          (else x)))
67          ((and (pair? (car x))  
68                (eq? (caar x) 'quasiquote))  (define (transform-quote x)
69           (transformer (car x)))    (trc 'transform-quote x)
70          ((symbol? (car x))    (cond ((not (pair? x))
71           (case (car x)           (transform-datum x))
72             ((@fop @bind define-module use-modules use-syntax) x)          (else
73             ; Escape to Scheme syntax           (cons-source x
74             ((scheme) (cons begin (cdr x)))                        (transform-quote (car x))
75             ; Should be handled in reader                        (transform-quote (cdr x))))))
76             ((quote function) `(,quote ,@(cars->nil (cdr x))))  
77             ((quasiquote) (m-quasiquote x '()))  (define (transform-quasiquote x)
78             ;((nil-cond) (transform-1 x))    (trc 'transform-quasiquote x)
79             ;((let) (m-let x '()))    (cond ((not (pair? x))
80             ;((let*) (m-let* x '()))           (transform-datum x))
            ;((if) (m-if x '()))  
            ;((and) (m-and x '()))  
            ;((or) (m-or x '()))  
            ;((while) (m-while x '()))  
            ;((while) (cons macro-while (cdr x)))  
            ;((prog1) (m-prog1 x '()))  
            ;((prog2) (m-prog2 x '()))  
            ;((progn) (cons 'begin (map transformer (cdr x))))  
            ;((cond) (m-cond x '()))  
            ;((lambda) (transform-lambda/interactive x '<elisp-lambda>))  
            ;((defun) (m-defun x '()))  
            ;((defmacro) (m-defmacro x '()))  
            ;((setq) (m-setq x '()))  
            ;((interactive) (fluid-set! interactive-spec x) #f)  
            ;((unwind-protect) (m-unwind-protect x '()))  
            (else (transform-application x))))  
         (else (syntax-error x))))  
   
 (define (m-quasiquote exp env)  
   (cons quasiquote  
         (map transform-inside-qq (cdr exp))))  
   
 (define (transform-inside-qq x)  
   (trc 'transform-inside-qq x)  
   (cond ((not (pair? x)) x)  
81          ((symbol? (car x))          ((symbol? (car x))
82           (case (car x)           (case (car x)
83             ((unquote) (list 'unquote (transformer (cadr x))))             ((unquote) (list 'unquote (transformer (cadr x))))
84             ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))             ((unquote-splicing) (list 'unquote-splicing (transformer (cadr x))))
85             (else (cons (car x) (map transform-inside-qq (cdr x))))))             (else (cons-source x
86                                  (transform-datum (car x))
87                                  (transform-quasiquote (cdr x))))))
88          (else          (else
89           (cons (transform-inside-qq (car x)) (transform-inside-qq (cdr x))))))           (cons-source x
90                          (transform-quasiquote (car x))
91                          (transform-quasiquote (cdr x))))))
92    
93  (define (transform-application x)  (define (transform-application x)
94    (cons-source x    (cons-source x @fop `(,(car x) (,transformer-macro ,@(map transform-quote (cdr x))))))
                '@fop  
                `(,(car x) (,transformer-macro ,@(cdr x)))))  
95    
96  (define transformer-macro  (define transformer-macro
97    (procedure->memoizing-macro    (procedure->memoizing-macro
98     (let ((cdr cdr))     (let ((cdr cdr))
99       (lambda (exp env)       (lambda (exp env)
100         (cons 'list (map transformer (cdr exp)))))))         (cons-source exp list (map transformer (cdr exp)))))))
   
 (define (cars->nil ls)  
   (cond ((not (pair? ls)) ls)  
         ((null? (car ls)) (cons '() (cars->nil (cdr ls))))  
         (else (cons (cars->nil (car ls))  
                     (cars->nil (cdr ls))))))  
101    
102  (define transform transformer)  (define transform transformer)

Legend:
Removed from v.1.5  
changed lines
  Added in v.1.6

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