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) |