1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
|
; Copyright (c) 1993-1999 by Richard Kelsey and Jonathan Rees. See file COPYING.
; schemify
; This is only used for producing error and warning messages.
; Flush nodes and generated names in favor of something a little more
; readable. Eventually, (schemify node env) ought to produce an
; s-expression that has the same semantics as node, when node is fully
; expanded.
(define (schemify node . maybe-env)
(if (node? node)
(schemify-node node
(if (null? maybe-env)
#f
(car maybe-env)))
(schemify-sexp node)))
(define schemifiers
(make-operator-table (lambda (node env)
(let ((form (node-form node)))
(if (list? form)
(let ((op (car form)))
(cons (cond ((operator? op)
(operator-name op))
((node? op)
(schemify-node op env))
(else
(schemify-sexp op)))
(schemify-nodes (cdr form) env)))
form)))))
; We cache the no-env version because that's the one used to generate the
; sources in the debugging info (which takes up a lot of space).
(define (schemify-node node env)
(or (and (not env)
(node-ref node 'schemify))
(let ((form ((operator-table-ref schemifiers (node-operator-id node))
node
env)))
(if (not env)
(node-set! node 'schemify form))
form)))
(define (schemify-nodes nodes env)
(map (lambda (node)
(schemify-node node env))
nodes))
(define (define-schemifier name type proc)
(operator-define! schemifiers name type proc))
(define-schemifier 'name 'leaf
(lambda (node env)
(if env
(name->qualified (node-form node)
env)
(desyntaxify (node-form node)))))
(define-schemifier 'quote syntax-type
(lambda (node env)
(let ((form (node-form node)))
`(quote ,(cadr form)))))
(define-schemifier 'call 'internal
(lambda (node env)
(map (lambda (node)
(schemify-node node env))
(node-form node))))
; We ignore the list of free variables in flat lambdas.
(define (schemify-lambda node env)
(let ((form (node-form node)))
`(lambda ,(schemify-formals (cadr form) env)
,(schemify-node (last form) env))))
(define-schemifier 'lambda syntax-type schemify-lambda)
(define-schemifier 'flat-lambda syntax-type schemify-lambda)
(define (schemify-formals formals env)
(cond ((node? formals)
(schemify-node formals env))
((pair? formals)
(cons (schemify-node (car formals) env)
(schemify-formals (cdr formals) env)))
(else
(schemify-sexp formals)))) ; anything besides '() ?
; let-syntax, letrec-syntax...
(define-schemifier 'letrec syntax-type
(lambda (node env)
(let ((form (node-form node)))
`(letrec ,(map (lambda (spec)
(schemify-nodes spec env))
(cadr form))
,@(map (lambda (f) (schemify-node f env))
(cddr form))))))
(define-schemifier 'loophole syntax-type
(lambda (node env)
(let ((form (node-form node)))
(list 'loophole
(type->sexp (cadr form) #t)
(schemify-node (caddr form) env)))))
(define-schemifier 'lap syntax-type
(lambda (node env)
(let ((form (node-form node)))
`(lap
,(cadr form)
,(schemify-nodes (caddr form) env)
. ,(cdddr form)))))
;----------------
(define (schemify-sexp thing)
(cond ((name? thing)
(desyntaxify thing))
((pair? thing)
(let ((x (schemify-sexp (car thing)))
(y (schemify-sexp (cdr thing))))
(if (and (eq? x (car thing))
(eq? y (cdr thing)))
thing ;+++
(cons x y))))
((vector? thing)
(let ((new (make-vector (vector-length thing) #f)))
(let loop ((i 0) (same? #t))
(if (>= i (vector-length thing))
(if same? thing new) ;+++
(let ((x (schemify-sexp (vector-ref thing i))))
(vector-set! new i x)
(loop (+ i 1)
(and same? (eq? x (vector-ref thing i)))))))))
(else thing)))
|
