Commit | Line | Data |
---|---|---|
c7228382 KN |
1 | ;;; Guile Scheme specification |
2 | ||
3 | ;; Copyright (C) 2001 Free Software Foundation, Inc. | |
4 | ||
5 | ;; This program is free software; you can redistribute it and/or modify | |
6 | ;; it under the terms of the GNU General Public License as published by | |
7 | ;; the Free Software Foundation; either version 2, or (at your option) | |
8 | ;; any later version. | |
2335fb97 | 9 | ;; |
c7228382 KN |
10 | ;; This program is distributed in the hope that it will be useful, |
11 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
12 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
13 | ;; GNU General Public License for more details. | |
2335fb97 | 14 | ;; |
c7228382 KN |
15 | ;; You should have received a copy of the GNU General Public License |
16 | ;; along with this program; see the file COPYING. If not, write to | |
17 | ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, | |
18 | ;; Boston, MA 02111-1307, USA. | |
19 | ||
20 | ;;; Code: | |
21 | ||
22 | (define-module (language scheme translate) | |
1a1a10d3 AW |
23 | #:use-module (system base pmatch) |
24 | #:use-module (system base language) | |
25 | #:use-module (system il ghil) | |
26 | #:use-module (system il inline) | |
b0b180d5 | 27 | #:use-module (system vm objcode) |
1a1a10d3 | 28 | #:use-module (ice-9 receive) |
b0b180d5 | 29 | #:use-module (ice-9 optargs) |
1e6ebf54 | 30 | #:use-module ((ice-9 syncase) #:select (sc-macro)) |
1a1a10d3 | 31 | #:use-module ((system base compile) #:select (syntax-error)) |
fd4da4fa AW |
32 | #:export (translate translate-1 |
33 | *translate-table* define-scheme-translator)) | |
c7228382 | 34 | |
2335fb97 | 35 | |
b0b180d5 AW |
36 | ;;; environment := #f |
37 | ;;; | MODULE | |
38 | ;;; | COMPILE-ENV | |
39 | ;;; compile-env := (MODULE LEXICALS . EXTERNALS) | |
40 | (define (cenv-module env) | |
41 | (cond ((not env) #f) | |
42 | ((module? env) env) | |
43 | ((and (pair? env) (module? (car env))) (car env)) | |
44 | (else (error "bad environment" env)))) | |
45 | ||
46 | (define (cenv-ghil-env env) | |
47 | (cond ((not env) (make-ghil-toplevel-env)) | |
48 | ((module? env) (make-ghil-toplevel-env)) | |
49 | ((pair? env) | |
50 | (ghil-env-dereify (cadr env))) | |
51 | (else (error "bad environment" env)))) | |
52 | ||
53 | (define (cenv-externals env) | |
54 | (cond ((not env) '()) | |
55 | ((module? env) '()) | |
56 | ((pair? env) (cddr env)) | |
57 | (else (error "bad environment" env)))) | |
58 | ||
59 | ||
60 | \f | |
61 | ||
62 | (define (translate x e opts) | |
63 | (save-module-excursion | |
64 | (lambda () | |
65 | (and=> (cenv-module e) set-current-module) | |
66 | (call-with-ghil-environment (cenv-ghil-env e) '() | |
67 | (lambda (env vars) | |
68 | (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)) | |
69 | (and e | |
70 | (cons* (cenv-module e) | |
71 | (ghil-env-parent env) | |
72 | (cenv-externals e))))))))) | |
c7228382 KN |
73 | |
74 | \f | |
75 | ;;; | |
76 | ;;; Translator | |
77 | ;;; | |
78 | ||
f03c31db | 79 | (define *forbidden-primitives* |
2335fb97 LC |
80 | ;; Guile's `procedure->macro' family is evil because it crosses the |
81 | ;; compilation boundary. One solution might be to evaluate calls to | |
82 | ;; `procedure->memoizing-macro' at compilation time, but it may be more | |
83 | ;; compicated than that. | |
29a321ae | 84 | '(procedure->syntax procedure->macro)) |
2335fb97 | 85 | |
2e7e6969 AW |
86 | ;; Looks up transformers relative to the current module at |
87 | ;; compilation-time. See also the discussion of ghil-lookup in ghil.scm. | |
eb5f05c3 AW |
88 | ;; |
89 | ;; FIXME shadowing lexicals? | |
2e7e6969 AW |
90 | (define (lookup-transformer head retrans) |
91 | (let* ((mod (current-module)) | |
427d4a0c AW |
92 | (val (and (symbol? head) |
93 | (and=> (module-variable mod head) | |
94 | (lambda (var) | |
95 | ;; unbound vars can happen if the module | |
96 | ;; definition forward-declared them | |
97 | (and (variable-bound? var) (variable-ref var))))))) | |
7d1c45d3 | 98 | (cond |
fd4da4fa | 99 | ((hashq-ref *translate-table* val)) |
7d1c45d3 AW |
100 | |
101 | ((defmacro? val) | |
102 | (lambda (env loc exp) | |
103 | (retrans (apply (defmacro-transformer val) (cdr exp))))) | |
104 | ||
1e6ebf54 | 105 | ((eq? val sc-macro) |
a52b96a7 | 106 | ;; syncase! |
8f43eb2b AW |
107 | (let* ((the-syncase-module (resolve-module '(ice-9 syncase))) |
108 | (eec (module-ref the-syncase-module 'expansion-eval-closure)) | |
109 | (sc-expand3 (module-ref the-syncase-module 'sc-expand3))) | |
a52b96a7 | 110 | (lambda (env loc exp) |
8f43eb2b | 111 | (retrans |
1b8abe55 | 112 | (with-fluids ((eec (module-eval-closure mod))) |
8f43eb2b | 113 | (sc-expand3 exp 'c '(compile load eval))))))) |
a52b96a7 | 114 | |
7e97ad2d AW |
115 | ((primitive-macro? val) |
116 | (syntax-error #f "unhandled primitive macro" head)) | |
117 | ||
7d1c45d3 AW |
118 | ((macro? val) |
119 | (syntax-error #f "unknown kind of macro" head)) | |
120 | ||
121 | (else #f)))) | |
122 | ||
fd4da4fa AW |
123 | (define (translate-1 e l x) |
124 | (let ((l (or l (location x)))) | |
125 | (define (retrans x) (translate-1 e #f x)) | |
126 | (cond ((pair? x) | |
127 | (let ((head (car x)) (tail (cdr x))) | |
128 | (cond | |
129 | ((lookup-transformer head retrans) | |
130 | => (lambda (t) (t e l x))) | |
131 | ||
132 | ;; FIXME: lexical/module overrides of forbidden primitives | |
133 | ((memq head *forbidden-primitives*) | |
134 | (syntax-error l (format #f "`~a' is forbidden" head) | |
135 | (cons head tail))) | |
136 | ||
137 | (else | |
138 | (let ((tail (map retrans tail))) | |
139 | (or (and (symbol? head) | |
140 | (try-inline-with-env e l (cons head tail))) | |
141 | (make-ghil-call e l (retrans head) tail))))))) | |
142 | ||
143 | ((symbol? x) | |
144 | (make-ghil-ref e l (ghil-var-for-ref! e x))) | |
145 | ||
146 | ;; fixme: non-self-quoting objects like #<foo> | |
147 | (else | |
148 | (make-ghil-quote e l #:obj x))))) | |
c7228382 | 149 | |
f245e62c AW |
150 | (define (valid-bindings? bindings . it-is-for-do) |
151 | (define (valid-binding? b) | |
152 | (pmatch b | |
153 | ((,sym ,var) (guard (symbol? sym)) #t) | |
154 | ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) | |
155 | (else #f))) | |
156 | (and (list? bindings) (and-map valid-binding? bindings))) | |
157 | ||
fd4da4fa AW |
158 | (define *translate-table* (make-hash-table)) |
159 | ||
160 | (define-macro (define-scheme-translator sym . clauses) | |
161 | `(hashq-set! (@ (language scheme translate) *translate-table*) | |
162 | ,sym | |
163 | (lambda (e l exp) | |
164 | (define (retrans x) | |
165 | ((@ (language scheme translate) translate-1) e #f x)) | |
166 | (define syntax-error (@ (system base compile) syntax-error)) | |
167 | (pmatch (cdr exp) | |
168 | ,@clauses | |
169 | (else | |
eb5f05c3 | 170 | (syntax-error l (format #f "bad ~A" ',sym) exp)))))) |
fd4da4fa AW |
171 | |
172 | (define-scheme-translator quote | |
173 | ;; (quote OBJ) | |
f38624b3 | 174 | ((,obj) (make-ghil-quote e l #:obj obj))) |
7d1c45d3 | 175 | |
fd4da4fa AW |
176 | (define-scheme-translator quasiquote |
177 | ;; (quasiquote OBJ) | |
f38624b3 | 178 | ((,obj) (make-ghil-quasiquote e l #:exp (trans-quasiquote e l obj 0)))) |
fd4da4fa AW |
179 | |
180 | (define-scheme-translator define | |
181 | ;; (define NAME VAL) | |
182 | ((,name ,val) (guard (symbol? name) | |
183 | (ghil-toplevel-env? (ghil-env-parent e))) | |
184 | (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name) | |
185 | (maybe-name-value! (retrans val) name))) | |
186 | ;; (define (NAME FORMALS...) BODY...) | |
187 | (((,name . ,formals) . ,body) (guard (symbol? name)) | |
188 | ;; -> (define NAME (lambda FORMALS BODY...)) | |
189 | (retrans `(define ,name (lambda ,formals ,@body))))) | |
190 | ||
191 | (define-scheme-translator set! | |
192 | ;; (set! NAME VAL) | |
193 | ((,name ,val) (guard (symbol? name)) | |
194 | (make-ghil-set e l (ghil-var-for-set! e name) (retrans val))) | |
195 | ||
196 | ;; FIXME: Would be nice to verify the values of @ and @@ relative | |
197 | ;; to imported modules... | |
198 | (((@ ,modname ,name) ,val) (guard (symbol? name) | |
199 | (list? modname) | |
200 | (and-map symbol? modname) | |
201 | (not (ghil-var-is-bound? e '@))) | |
202 | (make-ghil-set e l (ghil-var-at-module! e modname name #t) | |
203 | (retrans val))) | |
204 | ||
205 | (((@@ ,modname ,name) ,val) (guard (symbol? name) | |
206 | (list? modname) | |
207 | (and-map symbol? modname) | |
208 | (not (ghil-var-is-bound? e '@@))) | |
209 | (make-ghil-set e l (ghil-var-at-module! e modname name #f) | |
210 | (retrans val))) | |
211 | ||
212 | ;; (set! (NAME ARGS...) VAL) | |
213 | (((,name . ,args) ,val) (guard (symbol? name)) | |
214 | ;; -> ((setter NAME) ARGS... VAL) | |
215 | (retrans `((setter ,name) . (,@args ,val))))) | |
216 | ||
217 | (define-scheme-translator if | |
218 | ;; (if TEST THEN [ELSE]) | |
219 | ((,test ,then) | |
220 | (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) | |
221 | ((,test ,then ,else) | |
222 | (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) | |
223 | ||
224 | (define-scheme-translator and | |
225 | ;; (and EXPS...) | |
226 | (,tail (make-ghil-and e l (map retrans tail)))) | |
227 | ||
228 | (define-scheme-translator or | |
229 | ;; (or EXPS...) | |
230 | (,tail (make-ghil-or e l (map retrans tail)))) | |
231 | ||
232 | (define-scheme-translator begin | |
233 | ;; (begin EXPS...) | |
234 | (,tail (make-ghil-begin e l (map retrans tail)))) | |
235 | ||
236 | (define-scheme-translator let | |
237 | ;; (let NAME ((SYM VAL) ...) BODY...) | |
238 | ((,name ,bindings . ,body) (guard (symbol? name) | |
239 | (valid-bindings? bindings)) | |
240 | ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) | |
241 | (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) | |
242 | (,name ,@(map cadr bindings))))) | |
243 | ||
244 | ;; (let () BODY...) | |
245 | ((() . ,body) | |
246 | ;; Note: this differs from `begin' | |
247 | (make-ghil-begin e l (list (trans-body e l body)))) | |
7d1c45d3 | 248 | |
fd4da4fa AW |
249 | ;; (let ((SYM VAL) ...) BODY...) |
250 | ((,bindings . ,body) (guard (valid-bindings? bindings)) | |
251 | (let ((vals (map retrans (map cadr bindings)))) | |
7d1c45d3 | 252 | (call-with-ghil-bindings e (map car bindings) |
fd4da4fa AW |
253 | (lambda (vars) |
254 | (make-ghil-bind e l vars vals (trans-body e l body))))))) | |
255 | ||
256 | (define-scheme-translator let* | |
257 | ;; (let* ((SYM VAL) ...) BODY...) | |
258 | ((() . ,body) | |
259 | (retrans `(let () ,@body))) | |
260 | ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) | |
261 | (retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) | |
262 | ||
263 | (define-scheme-translator letrec | |
264 | ;; (letrec ((SYM VAL) ...) BODY...) | |
265 | ((,bindings . ,body) (guard (valid-bindings? bindings)) | |
266 | (call-with-ghil-bindings e (map car bindings) | |
267 | (lambda (vars) | |
268 | (let ((vals (map retrans (map cadr bindings)))) | |
269 | (make-ghil-bind e l vars vals (trans-body e l body))))))) | |
270 | ||
271 | (define-scheme-translator cond | |
272 | ;; (cond (CLAUSE BODY...) ...) | |
273 | (() (retrans '(begin))) | |
274 | (((else . ,body)) (retrans `(begin ,@body))) | |
275 | (((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) | |
276 | (((,test => ,proc) . ,rest) | |
277 | ;; FIXME hygiene! | |
278 | (retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))) | |
279 | (((,test . ,body) . ,rest) | |
280 | (retrans `(if ,test (begin ,@body) (cond ,@rest))))) | |
281 | ||
282 | (define-scheme-translator case | |
283 | ;; (case EXP ((KEY...) BODY...) ...) | |
284 | ((,exp . ,clauses) | |
285 | (retrans | |
286 | ;; FIXME hygiene! | |
287 | `(let ((_t ,exp)) | |
288 | ,(let loop ((ls clauses)) | |
289 | (cond ((null? ls) '(begin)) | |
290 | ((eq? (caar ls) 'else) `(begin ,@(cdar ls))) | |
291 | (else `(if (memv _t ',(caar ls)) | |
292 | (begin ,@(cdar ls)) | |
293 | ,(loop (cdr ls)))))))))) | |
294 | ||
295 | (define-scheme-translator do | |
296 | ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) | |
297 | ((,bindings (,test . ,result) . ,body) | |
298 | (let ((sym (map car bindings)) | |
299 | (val (map cadr bindings)) | |
300 | (update (map cddr bindings))) | |
301 | (define (next s x) (if (pair? x) (car x) s)) | |
7d1c45d3 AW |
302 | (retrans |
303 | ;; FIXME hygiene! | |
fd4da4fa AW |
304 | `(letrec ((_l (lambda ,sym |
305 | (if ,test | |
306 | (begin ,@result) | |
307 | (begin ,@body | |
308 | (_l ,@(map next sym update))))))) | |
309 | (_l ,@val)))))) | |
310 | ||
311 | (define-scheme-translator lambda | |
312 | ;; (lambda FORMALS BODY...) | |
313 | ((,formals . ,body) | |
314 | (receive (syms rest) (parse-formals formals) | |
315 | (call-with-ghil-environment e syms | |
316 | (lambda (env vars) | |
317 | (receive (meta body) (parse-lambda-meta body) | |
318 | (make-ghil-lambda env l vars rest meta | |
319 | (trans-body env l body)))))))) | |
320 | ||
321 | (define-scheme-translator delay | |
322 | ;; FIXME not hygienic | |
323 | ((,expr) | |
324 | (retrans `(make-promise (lambda () ,expr))))) | |
325 | ||
326 | (define-scheme-translator @ | |
327 | ((,modname ,sym) | |
328 | (make-ghil-ref e l (ghil-var-at-module! e modname sym #t)))) | |
329 | ||
330 | (define-scheme-translator @@ | |
331 | ((,modname ,sym) | |
332 | (make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) | |
333 | ||
334 | (define *the-compile-toplevel-symbol* 'compile-toplevel) | |
335 | (define-scheme-translator eval-case | |
336 | (,clauses | |
337 | (retrans | |
338 | `(begin | |
339 | ;; Compilation of toplevel units is always wrapped in a lambda | |
340 | ,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e)))) | |
341 | (let loop ((seen '()) (in clauses) (runtime '())) | |
342 | (cond | |
343 | ((null? in) runtime) | |
344 | (else | |
345 | (pmatch (car in) | |
346 | ((else . ,body) | |
347 | (if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen))) | |
348 | (primitive-eval `(begin ,@body))) | |
349 | (if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen) | |
350 | runtime | |
351 | body)) | |
352 | ((,keys . ,body) (guard (list? keys) (and-map symbol? keys)) | |
353 | (for-each (lambda (k) | |
354 | (if (memq k seen) | |
355 | (syntax-error l "eval-case condition seen twice" k))) | |
356 | keys) | |
357 | (if (and toplevel? (memq *the-compile-toplevel-symbol* keys)) | |
358 | (primitive-eval `(begin ,@body))) | |
359 | (loop (append keys seen) | |
360 | (cdr in) | |
361 | (if (memq (if toplevel? 'load-toplevel 'evaluate) keys) | |
362 | (append runtime body) | |
363 | runtime))) | |
364 | (else (syntax-error l "bad eval-case clause" (car in)))))))))))) | |
365 | ||
366 | (define-scheme-translator apply | |
367 | ;; FIXME: not hygienic, relies on @apply not being shadowed | |
368 | (,args (retrans `(@apply ,@args)))) | |
369 | ||
370 | (define-scheme-translator @apply | |
371 | ((,proc ,arg1 . ,args) | |
372 | (let ((args (cons (retrans arg1) (map retrans args)))) | |
373 | (cond ((and (symbol? proc) | |
374 | (not (ghil-var-is-bound? e proc)) | |
375 | (and=> (module-variable (current-module) proc) | |
376 | (lambda (var) | |
377 | (and (variable-bound? var) | |
378 | (lookup-apply-transformer (variable-ref var)))))) | |
379 | ;; that is, a variable, not part of this compilation | |
380 | ;; unit, but defined in the toplevel environment, and has | |
381 | ;; an apply transformer registered | |
382 | => (lambda (t) (t e l args))) | |
383 | (else (make-ghil-inline e l 'apply | |
384 | (cons (retrans proc) args))))))) | |
385 | ||
386 | (define-scheme-translator call-with-values | |
387 | ;; FIXME: not hygienic, relies on @call-with-values not being shadowed | |
388 | ((,producer ,consumer) | |
389 | (retrans `(@call-with-values ,producer ,consumer))) | |
390 | (else #f)) | |
391 | ||
392 | (define-scheme-translator @call-with-values | |
393 | ((,producer ,consumer) | |
394 | (make-ghil-mv-call e l (retrans producer) (retrans consumer)))) | |
395 | ||
396 | (define-scheme-translator call-with-current-continuation | |
397 | ;; FIXME: not hygienic, relies on @call-with-current-continuation | |
398 | ;; not being shadowed | |
399 | ((,proc) | |
400 | (retrans `(@call-with-current-continuation ,proc))) | |
401 | (else #f)) | |
402 | ||
403 | (define-scheme-translator @call-with-current-continuation | |
404 | ((,proc) | |
405 | (make-ghil-inline e l 'call/cc (list (retrans proc))))) | |
406 | ||
407 | (define-scheme-translator receive | |
408 | ((,formals ,producer-exp . ,body) | |
409 | ;; Lovely, self-referential usage. Not strictly necessary, the | |
410 | ;; macro would do the trick; but it's good to test the mv-bind | |
411 | ;; code. | |
412 | (receive (syms rest) (parse-formals formals) | |
b0b180d5 AW |
413 | (let ((producer (retrans `(lambda () ,producer-exp)))) |
414 | (call-with-ghil-bindings e syms | |
415 | (lambda (vars) | |
416 | (make-ghil-mv-bind e l producer | |
417 | vars rest (trans-body e l body)))))))) | |
fd4da4fa AW |
418 | |
419 | (define-scheme-translator values | |
420 | ((,x) (retrans x)) | |
421 | (,args (make-ghil-values e l (map retrans args)))) | |
422 | ||
423 | (define-scheme-translator compile-time-environment | |
424 | ;; (compile-time-environment) | |
425 | ;; => (MODULE LEXICALS . EXTERNALS) | |
426 | (() (make-ghil-inline | |
427 | e l 'cons | |
428 | (list (retrans '(current-module)) | |
429 | (make-ghil-inline | |
430 | e l 'cons | |
431 | (list (make-ghil-reified-env e l) | |
432 | (make-ghil-inline e l 'externals '()))))))) | |
c7228382 | 433 | |
ef24c01b AW |
434 | (define (lookup-apply-transformer proc) |
435 | (cond ((eq? proc values) | |
436 | (lambda (e l args) | |
437 | (make-ghil-values* e l args))) | |
438 | (else #f))) | |
439 | ||
124c52d8 | 440 | (define (trans-quasiquote e l x level) |
c7228382 KN |
441 | (cond ((not (pair? x)) x) |
442 | ((memq (car x) '(unquote unquote-splicing)) | |
443 | (let ((l (location x))) | |
f245e62c AW |
444 | (pmatch (cdr x) |
445 | ((,obj) | |
124c52d8 AW |
446 | (cond |
447 | ((zero? level) | |
448 | (if (eq? (car x) 'unquote) | |
fd4da4fa AW |
449 | (make-ghil-unquote e l (translate-1 e l obj)) |
450 | (make-ghil-unquote-splicing e l (translate-1 e l obj)))) | |
124c52d8 AW |
451 | (else |
452 | (list (car x) (trans-quasiquote e l obj (1- level)))))) | |
c7228382 | 453 | (else (syntax-error l (format #f "bad ~A" (car x)) x))))) |
124c52d8 AW |
454 | ((eq? (car x) 'quasiquote) |
455 | (let ((l (location x))) | |
456 | (pmatch (cdr x) | |
457 | ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level)))) | |
458 | (else (syntax-error l (format #f "bad ~A" (car x)) x))))) | |
459 | (else (cons (trans-quasiquote e l (car x) level) | |
460 | (trans-quasiquote e l (cdr x) level))))) | |
c7228382 KN |
461 | |
462 | (define (trans-body e l body) | |
463 | (define (define->binding df) | |
f245e62c AW |
464 | (pmatch (cdr df) |
465 | ((,name ,val) (guard (symbol? name)) (list name val)) | |
466 | (((,name . ,formals) . ,body) (guard (symbol? name)) | |
c7228382 KN |
467 | (list name `(lambda ,formals ,@body))) |
468 | (else (syntax-error (location df) "bad define" df)))) | |
469 | ;; main | |
470 | (let loop ((ls body) (ds '())) | |
be852e52 AW |
471 | (pmatch ls |
472 | (() (syntax-error l "bad body" body)) | |
473 | (((define . _) . _) | |
474 | (loop (cdr ls) (cons (car ls) ds))) | |
475 | (else | |
476 | (if (null? ds) | |
fd4da4fa AW |
477 | (translate-1 e l `(begin ,@ls)) |
478 | (translate-1 e l `(letrec ,(map define->binding ds) ,@ls))))))) | |
c7228382 KN |
479 | |
480 | (define (parse-formals formals) | |
481 | (cond | |
482 | ;; (lambda x ...) | |
483 | ((symbol? formals) (values (list formals) #t)) | |
484 | ;; (lambda (x y z) ...) | |
485 | ((list? formals) (values formals #f)) | |
486 | ;; (lambda (x y . z) ...) | |
487 | ((pair? formals) | |
488 | (let loop ((l formals) (v '())) | |
489 | (if (pair? l) | |
490 | (loop (cdr l) (cons (car l) v)) | |
491 | (values (reverse! (cons l v)) #t)))) | |
492 | (else (syntax-error (location formals) "bad formals" formals)))) | |
493 | ||
fbde2b91 AW |
494 | (define (parse-lambda-meta body) |
495 | (cond ((or (null? body) (null? (cdr body))) (values '() body)) | |
496 | ((string? (car body)) | |
497 | (values `((documentation . ,(car body))) (cdr body))) | |
498 | (else (values '() body)))) | |
499 | ||
5dcf8f35 AW |
500 | (define (maybe-name-value! val name) |
501 | (cond | |
502 | ((ghil-lambda? val) | |
503 | (if (not (assq-ref (ghil-lambda-meta val) 'name)) | |
504 | (set! (ghil-lambda-meta val) | |
505 | (acons 'name name (ghil-lambda-meta val)))))) | |
506 | val) | |
507 | ||
c7228382 KN |
508 | (define (location x) |
509 | (and (pair? x) | |
510 | (let ((props (source-properties x))) | |
511 | (and (not (null? props)) | |
96969dc1 AW |
512 | (vector (assq-ref props 'line) |
513 | (assq-ref props 'column) | |
514 | (assq-ref props 'filename)))))) |