1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
4
5; schemify
6
7; This is only used for producing error and warning messages.
8
9; Flush nodes and generated names in favor of something a little more
10; readable.  Eventually, (schemify node env) ought to produce an
11; s-expression that has the same semantics as node, when node is fully
12; expanded.
13
14(define (schemify node . maybe-env)
15  (if (node? node)
16      (schemify-node node
17		     (if (null? maybe-env)
18			 #f
19			 (car maybe-env)))
20      (schemify-sexp node)))
21
22
23(define schemifiers
24  (make-operator-table (lambda (node env)
25			 (let ((form (node-form node)))
26			   (if (list? form)
27			       (let ((op (car form)))
28				 (cons (cond ((operator? op)
29					      (operator-name op))
30					     ((node? op)
31					      (schemify-node op env))
32					     (else
33					      (schemify-sexp op)))
34				       (schemify-nodes (cdr form) env)))
35			       form)))))
36
37; We cache the no-env version because that's the one used to generate the
38; sources in the debugging info (which takes up a lot of space).
39
40(define (schemify-node node env)
41  (or (and (not env)
42	   (node-ref node 'schemify))
43      (let ((form ((operator-table-ref schemifiers (node-operator-id node))
44		     node
45		     env)))
46	(if (not env)
47	    (node-set! node 'schemify form))
48	form)))
49
50(define (schemify-nodes nodes env)
51  (map (lambda (node)
52	 (schemify-node node env))
53       nodes))
54
55(define (define-schemifier name type proc)
56  (operator-define! schemifiers name type proc))
57
58(define-schemifier 'name 'leaf
59  (lambda (node env)
60    (if env
61	(name->qualified (node-form node)
62			 env)
63	(let ((form (node-form node)))
64          (if (or #f (node? form))
65              (schemify-node form env)
66              (desyntaxify form))))))
67
68; Convert an alias (generated name) to S-expression form ("qualified name").
69
70(define (name->qualified name env)
71  (cond ((not (generated? name))
72	 name)
73	((let ((d0 (lookup env name))
74	       (d1 (lookup env (generated-name name))))
75	   (and d0 d1 (same-denotation? d0 d1)))
76	 (generated-name name))   ;+++
77	(else
78	 (make-qualified (qualify-parent (generated-parent-name name)
79					 env)
80			 (generated-name name)
81			 (generated-uid name)))))
82
83; As an optimization, we elide intermediate steps in the lookup path
84; when possible.  E.g.
85;     #(>> #(>> #(>> define-record-type define-accessors)
86;              define-accessor)
87;         record-ref)
88; is replaced with
89;     #(>> define-record-type record-ref)
90
91(define (qualify-parent name env)
92  (let recur ((name name) (env env))
93    (if (generated? name)
94	(let ((parent (generated-parent-name name)))
95	  (if (and (environment-stable? env)
96		   (let ((b1 (generic-lookup env name))
97			 (b2 (generic-lookup env parent)))
98		     (and b1
99			  b2
100			  (or (same-denotation? b1 b2)
101			      (and (binding? b1)
102				   (binding? b2)
103				   (let ((s1 (binding-static b1))
104					 (s2 (binding-static b2)))
105				     (and (transform? s1)
106					  (transform? s2)
107					  (eq? (transform-env s1)
108					       (transform-env s2)))))))))
109	      (recur parent env)	;+++
110	      (make-qualified (recur parent (generated-env name))
111			      (generated-name name)
112			      (generated-uid name))))
113	name)))
114
115(define-schemifier 'quote syntax-type
116  (lambda (node env)
117    (let ((form (node-form node)))
118      `(quote ,(cadr form)))))
119
120(define-schemifier 'call 'internal
121  (lambda (node env)
122    (map (lambda (node)
123	   (schemify-node node env))
124	 (node-form node))))
125
126; We ignore the list of free variables in flat lambdas.
127
128(define (schemify-lambda node env)
129  (let ((form (node-form node)))
130    `(lambda ,(schemify-formals (cadr form) env)
131       ,(schemify-node (last form) env))))
132
133(define-schemifier 'lambda syntax-type schemify-lambda)
134(define-schemifier 'flat-lambda syntax-type schemify-lambda)
135
136(define (schemify-formals formals env)
137  (cond ((node? formals)
138	 (schemify-node formals env))
139	((pair? formals)
140	 (cons (schemify-node (car formals) env)
141	       (schemify-formals (cdr formals) env)))
142	(else
143	 (schemify-sexp formals))))  ; anything besides '() ?
144
145; let-syntax, letrec-syntax...
146
147(define-schemifier 'letrec syntax-type
148  (lambda (node env)
149    (let ((form (node-form node)))
150      (schemify-letrec 'letrec (cadr form) (caddr form) env))))
151
152(define-schemifier 'letrec* syntax-type
153  (lambda (node env)
154    (let ((form (node-form node)))
155      (schemify-letrec 'letrec* (cadr form) (caddr form) env))))
156
157(define-schemifier 'pure-letrec syntax-type
158  (lambda (node env)
159    (let ((form (node-form node)))
160      (schemify-letrec 'letrec (cadr form) (cadddr form) env))))
161
162(define (schemify-letrec op specs body env)
163  `(,op ,(map (lambda (spec)
164		   (schemify-nodes spec env))
165		 specs)
166     ,(schemify-node body env)))
167
168(define-schemifier 'loophole syntax-type
169  (lambda (node env)
170    (let ((form (node-form node)))
171      (list 'loophole
172	    (type->sexp (cadr form) #t)
173	    (schemify-node (caddr form) env)))))
174
175(define-schemifier 'lap syntax-type
176  (lambda (node env)
177    (let ((form (node-form node)))
178      `(lap
179	,(cadr form)
180	,(schemify-nodes (caddr form) env)
181	. ,(cdddr form)))))
182
183;----------------
184
185(define (schemify-sexp thing)
186  (cond ((name? thing)
187	 (desyntaxify thing))
188	((pair? thing)
189	 (let ((x (schemify-sexp (car thing)))
190	       (y (schemify-sexp (cdr thing))))
191	   (if (and (eq? x (car thing))
192		    (eq? y (cdr thing)))
193	       thing			;+++
194	       (cons x y))))
195	((vector? thing)
196	 (let ((new (make-vector (vector-length thing) #f)))
197	   (let loop ((i 0) (same? #t))
198	     (if (>= i (vector-length thing))
199		 (if same? thing new)	;+++
200		 (let ((x (schemify-sexp (vector-ref thing i))))
201		   (vector-set! new i x)
202		   (loop (+ i 1)
203			 (and same? (eq? x (vector-ref thing i)))))))))
204	(else thing)))
205
206