HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Merge remote-tracking branch 'origin/stable-2.0'
[bpt/guile.git] / module / ice-9 / psyntax-pp.scm
1 (eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
2 (if #f #f)
3
4 (letrec*
5 ((make-void
6 (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
7 (make-const
8 (lambda (src exp)
9 (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
10 (make-primitive-ref
11 (lambda (src name)
12 (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
13 (make-lexical-ref
14 (lambda (src name gensym)
15 (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
16 (make-lexical-set
17 (lambda (src name gensym exp)
18 (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
19 (make-module-ref
20 (lambda (src mod name public?)
21 (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
22 (make-module-set
23 (lambda (src mod name public? exp)
24 (make-struct
25 (vector-ref %expanded-vtables 6)
26 0
27 src
28 mod
29 name
30 public?
31 exp)))
32 (make-toplevel-ref
33 (lambda (src name)
34 (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
35 (make-toplevel-set
36 (lambda (src name exp)
37 (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
38 (make-toplevel-define
39 (lambda (src name exp)
40 (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
41 (make-conditional
42 (lambda (src test consequent alternate)
43 (make-struct
44 (vector-ref %expanded-vtables 10)
45 0
46 src
47 test
48 consequent
49 alternate)))
50 (make-call
51 (lambda (src proc args)
52 (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
53 (make-primcall
54 (lambda (src name args)
55 (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
56 (make-seq
57 (lambda (src head tail)
58 (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
59 (make-lambda
60 (lambda (src meta body)
61 (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
62 (make-lambda-case
63 (lambda (src req opt rest kw inits gensyms body alternate)
64 (make-struct
65 (vector-ref %expanded-vtables 15)
66 0
67 src
68 req
69 opt
70 rest
71 kw
72 inits
73 gensyms
74 body
75 alternate)))
76 (make-let
77 (lambda (src names gensyms vals body)
78 (make-struct
79 (vector-ref %expanded-vtables 16)
80 0
81 src
82 names
83 gensyms
84 vals
85 body)))
86 (make-letrec
87 (lambda (src in-order? names gensyms vals body)
88 (make-struct
89 (vector-ref %expanded-vtables 17)
90 0
91 src
92 in-order?
93 names
94 gensyms
95 vals
96 body)))
97 (make-dynlet
98 (lambda (src fluids vals body)
99 (make-struct
100 (vector-ref %expanded-vtables 18)
101 0
102 src
103 fluids
104 vals
105 body)))
106 (lambda?
107 (lambda (x)
108 (and (struct? x)
109 (eq? (struct-vtable x) (vector-ref %expanded-vtables 14)))))
110 (lambda-meta (lambda (x) (struct-ref x 1)))
111 (set-lambda-meta! (lambda (x v) (struct-set! x 1 v)))
112 (top-level-eval-hook (lambda (x mod) (primitive-eval x)))
113 (local-eval-hook (lambda (x mod) (primitive-eval x)))
114 (session-id
115 (let ((v (module-variable (current-module) 'syntax-session-id)))
116 (lambda () ((variable-ref v)))))
117 (put-global-definition-hook
118 (lambda (symbol type val)
119 (module-define!
120 (current-module)
121 symbol
122 (make-syntax-transformer symbol type val))))
123 (get-global-definition-hook
124 (lambda (symbol module)
125 (if (and (not module) (current-module))
126 (warn "module system is booted, we should have a module" symbol))
127 (let ((v (module-variable
128 (if module (resolve-module (cdr module)) (current-module))
129 symbol)))
130 (and v
131 (variable-bound? v)
132 (let ((val (variable-ref v)))
133 (and (macro? val)
134 (macro-type val)
135 (cons (macro-type val) (macro-binding val))))))))
136 (decorate-source
137 (lambda (e s)
138 (if (and s (supports-source-properties? e))
139 (set-source-properties! e s))
140 e))
141 (maybe-name-value!
142 (lambda (name val)
143 (if (lambda? val)
144 (let ((meta (lambda-meta val)))
145 (if (not (assq 'name meta))
146 (set-lambda-meta! val (acons 'name name meta)))))))
147 (build-void (lambda (source) (make-void source)))
148 (build-call
149 (lambda (source fun-exp arg-exps)
150 (make-call source fun-exp arg-exps)))
151 (build-conditional
152 (lambda (source test-exp then-exp else-exp)
153 (make-conditional source test-exp then-exp else-exp)))
154 (build-dynlet
155 (lambda (source fluids vals body)
156 (make-dynlet source fluids vals body)))
157 (build-lexical-reference
158 (lambda (type source name var) (make-lexical-ref source name var)))
159 (build-lexical-assignment
160 (lambda (source name var exp)
161 (maybe-name-value! name exp)
162 (make-lexical-set source name var exp)))
163 (analyze-variable
164 (lambda (mod var modref-cont bare-cont)
165 (if (not mod)
166 (bare-cont var)
167 (let ((kind (car mod)) (mod (cdr mod)))
168 (let ((key kind))
169 (cond ((memv key '(public)) (modref-cont mod var #t))
170 ((memv key '(private))
171 (if (not (equal? mod (module-name (current-module))))
172 (modref-cont mod var #f)
173 (bare-cont var)))
174 ((memv key '(bare)) (bare-cont var))
175 ((memv key '(hygiene))
176 (if (and (not (equal? mod (module-name (current-module))))
177 (module-variable (resolve-module mod) var))
178 (modref-cont mod var #f)
179 (bare-cont var)))
180 (else (syntax-violation #f "bad module kind" var mod))))))))
181 (build-global-reference
182 (lambda (source var mod)
183 (analyze-variable
184 mod
185 var
186 (lambda (mod var public?) (make-module-ref source mod var public?))
187 (lambda (var) (make-toplevel-ref source var)))))
188 (build-global-assignment
189 (lambda (source var exp mod)
190 (maybe-name-value! var exp)
191 (analyze-variable
192 mod
193 var
194 (lambda (mod var public?)
195 (make-module-set source mod var public? exp))
196 (lambda (var) (make-toplevel-set source var exp)))))
197 (build-global-definition
198 (lambda (source var exp)
199 (maybe-name-value! var exp)
200 (make-toplevel-define source var exp)))
201 (build-simple-lambda
202 (lambda (src req rest vars meta exp)
203 (make-lambda
204 src
205 meta
206 (make-lambda-case src req #f rest #f '() vars exp #f))))
207 (build-case-lambda
208 (lambda (src meta body) (make-lambda src meta body)))
209 (build-lambda-case
210 (lambda (src req opt rest kw inits vars body else-case)
211 (make-lambda-case src req opt rest kw inits vars body else-case)))
212 (build-primcall
213 (lambda (src name args) (make-primcall src name args)))
214 (build-primref (lambda (src name) (make-primitive-ref src name)))
215 (build-data (lambda (src exp) (make-const src exp)))
216 (build-sequence
217 (lambda (src exps)
218 (if (null? (cdr exps))
219 (car exps)
220 (make-seq src (car exps) (build-sequence #f (cdr exps))))))
221 (build-let
222 (lambda (src ids vars val-exps body-exp)
223 (for-each maybe-name-value! ids val-exps)
224 (if (null? vars) body-exp (make-let src ids vars val-exps body-exp))))
225 (build-named-let
226 (lambda (src ids vars val-exps body-exp)
227 (let ((f (car vars)) (f-name (car ids)) (vars (cdr vars)) (ids (cdr ids)))
228 (let ((proc (build-simple-lambda src ids #f vars '() body-exp)))
229 (maybe-name-value! f-name proc)
230 (for-each maybe-name-value! ids val-exps)
231 (make-letrec
232 src
233 #f
234 (list f-name)
235 (list f)
236 (list proc)
237 (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
238 (build-letrec
239 (lambda (src in-order? ids vars val-exps body-exp)
240 (if (null? vars)
241 body-exp
242 (begin
243 (for-each maybe-name-value! ids val-exps)
244 (make-letrec src in-order? ids vars val-exps body-exp)))))
245 (make-syntax-object
246 (lambda (expression wrap module)
247 (vector 'syntax-object expression wrap module)))
248 (syntax-object?
249 (lambda (x)
250 (and (vector? x)
251 (= (vector-length x) 4)
252 (eq? (vector-ref x 0) 'syntax-object))))
253 (syntax-object-expression (lambda (x) (vector-ref x 1)))
254 (syntax-object-wrap (lambda (x) (vector-ref x 2)))
255 (syntax-object-module (lambda (x) (vector-ref x 3)))
256 (set-syntax-object-expression!
257 (lambda (x update) (vector-set! x 1 update)))
258 (set-syntax-object-wrap!
259 (lambda (x update) (vector-set! x 2 update)))
260 (set-syntax-object-module!
261 (lambda (x update) (vector-set! x 3 update)))
262 (source-annotation
263 (lambda (x)
264 (let ((props (source-properties
265 (if (syntax-object? x) (syntax-object-expression x) x))))
266 (and (pair? props) props))))
267 (extend-env
268 (lambda (labels bindings r)
269 (if (null? labels)
270 r
271 (extend-env
272 (cdr labels)
273 (cdr bindings)
274 (cons (cons (car labels) (car bindings)) r)))))
275 (extend-var-env
276 (lambda (labels vars r)
277 (if (null? labels)
278 r
279 (extend-var-env
280 (cdr labels)
281 (cdr vars)
282 (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
283 (macros-only-env
284 (lambda (r)
285 (if (null? r)
286 '()
287 (let ((a (car r)))
288 (if (memq (cadr a) '(macro syntax-parameter))
289 (cons a (macros-only-env (cdr r)))
290 (macros-only-env (cdr r)))))))
291 (global-extend
292 (lambda (type sym val) (put-global-definition-hook sym type val)))
293 (nonsymbol-id?
294 (lambda (x)
295 (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
296 (id? (lambda (x)
297 (if (symbol? x)
298 #t
299 (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
300 (id-sym-name&marks
301 (lambda (x w)
302 (if (syntax-object? x)
303 (values
304 (syntax-object-expression x)
305 (join-marks (car w) (car (syntax-object-wrap x))))
306 (values x (car w)))))
307 (gen-label
308 (lambda ()
309 (string-append "l-" (session-id) (symbol->string (gensym "-")))))
310 (gen-labels
311 (lambda (ls)
312 (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
313 (make-ribcage
314 (lambda (symnames marks labels)
315 (vector 'ribcage symnames marks labels)))
316 (ribcage?
317 (lambda (x)
318 (and (vector? x)
319 (= (vector-length x) 4)
320 (eq? (vector-ref x 0) 'ribcage))))
321 (ribcage-symnames (lambda (x) (vector-ref x 1)))
322 (ribcage-marks (lambda (x) (vector-ref x 2)))
323 (ribcage-labels (lambda (x) (vector-ref x 3)))
324 (set-ribcage-symnames! (lambda (x update) (vector-set! x 1 update)))
325 (set-ribcage-marks! (lambda (x update) (vector-set! x 2 update)))
326 (set-ribcage-labels! (lambda (x update) (vector-set! x 3 update)))
327 (anti-mark
328 (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
329 (extend-ribcage!
330 (lambda (ribcage id label)
331 (set-ribcage-symnames!
332 ribcage
333 (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
334 (set-ribcage-marks!
335 ribcage
336 (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
337 (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
338 (make-binding-wrap
339 (lambda (ids labels w)
340 (if (null? ids)
341 w
342 (cons (car w)
343 (cons (let* ((labelvec (list->vector labels)) (n (vector-length labelvec)))
344 (let ((symnamevec (make-vector n)) (marksvec (make-vector n)))
345 (let f ((ids ids) (i 0))
346 (if (not (null? ids))
347 (call-with-values
348 (lambda () (id-sym-name&marks (car ids) w))
349 (lambda (symname marks)
350 (vector-set! symnamevec i symname)
351 (vector-set! marksvec i marks)
352 (f (cdr ids) (+ i 1))))))
353 (make-ribcage symnamevec marksvec labelvec)))
354 (cdr w))))))
355 (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
356 (join-wraps
357 (lambda (w1 w2)
358 (let ((m1 (car w1)) (s1 (cdr w1)))
359 (if (null? m1)
360 (if (null? s1) w2 (cons (car w2) (smart-append s1 (cdr w2))))
361 (cons (smart-append m1 (car w2)) (smart-append s1 (cdr w2)))))))
362 (join-marks (lambda (m1 m2) (smart-append m1 m2)))
363 (same-marks?
364 (lambda (x y)
365 (or (eq? x y)
366 (and (not (null? x))
367 (not (null? y))
368 (eq? (car x) (car y))
369 (same-marks? (cdr x) (cdr y))))))
370 (id-var-name
371 (lambda (id w mod)
372 (letrec*
373 ((search
374 (lambda (sym subst marks mod)
375 (if (null? subst)
376 (values #f marks)
377 (let ((fst (car subst)))
378 (if (eq? fst 'shift)
379 (search sym (cdr subst) (cdr marks) mod)
380 (let ((symnames (ribcage-symnames fst)))
381 (if (vector? symnames)
382 (search-vector-rib sym subst marks symnames fst mod)
383 (search-list-rib sym subst marks symnames fst mod))))))))
384 (search-list-rib
385 (lambda (sym subst marks symnames ribcage mod)
386 (let f ((symnames symnames) (i 0))
387 (cond ((null? symnames) (search sym (cdr subst) marks mod))
388 ((and (eq? (car symnames) sym)
389 (same-marks? marks (list-ref (ribcage-marks ribcage) i)))
390 (let ((n (list-ref (ribcage-labels ribcage) i)))
391 (if (pair? n)
392 (if (equal? mod (car n))
393 (values (cdr n) marks)
394 (f (cdr symnames) (+ i 1)))
395 (values n marks))))
396 (else (f (cdr symnames) (+ i 1)))))))
397 (search-vector-rib
398 (lambda (sym subst marks symnames ribcage mod)
399 (let ((n (vector-length symnames)))
400 (let f ((i 0))
401 (cond ((= i n) (search sym (cdr subst) marks mod))
402 ((and (eq? (vector-ref symnames i) sym)
403 (same-marks? marks (vector-ref (ribcage-marks ribcage) i)))
404 (let ((n (vector-ref (ribcage-labels ribcage) i)))
405 (if (pair? n)
406 (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
407 (values n marks))))
408 (else (f (+ i 1)))))))))
409 (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id))
410 ((syntax-object? id)
411 (let ((id (syntax-object-expression id))
412 (w1 (syntax-object-wrap id))
413 (mod (syntax-object-module id)))
414 (let ((marks (join-marks (car w) (car w1))))
415 (call-with-values
416 (lambda () (search id (cdr w) marks mod))
417 (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id))))))
418 (else (syntax-violation 'id-var-name "invalid id" id))))))
419 (locally-bound-identifiers
420 (lambda (w mod)
421 (letrec*
422 ((scan (lambda (subst results)
423 (if (null? subst)
424 results
425 (let ((fst (car subst)))
426 (if (eq? fst 'shift)
427 (scan (cdr subst) results)
428 (let ((symnames (ribcage-symnames fst)) (marks (ribcage-marks fst)))
429 (if (vector? symnames)
430 (scan-vector-rib subst symnames marks results)
431 (scan-list-rib subst symnames marks results))))))))
432 (scan-list-rib
433 (lambda (subst symnames marks results)
434 (let f ((symnames symnames) (marks marks) (results results))
435 (if (null? symnames)
436 (scan (cdr subst) results)
437 (f (cdr symnames)
438 (cdr marks)
439 (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod)
440 results))))))
441 (scan-vector-rib
442 (lambda (subst symnames marks results)
443 (let ((n (vector-length symnames)))
444 (let f ((i 0) (results results))
445 (if (= i n)
446 (scan (cdr subst) results)
447 (f (+ i 1)
448 (cons (wrap (vector-ref symnames i)
449 (anti-mark (cons (vector-ref marks i) subst))
450 mod)
451 results))))))))
452 (scan (cdr w) '()))))
453 (resolve-identifier
454 (lambda (id w r mod resolve-syntax-parameters?)
455 (letrec*
456 ((resolve-syntax-parameters
457 (lambda (b)
458 (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
459 (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
460 b)))
461 (resolve-global
462 (lambda (var mod)
463 (let ((b (resolve-syntax-parameters
464 (or (get-global-definition-hook var mod) '(global)))))
465 (if (eq? (car b) 'global)
466 (values 'global var mod)
467 (values (car b) (cdr b) mod)))))
468 (resolve-lexical
469 (lambda (label mod)
470 (let ((b (resolve-syntax-parameters
471 (or (assq-ref r label) '(displaced-lexical)))))
472 (values (car b) (cdr b) mod)))))
473 (let ((n (id-var-name id w mod)))
474 (cond ((syntax-object? n)
475 (resolve-identifier n w r mod resolve-syntax-parameters?))
476 ((symbol? n)
477 (resolve-global
478 n
479 (if (syntax-object? id) (syntax-object-module id) mod)))
480 ((string? n)
481 (resolve-lexical
482 n
483 (if (syntax-object? id) (syntax-object-module id) mod)))
484 (else (error "unexpected id-var-name" id w n)))))))
485 (transformer-environment
486 (make-fluid
487 (lambda (k)
488 (error "called outside the dynamic extent of a syntax transformer"))))
489 (with-transformer-environment
490 (lambda (k) ((fluid-ref transformer-environment) k)))
491 (free-id=?
492 (lambda (i j)
493 (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
494 (mj (and (syntax-object? j) (syntax-object-module j)))
495 (ni (id-var-name i '(()) mi))
496 (nj (id-var-name j '(()) mj)))
497 (letrec*
498 ((id-module-binding
499 (lambda (id mod)
500 (module-variable
501 (if mod (resolve-module (cdr mod)) (current-module))
502 (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
503 (cond ((syntax-object? ni) (free-id=? ni j))
504 ((syntax-object? nj) (free-id=? i nj))
505 ((symbol? ni)
506 (and (eq? nj
507 (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
508 (let ((bi (id-module-binding i mi)))
509 (if bi
510 (eq? bi (id-module-binding j mj))
511 (and (not (id-module-binding j mj)) (eq? ni nj))))
512 (eq? (id-module-binding i mi) (id-module-binding j mj))))
513 (else (equal? ni nj)))))))
514 (bound-id=?
515 (lambda (i j)
516 (if (and (syntax-object? i) (syntax-object? j))
517 (and (eq? (syntax-object-expression i) (syntax-object-expression j))
518 (same-marks?
519 (car (syntax-object-wrap i))
520 (car (syntax-object-wrap j))))
521 (eq? i j))))
522 (valid-bound-ids?
523 (lambda (ids)
524 (and (let all-ids? ((ids ids))
525 (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
526 (distinct-bound-ids? ids))))
527 (distinct-bound-ids?
528 (lambda (ids)
529 (let distinct? ((ids ids))
530 (or (null? ids)
531 (and (not (bound-id-member? (car ids) (cdr ids)))
532 (distinct? (cdr ids)))))))
533 (bound-id-member?
534 (lambda (x list)
535 (and (not (null? list))
536 (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
537 (wrap (lambda (x w defmod)
538 (cond ((and (null? (car w)) (null? (cdr w))) x)
539 ((syntax-object? x)
540 (make-syntax-object
541 (syntax-object-expression x)
542 (join-wraps w (syntax-object-wrap x))
543 (syntax-object-module x)))
544 ((null? x) x)
545 (else (make-syntax-object x w defmod)))))
546 (source-wrap
547 (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
548 (expand-sequence
549 (lambda (body r w s mod)
550 (build-sequence
551 s
552 (let dobody ((body body) (r r) (w w) (mod mod))
553 (if (null? body)
554 '()
555 (let ((first (expand (car body) r w mod)))
556 (cons first (dobody (cdr body) r w mod))))))))
557 (expand-top-sequence
558 (lambda (body r w s m esew mod)
559 (let* ((r (cons '("placeholder" placeholder) r))
560 (ribcage (make-ribcage '() '() '()))
561 (w (cons (car w) (cons ribcage (cdr w)))))
562 (letrec*
563 ((record-definition!
564 (lambda (id var)
565 (let ((mod (cons 'hygiene (module-name (current-module)))))
566 (extend-ribcage!
567 ribcage
568 id
569 (cons (syntax-object-module id) (wrap var '((top)) mod))))))
570 (macro-introduced-identifier?
571 (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
572 (fresh-derived-name
573 (lambda (id orig-form)
574 (symbol-append
575 (syntax-object-expression id)
576 '-
577 (string->symbol
578 (number->string
579 (hash (syntax->datum orig-form) most-positive-fixnum)
580 16)))))
581 (parse (lambda (body r w s m esew mod)
582 (let lp ((body body) (exps '()))
583 (if (null? body)
584 exps
585 (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
586 (parse1
587 (lambda (x r w s m esew mod)
588 (call-with-values
589 (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
590 (lambda (type value form e w s mod)
591 (let ((key type))
592 (cond ((memv key '(define-form))
593 (let* ((id (wrap value w mod))
594 (label (gen-label))
595 (var (if (macro-introduced-identifier? id)
596 (fresh-derived-name id x)
597 (syntax-object-expression id))))
598 (record-definition! id var)
599 (list (if (eq? m 'c&e)
600 (let ((x (build-global-definition s var (expand e r w mod))))
601 (top-level-eval-hook x mod)
602 (lambda () x))
603 (lambda () (build-global-definition s var (expand e r w mod)))))))
604 ((memv key '(define-syntax-form define-syntax-parameter-form))
605 (let* ((id (wrap value w mod))
606 (label (gen-label))
607 (var (if (macro-introduced-identifier? id)
608 (fresh-derived-name id x)
609 (syntax-object-expression id))))
610 (record-definition! id var)
611 (let ((key m))
612 (cond ((memv key '(c))
613 (cond ((memq 'compile esew)
614 (let ((e (expand-install-global var type (expand e r w mod))))
615 (top-level-eval-hook e mod)
616 (if (memq 'load esew) (list (lambda () e)) '())))
617 ((memq 'load esew)
618 (list (lambda () (expand-install-global var type (expand e r w mod)))))
619 (else '())))
620 ((memv key '(c&e))
621 (let ((e (expand-install-global var type (expand e r w mod))))
622 (top-level-eval-hook e mod)
623 (list (lambda () e))))
624 (else
625 (if (memq 'eval esew)
626 (top-level-eval-hook
627 (expand-install-global var type (expand e r w mod))
628 mod))
629 '())))))
630 ((memv key '(begin-form))
631 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
632 (if tmp
633 (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
634 (syntax-violation
635 #f
636 "source expression failed to match any pattern"
637 tmp-1))))
638 ((memv key '(local-syntax-form))
639 (expand-local-syntax
640 value
641 e
642 r
643 w
644 s
645 mod
646 (lambda (forms r w s mod) (parse forms r w s m esew mod))))
647 ((memv key '(eval-when-form))
648 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
649 (if tmp
650 (apply (lambda (x e1 e2)
651 (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
652 (letrec*
653 ((recurse (lambda (m esew) (parse body r w s m esew mod))))
654 (cond ((eq? m 'e)
655 (if (memq 'eval when-list)
656 (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
657 (begin
658 (if (memq 'expand when-list)
659 (top-level-eval-hook
660 (expand-top-sequence body r w s 'e '(eval) mod)
661 mod))
662 '())))
663 ((memq 'load when-list)
664 (cond ((or (memq 'compile when-list)
665 (memq 'expand when-list)
666 (and (eq? m 'c&e) (memq 'eval when-list)))
667 (recurse 'c&e '(compile load)))
668 ((memq m '(c c&e)) (recurse 'c '(load)))
669 (else '())))
670 ((or (memq 'compile when-list)
671 (memq 'expand when-list)
672 (and (eq? m 'c&e) (memq 'eval when-list)))
673 (top-level-eval-hook
674 (expand-top-sequence body r w s 'e '(eval) mod)
675 mod)
676 '())
677 (else '())))))
678 tmp)
679 (syntax-violation
680 #f
681 "source expression failed to match any pattern"
682 tmp-1))))
683 (else
684 (list (if (eq? m 'c&e)
685 (let ((x (expand-expr type value form e r w s mod)))
686 (top-level-eval-hook x mod)
687 (lambda () x))
688 (lambda () (expand-expr type value form e r w s mod))))))))))))
689 (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
690 (if (null? exps) (build-void s) (build-sequence s exps)))))))
691 (expand-install-global
692 (lambda (name type e)
693 (build-global-definition
694 #f
695 name
696 (build-primcall
697 #f
698 'make-syntax-transformer
699 (if (eq? type 'define-syntax-parameter-form)
700 (list (build-data #f name)
701 (build-data #f 'syntax-parameter)
702 (build-primcall #f 'list (list e)))
703 (list (build-data #f name) (build-data #f 'macro) e))))))
704 (parse-when-list
705 (lambda (e when-list)
706 (let ((result (strip when-list '(()))))
707 (let lp ((l result))
708 (cond ((null? l) result)
709 ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
710 (else (syntax-violation 'eval-when "invalid situation" e (car l))))))))
711 (syntax-type
712 (lambda (e r w s rib mod for-car?)
713 (cond ((symbol? e)
714 (call-with-values
715 (lambda () (resolve-identifier e w r mod #t))
716 (lambda (type value mod*)
717 (let ((key type))
718 (cond ((memv key '(macro))
719 (if for-car?
720 (values type value e e w s mod)
721 (syntax-type
722 (expand-macro value e r w s rib mod)
723 r
724 '(())
725 s
726 rib
727 mod
728 #f)))
729 ((memv key '(global)) (values type value e value w s mod*))
730 (else (values type value e e w s mod)))))))
731 ((pair? e)
732 (let ((first (car e)))
733 (call-with-values
734 (lambda () (syntax-type first r w s rib mod #t))
735 (lambda (ftype fval fform fe fw fs fmod)
736 (let ((key ftype))
737 (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
738 ((memv key '(global))
739 (values 'global-call (make-syntax-object fval w fmod) e e w s mod))
740 ((memv key '(macro))
741 (syntax-type
742 (expand-macro fval e r w s rib mod)
743 r
744 '(())
745 s
746 rib
747 mod
748 for-car?))
749 ((memv key '(module-ref))
750 (call-with-values
751 (lambda () (fval e r w))
752 (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
753 ((memv key '(core)) (values 'core-form fval e e w s mod))
754 ((memv key '(local-syntax))
755 (values 'local-syntax-form fval e e w s mod))
756 ((memv key '(begin)) (values 'begin-form #f e e w s mod))
757 ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod))
758 ((memv key '(define))
759 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
760 (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1))
761 (apply (lambda (name val) (values 'define-form name e val w s mod))
762 tmp-1)
763 (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any))))
764 (if (and tmp-1
765 (apply (lambda (name args e1 e2)
766 (and (id? name) (valid-bound-ids? (lambda-var-list args))))
767 tmp-1))
768 (apply (lambda (name args e1 e2)
769 (values
770 'define-form
771 (wrap name w mod)
772 (wrap e w mod)
773 (decorate-source
774 (cons '#(syntax-object lambda ((top)) (hygiene guile))
775 (wrap (cons args (cons e1 e2)) w mod))
776 s)
777 '(())
778 s
779 mod))
780 tmp-1)
781 (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
782 (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1))
783 (apply (lambda (name)
784 (values
785 'define-form
786 (wrap name w mod)
787 (wrap e w mod)
788 '(#(syntax-object if ((top)) (hygiene guile)) #f #f)
789 '(())
790 s
791 mod))
792 tmp-1)
793 (syntax-violation
794 #f
795 "source expression failed to match any pattern"
796 tmp))))))))
797 ((memv key '(define-syntax))
798 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
799 (if (and tmp (apply (lambda (name val) (id? name)) tmp))
800 (apply (lambda (name val) (values 'define-syntax-form name e val w s mod))
801 tmp)
802 (syntax-violation
803 #f
804 "source expression failed to match any pattern"
805 tmp-1))))
806 ((memv key '(define-syntax-parameter))
807 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
808 (if (and tmp (apply (lambda (name val) (id? name)) tmp))
809 (apply (lambda (name val)
810 (values 'define-syntax-parameter-form name e val w s mod))
811 tmp)
812 (syntax-violation
813 #f
814 "source expression failed to match any pattern"
815 tmp-1))))
816 (else (values 'call #f e e w s mod))))))))
817 ((syntax-object? e)
818 (syntax-type
819 (syntax-object-expression e)
820 r
821 (join-wraps w (syntax-object-wrap e))
822 (or (source-annotation e) s)
823 rib
824 (or (syntax-object-module e) mod)
825 for-car?))
826 ((self-evaluating? e) (values 'constant #f e e w s mod))
827 (else (values 'other #f e e w s mod)))))
828 (expand
829 (lambda (e r w mod)
830 (call-with-values
831 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
832 (lambda (type value form e w s mod)
833 (expand-expr type value form e r w s mod)))))
834 (expand-expr
835 (lambda (type value form e r w s mod)
836 (let ((key type))
837 (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value))
838 ((memv key '(core core-form)) (value e r w s mod))
839 ((memv key '(module-ref))
840 (call-with-values
841 (lambda () (value e r w))
842 (lambda (e r w s mod) (expand e r w mod))))
843 ((memv key '(lexical-call))
844 (expand-call
845 (let ((id (car e)))
846 (build-lexical-reference
847 'fun
848 (source-annotation id)
849 (if (syntax-object? id) (syntax->datum id) id)
850 value))
851 e
852 r
853 w
854 s
855 mod))
856 ((memv key '(global-call))
857 (expand-call
858 (build-global-reference
859 (source-annotation (car e))
860 (if (syntax-object? value) (syntax-object-expression value) value)
861 (if (syntax-object? value) (syntax-object-module value) mod))
862 e
863 r
864 w
865 s
866 mod))
867 ((memv key '(constant))
868 (build-data s (strip (source-wrap e w s mod) '(()))))
869 ((memv key '(global)) (build-global-reference s value mod))
870 ((memv key '(call))
871 (expand-call (expand (car e) r w mod) e r w s mod))
872 ((memv key '(begin-form))
873 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
874 (if tmp-1
875 (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod))
876 tmp-1)
877 (let ((tmp-1 ($sc-dispatch tmp '(_))))
878 (if tmp-1
879 (apply (lambda ()
880 (syntax-violation
881 #f
882 "sequence of zero expressions"
883 (source-wrap e w s mod)))
884 tmp-1)
885 (syntax-violation
886 #f
887 "source expression failed to match any pattern"
888 tmp))))))
889 ((memv key '(local-syntax-form))
890 (expand-local-syntax value e r w s mod expand-sequence))
891 ((memv key '(eval-when-form))
892 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
893 (if tmp
894 (apply (lambda (x e1 e2)
895 (let ((when-list (parse-when-list e x)))
896 (if (memq 'eval when-list)
897 (expand-sequence (cons e1 e2) r w s mod)
898 (expand-void))))
899 tmp)
900 (syntax-violation
901 #f
902 "source expression failed to match any pattern"
903 tmp-1))))
904 ((memv key
905 '(define-form define-syntax-form define-syntax-parameter-form))
906 (syntax-violation
907 #f
908 "definition in expression context, where definitions are not allowed,"
909 (source-wrap form w s mod)))
910 ((memv key '(syntax))
911 (syntax-violation
912 #f
913 "reference to pattern variable outside syntax form"
914 (source-wrap e w s mod)))
915 ((memv key '(displaced-lexical))
916 (syntax-violation
917 #f
918 "reference to identifier outside its scope"
919 (source-wrap e w s mod)))
920 (else
921 (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
922 (expand-call
923 (lambda (x e r w s mod)
924 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
925 (if tmp
926 (apply (lambda (e0 e1)
927 (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
928 tmp)
929 (syntax-violation
930 #f
931 "source expression failed to match any pattern"
932 tmp-1)))))
933 (expand-macro
934 (lambda (p e r w s rib mod)
935 (letrec*
936 ((rebuild-macro-output
937 (lambda (x m)
938 (cond ((pair? x)
939 (decorate-source
940 (cons (rebuild-macro-output (car x) m)
941 (rebuild-macro-output (cdr x) m))
942 s))
943 ((syntax-object? x)
944 (let ((w (syntax-object-wrap x)))
945 (let ((ms (car w)) (ss (cdr w)))
946 (if (and (pair? ms) (eq? (car ms) #f))
947 (make-syntax-object
948 (syntax-object-expression x)
949 (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
950 (syntax-object-module x))
951 (make-syntax-object
952 (decorate-source (syntax-object-expression x) s)
953 (cons (cons m ms)
954 (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
955 (syntax-object-module x))))))
956 ((vector? x)
957 (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
958 (let loop ((i 0))
959 (if (= i n)
960 (begin (if #f #f) v)
961 (begin
962 (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
963 (loop (+ i 1)))))))
964 ((symbol? x)
965 (syntax-violation
966 #f
967 "encountered raw symbol in macro output"
968 (source-wrap e w (cdr w) mod)
969 x))
970 (else (decorate-source x s))))))
971 (with-fluids
972 ((transformer-environment (lambda (k) (k e r w s rib mod))))
973 (rebuild-macro-output
974 (p (source-wrap e (anti-mark w) s mod))
975 (gensym (string-append "m-" (session-id) "-")))))))
976 (expand-body
977 (lambda (body outer-form r w mod)
978 (let* ((r (cons '("placeholder" placeholder) r))
979 (ribcage (make-ribcage '() '() '()))
980 (w (cons (car w) (cons ribcage (cdr w)))))
981 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
982 (ids '())
983 (labels '())
984 (var-ids '())
985 (vars '())
986 (vals '())
987 (bindings '()))
988 (if (null? body)
989 (syntax-violation #f "no expressions in body" outer-form)
990 (let ((e (cdar body)) (er (caar body)))
991 (call-with-values
992 (lambda ()
993 (syntax-type e er '(()) (source-annotation er) ribcage mod #f))
994 (lambda (type value form e w s mod)
995 (let ((key type))
996 (cond ((memv key '(define-form))
997 (let ((id (wrap value w mod)) (label (gen-label)))
998 (let ((var (gen-var id)))
999 (extend-ribcage! ribcage id label)
1000 (parse (cdr body)
1001 (cons id ids)
1002 (cons label labels)
1003 (cons id var-ids)
1004 (cons var vars)
1005 (cons (cons er (wrap e w mod)) vals)
1006 (cons (cons 'lexical var) bindings)))))
1007 ((memv key '(define-syntax-form define-syntax-parameter-form))
1008 (let ((id (wrap value w mod)) (label (gen-label)))
1009 (extend-ribcage! ribcage id label)
1010 (parse (cdr body)
1011 (cons id ids)
1012 (cons label labels)
1013 var-ids
1014 vars
1015 vals
1016 (cons (cons (if (eq? type 'define-syntax-parameter-form)
1017 'syntax-parameter
1018 'macro)
1019 (cons er (wrap e w mod)))
1020 bindings))))
1021 ((memv key '(begin-form))
1022 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
1023 (if tmp
1024 (apply (lambda (e1)
1025 (parse (let f ((forms e1))
1026 (if (null? forms)
1027 (cdr body)
1028 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1029 ids
1030 labels
1031 var-ids
1032 vars
1033 vals
1034 bindings))
1035 tmp)
1036 (syntax-violation
1037 #f
1038 "source expression failed to match any pattern"
1039 tmp-1))))
1040 ((memv key '(local-syntax-form))
1041 (expand-local-syntax
1042 value
1043 e
1044 er
1045 w
1046 s
1047 mod
1048 (lambda (forms er w s mod)
1049 (parse (let f ((forms forms))
1050 (if (null? forms)
1051 (cdr body)
1052 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1053 ids
1054 labels
1055 var-ids
1056 vars
1057 vals
1058 bindings))))
1059 ((null? ids)
1060 (build-sequence
1061 #f
1062 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1063 (cons (cons er (source-wrap e w s mod)) (cdr body)))))
1064 (else
1065 (if (not (valid-bound-ids? ids))
1066 (syntax-violation
1067 #f
1068 "invalid or duplicate identifier in definition"
1069 outer-form))
1070 (let loop ((bs bindings) (er-cache #f) (r-cache #f))
1071 (if (not (null? bs))
1072 (let ((b (car bs)))
1073 (if (memq (car b) '(macro syntax-parameter))
1074 (let* ((er (cadr b))
1075 (r-cache (if (eq? er er-cache) r-cache (macros-only-env er))))
1076 (set-cdr!
1077 b
1078 (eval-local-transformer (expand (cddr b) r-cache '(()) mod) mod))
1079 (if (eq? (car b) 'syntax-parameter) (set-cdr! b (list (cdr b))))
1080 (loop (cdr bs) er r-cache))
1081 (loop (cdr bs) er-cache r-cache)))))
1082 (set-cdr! r (extend-env labels bindings (cdr r)))
1083 (build-letrec
1084 #f
1085 #t
1086 (reverse (map syntax->datum var-ids))
1087 (reverse vars)
1088 (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
1089 (build-sequence
1090 #f
1091 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1092 (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
1093 (expand-local-syntax
1094 (lambda (rec? e r w s mod k)
1095 (let* ((tmp e)
1096 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1097 (if tmp
1098 (apply (lambda (id val e1 e2)
1099 (let ((ids id))
1100 (if (not (valid-bound-ids? ids))
1101 (syntax-violation #f "duplicate bound keyword" e)
1102 (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
1103 (k (cons e1 e2)
1104 (extend-env
1105 labels
1106 (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
1107 (map (lambda (x)
1108 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1109 val))
1110 r)
1111 new-w
1112 s
1113 mod)))))
1114 tmp)
1115 (syntax-violation
1116 #f
1117 "bad local syntax definition"
1118 (source-wrap e w s mod))))))
1119 (eval-local-transformer
1120 (lambda (expanded mod)
1121 (let ((p (local-eval-hook expanded mod)))
1122 (if (procedure? p)
1123 p
1124 (syntax-violation #f "nonprocedure transformer" p)))))
1125 (expand-void (lambda () (build-void #f)))
1126 (ellipsis?
1127 (lambda (x)
1128 (and (nonsymbol-id? x)
1129 (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
1130 (lambda-formals
1131 (lambda (orig-args)
1132 (letrec*
1133 ((req (lambda (args rreq)
1134 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1135 (if tmp-1
1136 (apply (lambda () (check (reverse rreq) #f)) tmp-1)
1137 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1138 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1139 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1140 (let ((tmp-1 (list tmp)))
1141 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1142 (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
1143 (let ((else tmp))
1144 (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
1145 (check (lambda (req rest)
1146 (if (distinct-bound-ids? (if rest (cons rest req) req))
1147 (values req #f rest #f)
1148 (syntax-violation
1149 'lambda
1150 "duplicate identifier in argument list"
1151 orig-args)))))
1152 (req orig-args '()))))
1153 (expand-simple-lambda
1154 (lambda (e r w s mod req rest meta body)
1155 (let* ((ids (if rest (append req (list rest)) req))
1156 (vars (map gen-var ids))
1157 (labels (gen-labels ids)))
1158 (build-simple-lambda
1159 s
1160 (map syntax->datum req)
1161 (and rest (syntax->datum rest))
1162 vars
1163 meta
1164 (expand-body
1165 body
1166 (source-wrap e w s mod)
1167 (extend-var-env labels vars r)
1168 (make-binding-wrap ids labels w)
1169 mod)))))
1170 (lambda*-formals
1171 (lambda (orig-args)
1172 (letrec*
1173 ((req (lambda (args rreq)
1174 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1175 (if tmp-1
1176 (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
1177 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1178 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1179 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1180 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1181 (if (and tmp-1
1182 (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1))
1183 (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
1184 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1185 (if (and tmp-1
1186 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1187 (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
1188 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1189 (if (and tmp-1
1190 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1191 (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
1192 (let ((tmp-1 (list tmp)))
1193 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1194 (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
1195 (let ((else tmp))
1196 (syntax-violation
1197 'lambda*
1198 "invalid argument list"
1199 orig-args
1200 args))))))))))))))))
1201 (opt (lambda (args req ropt)
1202 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1203 (if tmp-1
1204 (apply (lambda () (check req (reverse ropt) #f '())) tmp-1)
1205 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1206 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1207 (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
1208 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1209 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1210 (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
1211 tmp-1)
1212 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1213 (if (and tmp-1
1214 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1215 (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
1216 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1217 (if (and tmp-1
1218 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1219 (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1)
1220 (let ((tmp-1 (list tmp)))
1221 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1222 (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1)
1223 (let ((else tmp))
1224 (syntax-violation
1225 'lambda*
1226 "invalid optional argument list"
1227 orig-args
1228 args))))))))))))))))
1229 (key (lambda (args req opt rkey)
1230 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1231 (if tmp-1
1232 (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1)
1233 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1234 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1235 (apply (lambda (a b)
1236 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1237 (key b req opt (cons (cons k (cons a '(#f))) rkey))))
1238 tmp-1)
1239 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1240 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1241 (apply (lambda (a init b)
1242 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1243 (key b req opt (cons (list k a init) rkey))))
1244 tmp-1)
1245 (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
1246 (if (and tmp-1
1247 (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
1248 tmp-1))
1249 (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
1250 tmp-1)
1251 (let ((tmp-1 ($sc-dispatch tmp '(any))))
1252 (if (and tmp-1
1253 (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys))
1254 tmp-1))
1255 (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
1256 tmp-1)
1257 (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
1258 (if (and tmp-1
1259 (apply (lambda (aok a b)
1260 (and (eq? (syntax->datum aok) #:allow-other-keys)
1261 (eq? (syntax->datum a) #:rest)))
1262 tmp-1))
1263 (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
1264 tmp-1)
1265 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1266 (if (and tmp-1
1267 (apply (lambda (aok r)
1268 (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r)))
1269 tmp-1))
1270 (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
1271 tmp-1)
1272 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1273 (if (and tmp-1
1274 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1275 (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
1276 tmp-1)
1277 (let ((tmp-1 (list tmp)))
1278 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1279 (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
1280 tmp-1)
1281 (let ((else tmp))
1282 (syntax-violation
1283 'lambda*
1284 "invalid keyword argument list"
1285 orig-args
1286 args))))))))))))))))))))))
1287 (rest (lambda (args req opt kw)
1288 (let* ((tmp-1 args) (tmp (list tmp-1)))
1289 (if (and tmp (apply (lambda (r) (id? r)) tmp))
1290 (apply (lambda (r) (check req opt r kw)) tmp)
1291 (let ((else tmp-1))
1292 (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
1293 (check (lambda (req opt rest kw)
1294 (if (distinct-bound-ids?
1295 (append
1296 req
1297 (map car opt)
1298 (if rest (list rest) '())
1299 (if (pair? kw) (map cadr (cdr kw)) '())))
1300 (values req opt rest kw)
1301 (syntax-violation
1302 'lambda*
1303 "duplicate identifier in argument list"
1304 orig-args)))))
1305 (req orig-args '()))))
1306 (expand-lambda-case
1307 (lambda (e r w s mod get-formals clauses)
1308 (letrec*
1309 ((parse-req
1310 (lambda (req opt rest kw body)
1311 (let ((vars (map gen-var req)) (labels (gen-labels req)))
1312 (let ((r* (extend-var-env labels vars r))
1313 (w* (make-binding-wrap req labels w)))
1314 (parse-opt
1315 (map syntax->datum req)
1316 opt
1317 rest
1318 kw
1319 body
1320 (reverse vars)
1321 r*
1322 w*
1323 '()
1324 '())))))
1325 (parse-opt
1326 (lambda (req opt rest kw body vars r* w* out inits)
1327 (cond ((pair? opt)
1328 (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
1329 (if tmp
1330 (apply (lambda (id i)
1331 (let* ((v (gen-var id))
1332 (l (gen-labels (list v)))
1333 (r** (extend-var-env l (list v) r*))
1334 (w** (make-binding-wrap (list id) l w*)))
1335 (parse-opt
1336 req
1337 (cdr opt)
1338 rest
1339 kw
1340 body
1341 (cons v vars)
1342 r**
1343 w**
1344 (cons (syntax->datum id) out)
1345 (cons (expand i r* w* mod) inits))))
1346 tmp)
1347 (syntax-violation
1348 #f
1349 "source expression failed to match any pattern"
1350 tmp-1))))
1351 (rest
1352 (let* ((v (gen-var rest))
1353 (l (gen-labels (list v)))
1354 (r* (extend-var-env l (list v) r*))
1355 (w* (make-binding-wrap (list rest) l w*)))
1356 (parse-kw
1357 req
1358 (and (pair? out) (reverse out))
1359 (syntax->datum rest)
1360 (if (pair? kw) (cdr kw) kw)
1361 body
1362 (cons v vars)
1363 r*
1364 w*
1365 (and (pair? kw) (car kw))
1366 '()
1367 inits)))
1368 (else
1369 (parse-kw
1370 req
1371 (and (pair? out) (reverse out))
1372 #f
1373 (if (pair? kw) (cdr kw) kw)
1374 body
1375 vars
1376 r*
1377 w*
1378 (and (pair? kw) (car kw))
1379 '()
1380 inits)))))
1381 (parse-kw
1382 (lambda (req opt rest kw body vars r* w* aok out inits)
1383 (if (pair? kw)
1384 (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
1385 (if tmp
1386 (apply (lambda (k id i)
1387 (let* ((v (gen-var id))
1388 (l (gen-labels (list v)))
1389 (r** (extend-var-env l (list v) r*))
1390 (w** (make-binding-wrap (list id) l w*)))
1391 (parse-kw
1392 req
1393 opt
1394 rest
1395 (cdr kw)
1396 body
1397 (cons v vars)
1398 r**
1399 w**
1400 aok
1401 (cons (list (syntax->datum k) (syntax->datum id) v) out)
1402 (cons (expand i r* w* mod) inits))))
1403 tmp)
1404 (syntax-violation
1405 #f
1406 "source expression failed to match any pattern"
1407 tmp-1)))
1408 (parse-body
1409 req
1410 opt
1411 rest
1412 (and (or aok (pair? out)) (cons aok (reverse out)))
1413 body
1414 (reverse vars)
1415 r*
1416 w*
1417 (reverse inits)
1418 '()))))
1419 (parse-body
1420 (lambda (req opt rest kw body vars r* w* inits meta)
1421 (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
1422 (if (and tmp-1
1423 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1424 tmp-1))
1425 (apply (lambda (docstring e1 e2)
1426 (parse-body
1427 req
1428 opt
1429 rest
1430 kw
1431 (cons e1 e2)
1432 vars
1433 r*
1434 w*
1435 inits
1436 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1437 tmp-1)
1438 (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
1439 (if tmp-1
1440 (apply (lambda (k v e1 e2)
1441 (parse-body
1442 req
1443 opt
1444 rest
1445 kw
1446 (cons e1 e2)
1447 vars
1448 r*
1449 w*
1450 inits
1451 (append meta (syntax->datum (map cons k v)))))
1452 tmp-1)
1453 (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
1454 (if tmp-1
1455 (apply (lambda (e1 e2)
1456 (values
1457 meta
1458 req
1459 opt
1460 rest
1461 kw
1462 inits
1463 vars
1464 (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
1465 tmp-1)
1466 (syntax-violation
1467 #f
1468 "source expression failed to match any pattern"
1469 tmp))))))))))
1470 (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
1471 (if tmp-1
1472 (apply (lambda () (values '() #f)) tmp-1)
1473 (let ((tmp-1 ($sc-dispatch
1474 tmp
1475 '((any any . each-any) . #(each (any any . each-any))))))
1476 (if tmp-1
1477 (apply (lambda (args e1 e2 args* e1* e2*)
1478 (call-with-values
1479 (lambda () (get-formals args))
1480 (lambda (req opt rest kw)
1481 (call-with-values
1482 (lambda () (parse-req req opt rest kw (cons e1 e2)))
1483 (lambda (meta req opt rest kw inits vars body)
1484 (call-with-values
1485 (lambda ()
1486 (expand-lambda-case
1487 e
1488 r
1489 w
1490 s
1491 mod
1492 get-formals
1493 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1494 e2*
1495 e1*
1496 args*)))
1497 (lambda (meta* else*)
1498 (values
1499 (append meta meta*)
1500 (build-lambda-case s req opt rest kw inits vars body else*)))))))))
1501 tmp-1)
1502 (syntax-violation
1503 #f
1504 "source expression failed to match any pattern"
1505 tmp))))))))
1506 (strip (lambda (x w)
1507 (if (memq 'top (car w))
1508 x
1509 (let f ((x x))
1510 (cond ((syntax-object? x)
1511 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1512 ((pair? x)
1513 (let ((a (f (car x))) (d (f (cdr x))))
1514 (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
1515 ((vector? x)
1516 (let* ((old (vector->list x)) (new (map f old)))
1517 (let lp ((l1 old) (l2 new))
1518 (cond ((null? l1) x)
1519 ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
1520 (else (list->vector new))))))
1521 (else x))))))
1522 (gen-var
1523 (lambda (id)
1524 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1525 (gensym (string-append (symbol->string id) "-")))))
1526 (lambda-var-list
1527 (lambda (vars)
1528 (let lvl ((vars vars) (ls '()) (w '(())))
1529 (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1530 ((id? vars) (cons (wrap vars w #f) ls))
1531 ((null? vars) ls)
1532 ((syntax-object? vars)
1533 (lvl (syntax-object-expression vars)
1534 ls
1535 (join-wraps w (syntax-object-wrap vars))))
1536 (else (cons vars ls)))))))
1537 (global-extend 'local-syntax 'letrec-syntax #t)
1538 (global-extend 'local-syntax 'let-syntax #f)
1539 (global-extend
1540 'core
1541 'syntax-parameterize
1542 (lambda (e r w s mod)
1543 (let* ((tmp e)
1544 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1545 (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
1546 (apply (lambda (var val e1 e2)
1547 (let ((names (map (lambda (x)
1548 (call-with-values
1549 (lambda () (resolve-identifier x w r mod #f))
1550 (lambda (type value mod)
1551 (let ((key type))
1552 (cond ((memv key '(displaced-lexical))
1553 (syntax-violation
1554 'syntax-parameterize
1555 "identifier out of context"
1556 e
1557 (source-wrap x w s mod)))
1558 ((memv key '(syntax-parameter)) value)
1559 (else
1560 (syntax-violation
1561 'syntax-parameterize
1562 "invalid syntax parameter"
1563 e
1564 (source-wrap x w s mod))))))))
1565 var))
1566 (bindings
1567 (let ((trans-r (macros-only-env r)))
1568 (map (lambda (x)
1569 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1570 val))))
1571 (expand-body
1572 (cons e1 e2)
1573 (source-wrap e w s mod)
1574 (extend-env names bindings r)
1575 w
1576 mod)))
1577 tmp)
1578 (syntax-violation
1579 'syntax-parameterize
1580 "bad syntax"
1581 (source-wrap e w s mod))))))
1582 (global-extend
1583 'core
1584 'quote
1585 (lambda (e r w s mod)
1586 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
1587 (if tmp
1588 (apply (lambda (e) (build-data s (strip e w))) tmp)
1589 (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
1590 (global-extend
1591 'core
1592 'syntax
1593 (letrec*
1594 ((gen-syntax
1595 (lambda (src e r maps ellipsis? mod)
1596 (if (id? e)
1597 (call-with-values
1598 (lambda () (resolve-identifier e '(()) r mod #f))
1599 (lambda (type value mod)
1600 (let ((key type))
1601 (cond ((memv key '(syntax))
1602 (call-with-values
1603 (lambda () (gen-ref src (car value) (cdr value) maps))
1604 (lambda (var maps) (values (list 'ref var) maps))))
1605 ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
1606 (else (values (list 'quote e) maps))))))
1607 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
1608 (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
1609 (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
1610 tmp-1)
1611 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
1612 (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
1613 (apply (lambda (x dots y)
1614 (let f ((y y)
1615 (k (lambda (maps)
1616 (call-with-values
1617 (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
1618 (lambda (x maps)
1619 (if (null? (car maps))
1620 (syntax-violation 'syntax "extra ellipsis" src)
1621 (values (gen-map x (car maps)) (cdr maps))))))))
1622 (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
1623 (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
1624 (apply (lambda (dots y)
1625 (f y
1626 (lambda (maps)
1627 (call-with-values
1628 (lambda () (k (cons '() maps)))
1629 (lambda (x maps)
1630 (if (null? (car maps))
1631 (syntax-violation 'syntax "extra ellipsis" src)
1632 (values (gen-mappend x (car maps)) (cdr maps))))))))
1633 tmp)
1634 (call-with-values
1635 (lambda () (gen-syntax src y r maps ellipsis? mod))
1636 (lambda (y maps)
1637 (call-with-values
1638 (lambda () (k maps))
1639 (lambda (x maps) (values (gen-append x y) maps)))))))))
1640 tmp-1)
1641 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1642 (if tmp-1
1643 (apply (lambda (x y)
1644 (call-with-values
1645 (lambda () (gen-syntax src x r maps ellipsis? mod))
1646 (lambda (x maps)
1647 (call-with-values
1648 (lambda () (gen-syntax src y r maps ellipsis? mod))
1649 (lambda (y maps) (values (gen-cons x y) maps))))))
1650 tmp-1)
1651 (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
1652 (if tmp
1653 (apply (lambda (e1 e2)
1654 (call-with-values
1655 (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
1656 (lambda (e maps) (values (gen-vector e) maps))))
1657 tmp)
1658 (values (list 'quote e) maps))))))))))))
1659 (gen-ref
1660 (lambda (src var level maps)
1661 (cond ((= level 0) (values var maps))
1662 ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
1663 (else
1664 (call-with-values
1665 (lambda () (gen-ref src var (- level 1) (cdr maps)))
1666 (lambda (outer-var outer-maps)
1667 (let ((b (assq outer-var (car maps))))
1668 (if b
1669 (values (cdr b) maps)
1670 (let ((inner-var (gen-var 'tmp)))
1671 (values
1672 inner-var
1673 (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
1674 (gen-mappend
1675 (lambda (e map-env)
1676 (list 'apply '(primitive append) (gen-map e map-env))))
1677 (gen-map
1678 (lambda (e map-env)
1679 (let ((formals (map cdr map-env))
1680 (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
1681 (cond ((eq? (car e) 'ref) (car actuals))
1682 ((and-map
1683 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1684 (cdr e))
1685 (cons 'map
1686 (cons (list 'primitive (car e))
1687 (map (let ((r (map cons formals actuals)))
1688 (lambda (x) (cdr (assq (cadr x) r))))
1689 (cdr e)))))
1690 (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
1691 (gen-cons
1692 (lambda (x y)
1693 (let ((key (car y)))
1694 (cond ((memv key '(quote))
1695 (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
1696 ((eq? (cadr y) '()) (list 'list x))
1697 (else (list 'cons x y))))
1698 ((memv key '(list)) (cons 'list (cons x (cdr y))))
1699 (else (list 'cons x y))))))
1700 (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
1701 (gen-vector
1702 (lambda (x)
1703 (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
1704 ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
1705 (else (list 'list->vector x)))))
1706 (regen (lambda (x)
1707 (let ((key (car x)))
1708 (cond ((memv key '(ref))
1709 (build-lexical-reference 'value #f (cadr x) (cadr x)))
1710 ((memv key '(primitive)) (build-primref #f (cadr x)))
1711 ((memv key '(quote)) (build-data #f (cadr x)))
1712 ((memv key '(lambda))
1713 (if (list? (cadr x))
1714 (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
1715 (error "how did we get here" x)))
1716 (else (build-primcall #f (car x) (map regen (cdr x)))))))))
1717 (lambda (e r w s mod)
1718 (let* ((e (source-wrap e w s mod))
1719 (tmp e)
1720 (tmp ($sc-dispatch tmp '(_ any))))
1721 (if tmp
1722 (apply (lambda (x)
1723 (call-with-values
1724 (lambda () (gen-syntax e x r '() ellipsis? mod))
1725 (lambda (e maps) (regen e))))
1726 tmp)
1727 (syntax-violation 'syntax "bad `syntax' form" e))))))
1728 (global-extend
1729 'core
1730 'lambda
1731 (lambda (e r w s mod)
1732 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1733 (if tmp
1734 (apply (lambda (args e1 e2)
1735 (call-with-values
1736 (lambda () (lambda-formals args))
1737 (lambda (req opt rest kw)
1738 (let lp ((body (cons e1 e2)) (meta '()))
1739 (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
1740 (if (and tmp
1741 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1742 tmp))
1743 (apply (lambda (docstring e1 e2)
1744 (lp (cons e1 e2)
1745 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1746 tmp)
1747 (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
1748 (if tmp
1749 (apply (lambda (k v e1 e2)
1750 (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
1751 tmp)
1752 (expand-simple-lambda e r w s mod req rest meta body)))))))))
1753 tmp)
1754 (syntax-violation 'lambda "bad lambda" e)))))
1755 (global-extend
1756 'core
1757 'lambda*
1758 (lambda (e r w s mod)
1759 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1760 (if tmp
1761 (apply (lambda (args e1 e2)
1762 (call-with-values
1763 (lambda ()
1764 (expand-lambda-case
1765 e
1766 r
1767 w
1768 s
1769 mod
1770 lambda*-formals
1771 (list (cons args (cons e1 e2)))))
1772 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1773 tmp)
1774 (syntax-violation 'lambda "bad lambda*" e)))))
1775 (global-extend
1776 'core
1777 'case-lambda
1778 (lambda (e r w s mod)
1779 (let* ((tmp e)
1780 (tmp ($sc-dispatch
1781 tmp
1782 '(_ (any any . each-any) . #(each (any any . each-any))))))
1783 (if tmp
1784 (apply (lambda (args e1 e2 args* e1* e2*)
1785 (call-with-values
1786 (lambda ()
1787 (expand-lambda-case
1788 e
1789 r
1790 w
1791 s
1792 mod
1793 lambda-formals
1794 (cons (cons args (cons e1 e2))
1795 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1796 e2*
1797 e1*
1798 args*))))
1799 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1800 tmp)
1801 (syntax-violation 'case-lambda "bad case-lambda" e)))))
1802 (global-extend
1803 'core
1804 'case-lambda*
1805 (lambda (e r w s mod)
1806 (let* ((tmp e)
1807 (tmp ($sc-dispatch
1808 tmp
1809 '(_ (any any . each-any) . #(each (any any . each-any))))))
1810 (if tmp
1811 (apply (lambda (args e1 e2 args* e1* e2*)
1812 (call-with-values
1813 (lambda ()
1814 (expand-lambda-case
1815 e
1816 r
1817 w
1818 s
1819 mod
1820 lambda*-formals
1821 (cons (cons args (cons e1 e2))
1822 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1823 e2*
1824 e1*
1825 args*))))
1826 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1827 tmp)
1828 (syntax-violation 'case-lambda "bad case-lambda*" e)))))
1829 (global-extend
1830 'core
1831 'let
1832 (letrec*
1833 ((expand-let
1834 (lambda (e r w s mod constructor ids vals exps)
1835 (if (not (valid-bound-ids? ids))
1836 (syntax-violation 'let "duplicate bound variable" e)
1837 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1838 (let ((nw (make-binding-wrap ids labels w))
1839 (nr (extend-var-env labels new-vars r)))
1840 (constructor
1841 s
1842 (map syntax->datum ids)
1843 new-vars
1844 (map (lambda (x) (expand x r w mod)) vals)
1845 (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
1846 (lambda (e r w s mod)
1847 (let* ((tmp-1 e)
1848 (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
1849 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1850 (apply (lambda (id val e1 e2)
1851 (expand-let e r w s mod build-let id val (cons e1 e2)))
1852 tmp)
1853 (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
1854 (if (and tmp
1855 (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
1856 (apply (lambda (f id val e1 e2)
1857 (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
1858 tmp)
1859 (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
1860 (global-extend
1861 'core
1862 'letrec
1863 (lambda (e r w s mod)
1864 (let* ((tmp e)
1865 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1866 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1867 (apply (lambda (id val e1 e2)
1868 (let ((ids id))
1869 (if (not (valid-bound-ids? ids))
1870 (syntax-violation 'letrec "duplicate bound variable" e)
1871 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1872 (let ((w (make-binding-wrap ids labels w))
1873 (r (extend-var-env labels new-vars r)))
1874 (build-letrec
1875 s
1876 #f
1877 (map syntax->datum ids)
1878 new-vars
1879 (map (lambda (x) (expand x r w mod)) val)
1880 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1881 tmp)
1882 (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
1883 (global-extend
1884 'core
1885 'letrec*
1886 (lambda (e r w s mod)
1887 (let* ((tmp e)
1888 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1889 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1890 (apply (lambda (id val e1 e2)
1891 (let ((ids id))
1892 (if (not (valid-bound-ids? ids))
1893 (syntax-violation 'letrec* "duplicate bound variable" e)
1894 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1895 (let ((w (make-binding-wrap ids labels w))
1896 (r (extend-var-env labels new-vars r)))
1897 (build-letrec
1898 s
1899 #t
1900 (map syntax->datum ids)
1901 new-vars
1902 (map (lambda (x) (expand x r w mod)) val)
1903 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1904 tmp)
1905 (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
1906 (global-extend
1907 'core
1908 'set!
1909 (lambda (e r w s mod)
1910 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
1911 (if (and tmp (apply (lambda (id val) (id? id)) tmp))
1912 (apply (lambda (id val)
1913 (call-with-values
1914 (lambda () (resolve-identifier id w r mod #t))
1915 (lambda (type value id-mod)
1916 (let ((key type))
1917 (cond ((memv key '(lexical))
1918 (build-lexical-assignment
1919 s
1920 (syntax->datum id)
1921 value
1922 (expand val r w mod)))
1923 ((memv key '(global))
1924 (build-global-assignment s value (expand val r w mod) id-mod))
1925 ((memv key '(macro))
1926 (if (procedure-property value 'variable-transformer)
1927 (expand (expand-macro value e r w s #f mod) r '(()) mod)
1928 (syntax-violation
1929 'set!
1930 "not a variable transformer"
1931 (wrap e w mod)
1932 (wrap id w id-mod))))
1933 ((memv key '(displaced-lexical))
1934 (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
1935 (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1936 tmp)
1937 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
1938 (if tmp
1939 (apply (lambda (head tail val)
1940 (call-with-values
1941 (lambda () (syntax-type head r '(()) #f #f mod #t))
1942 (lambda (type value ee* ee ww ss modmod)
1943 (let ((key type))
1944 (if (memv key '(module-ref))
1945 (let ((val (expand val r w mod)))
1946 (call-with-values
1947 (lambda () (value (cons head tail) r w))
1948 (lambda (e r w s* mod)
1949 (let* ((tmp-1 e) (tmp (list tmp-1)))
1950 (if (and tmp (apply (lambda (e) (id? e)) tmp))
1951 (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
1952 tmp)
1953 (syntax-violation
1954 #f
1955 "source expression failed to match any pattern"
1956 tmp-1))))))
1957 (build-call
1958 s
1959 (expand
1960 (list '#(syntax-object setter ((top)) (hygiene guile)) head)
1961 r
1962 w
1963 mod)
1964 (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
1965 tmp)
1966 (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1967 (global-extend
1968 'module-ref
1969 '@
1970 (lambda (e r w)
1971 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
1972 (if (and tmp
1973 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
1974 (apply (lambda (mod id)
1975 (values
1976 (syntax->datum id)
1977 r
1978 '((top))
1979 #f
1980 (syntax->datum
1981 (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
1982 tmp)
1983 (syntax-violation
1984 #f
1985 "source expression failed to match any pattern"
1986 tmp-1)))))
1987 (global-extend
1988 'module-ref
1989 '@@
1990 (lambda (e r w)
1991 (letrec*
1992 ((remodulate
1993 (lambda (x mod)
1994 (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
1995 ((syntax-object? x)
1996 (make-syntax-object
1997 (remodulate (syntax-object-expression x) mod)
1998 (syntax-object-wrap x)
1999 mod))
2000 ((vector? x)
2001 (let* ((n (vector-length x)) (v (make-vector n)))
2002 (let loop ((i 0))
2003 (if (= i n)
2004 (begin (if #f #f) v)
2005 (begin
2006 (vector-set! v i (remodulate (vector-ref x i) mod))
2007 (loop (+ i 1)))))))
2008 (else x)))))
2009 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
2010 (if (and tmp
2011 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
2012 (apply (lambda (mod id)
2013 (values
2014 (syntax->datum id)
2015 r
2016 '((top))
2017 #f
2018 (syntax->datum
2019 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2020 tmp)
2021 (let ((tmp ($sc-dispatch
2022 tmp-1
2023 '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
2024 each-any
2025 any))))
2026 (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
2027 (apply (lambda (mod exp)
2028 (let ((mod (syntax->datum
2029 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2030 (values (remodulate exp mod) r w (source-annotation exp) mod)))
2031 tmp)
2032 (syntax-violation
2033 #f
2034 "source expression failed to match any pattern"
2035 tmp-1))))))))
2036 (global-extend
2037 'core
2038 'if
2039 (lambda (e r w s mod)
2040 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
2041 (if tmp-1
2042 (apply (lambda (test then)
2043 (build-conditional
2044 s
2045 (expand test r w mod)
2046 (expand then r w mod)
2047 (build-void #f)))
2048 tmp-1)
2049 (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
2050 (if tmp-1
2051 (apply (lambda (test then else)
2052 (build-conditional
2053 s
2054 (expand test r w mod)
2055 (expand then r w mod)
2056 (expand else r w mod)))
2057 tmp-1)
2058 (syntax-violation
2059 #f
2060 "source expression failed to match any pattern"
2061 tmp)))))))
2062 (global-extend
2063 'core
2064 'with-fluids
2065 (lambda (e r w s mod)
2066 (let* ((tmp-1 e)
2067 (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
2068 (if tmp
2069 (apply (lambda (fluid val b b*)
2070 (build-dynlet
2071 s
2072 (map (lambda (x) (expand x r w mod)) fluid)
2073 (map (lambda (x) (expand x r w mod)) val)
2074 (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
2075 tmp)
2076 (syntax-violation
2077 #f
2078 "source expression failed to match any pattern"
2079 tmp-1)))))
2080 (global-extend 'begin 'begin '())
2081 (global-extend 'define 'define '())
2082 (global-extend 'define-syntax 'define-syntax '())
2083 (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
2084 (global-extend 'eval-when 'eval-when '())
2085 (global-extend
2086 'core
2087 'syntax-case
2088 (letrec*
2089 ((convert-pattern
2090 (lambda (pattern keys)
2091 (letrec*
2092 ((cvt* (lambda (p* n ids)
2093 (if (not (pair? p*))
2094 (cvt p* n ids)
2095 (call-with-values
2096 (lambda () (cvt* (cdr p*) n ids))
2097 (lambda (y ids)
2098 (call-with-values
2099 (lambda () (cvt (car p*) n ids))
2100 (lambda (x ids) (values (cons x y) ids))))))))
2101 (v-reverse
2102 (lambda (x)
2103 (let loop ((r '()) (x x))
2104 (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
2105 (cvt (lambda (p n ids)
2106 (if (id? p)
2107 (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
2108 ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
2109 (values '_ ids))
2110 (else (values 'any (cons (cons p n) ids))))
2111 (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
2112 (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
2113 (apply (lambda (x dots)
2114 (call-with-values
2115 (lambda () (cvt x (+ n 1) ids))
2116 (lambda (p ids)
2117 (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
2118 tmp-1)
2119 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
2120 (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
2121 (apply (lambda (x dots ys)
2122 (call-with-values
2123 (lambda () (cvt* ys n ids))
2124 (lambda (ys ids)
2125 (call-with-values
2126 (lambda () (cvt x (+ n 1) ids))
2127 (lambda (x ids)
2128 (call-with-values
2129 (lambda () (v-reverse ys))
2130 (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
2131 tmp-1)
2132 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2133 (if tmp-1
2134 (apply (lambda (x y)
2135 (call-with-values
2136 (lambda () (cvt y n ids))
2137 (lambda (y ids)
2138 (call-with-values
2139 (lambda () (cvt x n ids))
2140 (lambda (x ids) (values (cons x y) ids))))))
2141 tmp-1)
2142 (let ((tmp-1 ($sc-dispatch tmp '())))
2143 (if tmp-1
2144 (apply (lambda () (values '() ids)) tmp-1)
2145 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2146 (if tmp-1
2147 (apply (lambda (x)
2148 (call-with-values
2149 (lambda () (cvt x n ids))
2150 (lambda (p ids) (values (vector 'vector p) ids))))
2151 tmp-1)
2152 (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
2153 (cvt pattern 0 '()))))
2154 (build-dispatch-call
2155 (lambda (pvars exp y r mod)
2156 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2157 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2158 (build-primcall
2159 #f
2160 'apply
2161 (list (build-simple-lambda
2162 #f
2163 (map syntax->datum ids)
2164 #f
2165 new-vars
2166 '()
2167 (expand
2168 exp
2169 (extend-env
2170 labels
2171 (map (lambda (var level) (cons 'syntax (cons var level)))
2172 new-vars
2173 (map cdr pvars))
2174 r)
2175 (make-binding-wrap ids labels '(()))
2176 mod))
2177 y))))))
2178 (gen-clause
2179 (lambda (x keys clauses r pat fender exp mod)
2180 (call-with-values
2181 (lambda () (convert-pattern pat keys))
2182 (lambda (p pvars)
2183 (cond ((not (distinct-bound-ids? (map car pvars)))
2184 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2185 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2186 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2187 (else
2188 (let ((y (gen-var 'tmp)))
2189 (build-call
2190 #f
2191 (build-simple-lambda
2192 #f
2193 (list 'tmp)
2194 #f
2195 (list y)
2196 '()
2197 (let ((y (build-lexical-reference 'value #f 'tmp y)))
2198 (build-conditional
2199 #f
2200 (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
2201 (if tmp
2202 (apply (lambda () y) tmp)
2203 (build-conditional
2204 #f
2205 y
2206 (build-dispatch-call pvars fender y r mod)
2207 (build-data #f #f))))
2208 (build-dispatch-call pvars exp y r mod)
2209 (gen-syntax-case x keys clauses r mod))))
2210 (list (if (eq? p 'any)
2211 (build-primcall #f 'list (list x))
2212 (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
2213 (gen-syntax-case
2214 (lambda (x keys clauses r mod)
2215 (if (null? clauses)
2216 (build-primcall
2217 #f
2218 'syntax-violation
2219 (list (build-data #f #f)
2220 (build-data #f "source expression failed to match any pattern")
2221 x))
2222 (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
2223 (if tmp
2224 (apply (lambda (pat exp)
2225 (if (and (id? pat)
2226 (and-map
2227 (lambda (x) (not (free-id=? pat x)))
2228 (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
2229 (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
2230 (expand exp r '(()) mod)
2231 (let ((labels (list (gen-label))) (var (gen-var pat)))
2232 (build-call
2233 #f
2234 (build-simple-lambda
2235 #f
2236 (list (syntax->datum pat))
2237 #f
2238 (list var)
2239 '()
2240 (expand
2241 exp
2242 (extend-env labels (list (cons 'syntax (cons var 0))) r)
2243 (make-binding-wrap (list pat) labels '(()))
2244 mod))
2245 (list x))))
2246 (gen-clause x keys (cdr clauses) r pat #t exp mod)))
2247 tmp)
2248 (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
2249 (if tmp
2250 (apply (lambda (pat fender exp)
2251 (gen-clause x keys (cdr clauses) r pat fender exp mod))
2252 tmp)
2253 (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
2254 (lambda (e r w s mod)
2255 (let* ((e (source-wrap e w s mod))
2256 (tmp-1 e)
2257 (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
2258 (if tmp
2259 (apply (lambda (val key m)
2260 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
2261 (let ((x (gen-var 'tmp)))
2262 (build-call
2263 s
2264 (build-simple-lambda
2265 #f
2266 (list 'tmp)
2267 #f
2268 (list x)
2269 '()
2270 (gen-syntax-case
2271 (build-lexical-reference 'value #f 'tmp x)
2272 key
2273 m
2274 r
2275 mod))
2276 (list (expand val r '(()) mod))))
2277 (syntax-violation 'syntax-case "invalid literals list" e)))
2278 tmp)
2279 (syntax-violation
2280 #f
2281 "source expression failed to match any pattern"
2282 tmp-1))))))
2283 (set! macroexpand
2284 (lambda* (x #:optional (m 'e) (esew '(eval)))
2285 (expand-top-sequence
2286 (list x)
2287 '()
2288 '((top))
2289 #f
2290 m
2291 esew
2292 (cons 'hygiene (module-name (current-module))))))
2293 (set! identifier? (lambda (x) (nonsymbol-id? x)))
2294 (set! datum->syntax
2295 (lambda (id datum)
2296 (make-syntax-object
2297 datum
2298 (syntax-object-wrap id)
2299 (syntax-object-module id))))
2300 (set! syntax->datum (lambda (x) (strip x '(()))))
2301 (set! syntax-source (lambda (x) (source-annotation x)))
2302 (set! generate-temporaries
2303 (lambda (ls)
2304 (let ((x ls))
2305 (if (not (list? x))
2306 (syntax-violation 'generate-temporaries "invalid argument" x)))
2307 (let ((mod (cons 'hygiene (module-name (current-module)))))
2308 (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
2309 (set! free-identifier=?
2310 (lambda (x y)
2311 (let ((x x))
2312 (if (not (nonsymbol-id? x))
2313 (syntax-violation 'free-identifier=? "invalid argument" x)))
2314 (let ((x y))
2315 (if (not (nonsymbol-id? x))
2316 (syntax-violation 'free-identifier=? "invalid argument" x)))
2317 (free-id=? x y)))
2318 (set! bound-identifier=?
2319 (lambda (x y)
2320 (let ((x x))
2321 (if (not (nonsymbol-id? x))
2322 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2323 (let ((x y))
2324 (if (not (nonsymbol-id? x))
2325 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2326 (bound-id=? x y)))
2327 (set! syntax-violation
2328 (lambda* (who message form #:optional (subform #f))
2329 (let ((x who))
2330 (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
2331 (syntax-violation 'syntax-violation "invalid argument" x)))
2332 (let ((x message))
2333 (if (not (string? x))
2334 (syntax-violation 'syntax-violation "invalid argument" x)))
2335 (throw 'syntax-error
2336 who
2337 message
2338 (or (source-annotation subform) (source-annotation form))
2339 (strip form '(()))
2340 (and subform (strip subform '(()))))))
2341 (letrec*
2342 ((syntax-module
2343 (lambda (id)
2344 (let ((x id))
2345 (if (not (nonsymbol-id? x))
2346 (syntax-violation 'syntax-module "invalid argument" x)))
2347 (cdr (syntax-object-module id))))
2348 (syntax-local-binding
2349 (lambda (id)
2350 (let ((x id))
2351 (if (not (nonsymbol-id? x))
2352 (syntax-violation 'syntax-local-binding "invalid argument" x)))
2353 (with-transformer-environment
2354 (lambda (e r w s rib mod)
2355 (letrec*
2356 ((strip-anti-mark
2357 (lambda (w)
2358 (let ((ms (car w)) (s (cdr w)))
2359 (if (and (pair? ms) (eq? (car ms) #f))
2360 (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
2361 (cons ms (if rib (cons rib s) s)))))))
2362 (call-with-values
2363 (lambda ()
2364 (resolve-identifier
2365 (syntax-object-expression id)
2366 (strip-anti-mark (syntax-object-wrap id))
2367 r
2368 (syntax-object-module id)
2369 #t))
2370 (lambda (type value mod)
2371 (let ((key type))
2372 (cond ((memv key '(lexical)) (values 'lexical value))
2373 ((memv key '(macro)) (values 'macro value))
2374 ((memv key '(syntax)) (values 'pattern-variable value))
2375 ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
2376 ((memv key '(global)) (values 'global (cons value (cdr mod))))
2377 (else (values 'other #f)))))))))))
2378 (syntax-locally-bound-identifiers
2379 (lambda (id)
2380 (let ((x id))
2381 (if (not (nonsymbol-id? x))
2382 (syntax-violation
2383 'syntax-locally-bound-identifiers
2384 "invalid argument"
2385 x)))
2386 (locally-bound-identifiers
2387 (syntax-object-wrap id)
2388 (syntax-object-module id)))))
2389 (define! 'syntax-module syntax-module)
2390 (define! 'syntax-local-binding syntax-local-binding)
2391 (define!
2392 'syntax-locally-bound-identifiers
2393 syntax-locally-bound-identifiers))
2394 (letrec*
2395 ((match-each
2396 (lambda (e p w mod)
2397 (cond ((pair? e)
2398 (let ((first (match (car e) p w '() mod)))
2399 (and first
2400 (let ((rest (match-each (cdr e) p w mod)))
2401 (and rest (cons first rest))))))
2402 ((null? e) '())
2403 ((syntax-object? e)
2404 (match-each
2405 (syntax-object-expression e)
2406 p
2407 (join-wraps w (syntax-object-wrap e))
2408 (syntax-object-module e)))
2409 (else #f))))
2410 (match-each+
2411 (lambda (e x-pat y-pat z-pat w r mod)
2412 (let f ((e e) (w w))
2413 (cond ((pair? e)
2414 (call-with-values
2415 (lambda () (f (cdr e) w))
2416 (lambda (xr* y-pat r)
2417 (if r
2418 (if (null? y-pat)
2419 (let ((xr (match (car e) x-pat w '() mod)))
2420 (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
2421 (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
2422 (values #f #f #f)))))
2423 ((syntax-object? e)
2424 (f (syntax-object-expression e) (join-wraps w e)))
2425 (else (values '() y-pat (match e z-pat w r mod)))))))
2426 (match-each-any
2427 (lambda (e w mod)
2428 (cond ((pair? e)
2429 (let ((l (match-each-any (cdr e) w mod)))
2430 (and l (cons (wrap (car e) w mod) l))))
2431 ((null? e) '())
2432 ((syntax-object? e)
2433 (match-each-any
2434 (syntax-object-expression e)
2435 (join-wraps w (syntax-object-wrap e))
2436 mod))
2437 (else #f))))
2438 (match-empty
2439 (lambda (p r)
2440 (cond ((null? p) r)
2441 ((eq? p '_) r)
2442 ((eq? p 'any) (cons '() r))
2443 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2444 ((eq? p 'each-any) (cons '() r))
2445 (else
2446 (let ((key (vector-ref p 0)))
2447 (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
2448 ((memv key '(each+))
2449 (match-empty
2450 (vector-ref p 1)
2451 (match-empty
2452 (reverse (vector-ref p 2))
2453 (match-empty (vector-ref p 3) r))))
2454 ((memv key '(free-id atom)) r)
2455 ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
2456 (combine
2457 (lambda (r* r)
2458 (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
2459 (match*
2460 (lambda (e p w r mod)
2461 (cond ((null? p) (and (null? e) r))
2462 ((pair? p)
2463 (and (pair? e)
2464 (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
2465 ((eq? p 'each-any)
2466 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2467 (else
2468 (let ((key (vector-ref p 0)))
2469 (cond ((memv key '(each))
2470 (if (null? e)
2471 (match-empty (vector-ref p 1) r)
2472 (let ((l (match-each e (vector-ref p 1) w mod)))
2473 (and l
2474 (let collect ((l l))
2475 (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
2476 ((memv key '(each+))
2477 (call-with-values
2478 (lambda ()
2479 (match-each+
2480 e
2481 (vector-ref p 1)
2482 (vector-ref p 2)
2483 (vector-ref p 3)
2484 w
2485 r
2486 mod))
2487 (lambda (xr* y-pat r)
2488 (and r
2489 (null? y-pat)
2490 (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
2491 ((memv key '(free-id))
2492 (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2493 ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
2494 ((memv key '(vector))
2495 (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
2496 (match (lambda (e p w r mod)
2497 (cond ((not r) #f)
2498 ((eq? p '_) r)
2499 ((eq? p 'any) (cons (wrap e w mod) r))
2500 ((syntax-object? e)
2501 (match*
2502 (syntax-object-expression e)
2503 p
2504 (join-wraps w (syntax-object-wrap e))
2505 r
2506 (syntax-object-module e)))
2507 (else (match* e p w r mod))))))
2508 (set! $sc-dispatch
2509 (lambda (e p)
2510 (cond ((eq? p 'any) (list e))
2511 ((eq? p '_) '())
2512 ((syntax-object? e)
2513 (match*
2514 (syntax-object-expression e)
2515 p
2516 (syntax-object-wrap e)
2517 '()
2518 (syntax-object-module e)))
2519 (else (match* e p '(()) '() #f)))))))
2520
2521 (define with-syntax
2522 (make-syntax-transformer
2523 'with-syntax
2524 'macro
2525 (lambda (x)
2526 (let ((tmp x))
2527 (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
2528 (if tmp-1
2529 (apply (lambda (e1 e2)
2530 (cons '#(syntax-object let ((top)) (hygiene guile))
2531 (cons '() (cons e1 e2))))
2532 tmp-1)
2533 (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
2534 (if tmp-1
2535 (apply (lambda (out in e1 e2)
2536 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2537 in
2538 '()
2539 (list out
2540 (cons '#(syntax-object let ((top)) (hygiene guile))
2541 (cons '() (cons e1 e2))))))
2542 tmp-1)
2543 (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
2544 (if tmp-1
2545 (apply (lambda (out in e1 e2)
2546 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2547 (cons '#(syntax-object list ((top)) (hygiene guile)) in)
2548 '()
2549 (list out
2550 (cons '#(syntax-object let ((top)) (hygiene guile))
2551 (cons '() (cons e1 e2))))))
2552 tmp-1)
2553 (syntax-violation
2554 #f
2555 "source expression failed to match any pattern"
2556 tmp)))))))))))
2557
2558 (define syntax-rules
2559 (make-syntax-transformer
2560 'syntax-rules
2561 'macro
2562 (lambda (xx)
2563 (let ((tmp-1 xx))
2564 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
2565 (if tmp
2566 (apply (lambda (k keyword pattern template)
2567 (list '#(syntax-object lambda ((top)) (hygiene guile))
2568 '(#(syntax-object x ((top)) (hygiene guile)))
2569 (vector
2570 '(#(syntax-object macro-type ((top)) (hygiene guile))
2571 .
2572 #(syntax-object
2573 syntax-rules
2574 ((top)
2575 #(ribcage
2576 #(syntax-rules)
2577 #((top))
2578 #(((hygiene guile)
2579 .
2580 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2581 (hygiene guile)))
2582 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2583 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2584 (cons '#(syntax-object x ((top)) (hygiene guile))
2585 (cons k
2586 (map (lambda (tmp-1 tmp)
2587 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2588 (list '#(syntax-object syntax ((top)) (hygiene guile))
2589 tmp-1)))
2590 template
2591 pattern))))))
2592 tmp)
2593 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
2594 (if (if tmp
2595 (apply (lambda (k docstring keyword pattern template)
2596 (string? (syntax->datum docstring)))
2597 tmp)
2598 #f)
2599 (apply (lambda (k docstring keyword pattern template)
2600 (list '#(syntax-object lambda ((top)) (hygiene guile))
2601 '(#(syntax-object x ((top)) (hygiene guile)))
2602 docstring
2603 (vector
2604 '(#(syntax-object macro-type ((top)) (hygiene guile))
2605 .
2606 #(syntax-object
2607 syntax-rules
2608 ((top)
2609 #(ribcage
2610 #(syntax-rules)
2611 #((top))
2612 #(((hygiene guile)
2613 .
2614 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2615 (hygiene guile)))
2616 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2617 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2618 (cons '#(syntax-object x ((top)) (hygiene guile))
2619 (cons k
2620 (map (lambda (tmp-1 tmp)
2621 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2622 (list '#(syntax-object syntax ((top)) (hygiene guile))
2623 tmp-1)))
2624 template
2625 pattern))))))
2626 tmp)
2627 (syntax-violation
2628 #f
2629 "source expression failed to match any pattern"
2630 tmp-1)))))))))
2631
2632 (define define-syntax-rule
2633 (make-syntax-transformer
2634 'define-syntax-rule
2635 'macro
2636 (lambda (x)
2637 (let ((tmp-1 x))
2638 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
2639 (if tmp
2640 (apply (lambda (name pattern template)
2641 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2642 name
2643 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2644 '()
2645 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2646 template))))
2647 tmp)
2648 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
2649 (if (if tmp
2650 (apply (lambda (name pattern docstring template)
2651 (string? (syntax->datum docstring)))
2652 tmp)
2653 #f)
2654 (apply (lambda (name pattern docstring template)
2655 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2656 name
2657 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2658 '()
2659 docstring
2660 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2661 template))))
2662 tmp)
2663 (syntax-violation
2664 #f
2665 "source expression failed to match any pattern"
2666 tmp-1)))))))))
2667
2668 (define let*
2669 (make-syntax-transformer
2670 'let*
2671 'macro
2672 (lambda (x)
2673 (let ((tmp-1 x))
2674 (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
2675 (if (if tmp
2676 (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
2677 #f)
2678 (apply (lambda (let* x v e1 e2)
2679 (let f ((bindings (map list x v)))
2680 (if (null? bindings)
2681 (cons '#(syntax-object let ((top)) (hygiene guile))
2682 (cons '() (cons e1 e2)))
2683 (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
2684 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2685 (if tmp
2686 (apply (lambda (body binding)
2687 (list '#(syntax-object let ((top)) (hygiene guile))
2688 (list binding)
2689 body))
2690 tmp)
2691 (syntax-violation
2692 #f
2693 "source expression failed to match any pattern"
2694 tmp-1)))))))
2695 tmp)
2696 (syntax-violation
2697 #f
2698 "source expression failed to match any pattern"
2699 tmp-1)))))))
2700
2701 (define quasiquote
2702 (make-syntax-transformer
2703 'quasiquote
2704 'macro
2705 (letrec*
2706 ((quasi (lambda (p lev)
2707 (let ((tmp p))
2708 (let ((tmp-1 ($sc-dispatch
2709 tmp
2710 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
2711 (if tmp-1
2712 (apply (lambda (p)
2713 (if (= lev 0)
2714 (list "value" p)
2715 (quasicons
2716 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2717 (quasi (list p) (- lev 1)))))
2718 tmp-1)
2719 (let ((tmp-1 ($sc-dispatch
2720 tmp
2721 '(#(free-id
2722 #(syntax-object
2723 quasiquote
2724 ((top)
2725 #(ribcage
2726 #(quasiquote)
2727 #((top))
2728 #(((hygiene guile)
2729 .
2730 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2731 (hygiene guile)))
2732 any))))
2733 (if tmp-1
2734 (apply (lambda (p)
2735 (quasicons
2736 '("quote"
2737 #(syntax-object
2738 quasiquote
2739 ((top)
2740 #(ribcage
2741 #(quasiquote)
2742 #((top))
2743 #(((hygiene guile)
2744 .
2745 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2746 (hygiene guile)))
2747 (quasi (list p) (+ lev 1))))
2748 tmp-1)
2749 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2750 (if tmp-1
2751 (apply (lambda (p q)
2752 (let ((tmp-1 p))
2753 (let ((tmp ($sc-dispatch
2754 tmp-1
2755 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2756 .
2757 each-any))))
2758 (if tmp
2759 (apply (lambda (p)
2760 (if (= lev 0)
2761 (quasilist*
2762 (map (lambda (tmp) (list "value" tmp)) p)
2763 (quasi q lev))
2764 (quasicons
2765 (quasicons
2766 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2767 (quasi p (- lev 1)))
2768 (quasi q lev))))
2769 tmp)
2770 (let ((tmp ($sc-dispatch
2771 tmp-1
2772 '(#(free-id
2773 #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2774 .
2775 each-any))))
2776 (if tmp
2777 (apply (lambda (p)
2778 (if (= lev 0)
2779 (quasiappend
2780 (map (lambda (tmp) (list "value" tmp)) p)
2781 (quasi q lev))
2782 (quasicons
2783 (quasicons
2784 '("quote"
2785 #(syntax-object
2786 unquote-splicing
2787 ((top))
2788 (hygiene guile)))
2789 (quasi p (- lev 1)))
2790 (quasi q lev))))
2791 tmp)
2792 (quasicons (quasi p lev) (quasi q lev))))))))
2793 tmp-1)
2794 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2795 (if tmp-1
2796 (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
2797 (let ((p tmp)) (list "quote" p)))))))))))))
2798 (vquasi
2799 (lambda (p lev)
2800 (let ((tmp p))
2801 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2802 (if tmp-1
2803 (apply (lambda (p q)
2804 (let ((tmp-1 p))
2805 (let ((tmp ($sc-dispatch
2806 tmp-1
2807 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2808 .
2809 each-any))))
2810 (if tmp
2811 (apply (lambda (p)
2812 (if (= lev 0)
2813 (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
2814 (quasicons
2815 (quasicons
2816 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2817 (quasi p (- lev 1)))
2818 (vquasi q lev))))
2819 tmp)
2820 (let ((tmp ($sc-dispatch
2821 tmp-1
2822 '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2823 .
2824 each-any))))
2825 (if tmp
2826 (apply (lambda (p)
2827 (if (= lev 0)
2828 (quasiappend
2829 (map (lambda (tmp) (list "value" tmp)) p)
2830 (vquasi q lev))
2831 (quasicons
2832 (quasicons
2833 '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2834 (quasi p (- lev 1)))
2835 (vquasi q lev))))
2836 tmp)
2837 (quasicons (quasi p lev) (vquasi q lev))))))))
2838 tmp-1)
2839 (let ((tmp-1 ($sc-dispatch tmp '())))
2840 (if tmp-1
2841 (apply (lambda () '("quote" ())) tmp-1)
2842 (syntax-violation
2843 #f
2844 "source expression failed to match any pattern"
2845 tmp))))))))
2846 (quasicons
2847 (lambda (x y)
2848 (let ((tmp-1 (list x y)))
2849 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2850 (if tmp
2851 (apply (lambda (x y)
2852 (let ((tmp y))
2853 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2854 (if tmp-1
2855 (apply (lambda (dy)
2856 (let ((tmp x))
2857 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
2858 (if tmp
2859 (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
2860 (if (null? dy) (list "list" x) (list "list*" x y))))))
2861 tmp-1)
2862 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
2863 (if tmp-1
2864 (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
2865 (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
2866 (if tmp
2867 (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
2868 (list "list*" x y)))))))))
2869 tmp)
2870 (syntax-violation
2871 #f
2872 "source expression failed to match any pattern"
2873 tmp-1))))))
2874 (quasiappend
2875 (lambda (x y)
2876 (let ((tmp y))
2877 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
2878 (if tmp
2879 (apply (lambda ()
2880 (if (null? x)
2881 '("quote" ())
2882 (if (null? (cdr x))
2883 (car x)
2884 (let ((tmp-1 x))
2885 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2886 (if tmp
2887 (apply (lambda (p) (cons "append" p)) tmp)
2888 (syntax-violation
2889 #f
2890 "source expression failed to match any pattern"
2891 tmp-1)))))))
2892 tmp)
2893 (if (null? x)
2894 y
2895 (let ((tmp-1 (list x y)))
2896 (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
2897 (if tmp
2898 (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
2899 (syntax-violation
2900 #f
2901 "source expression failed to match any pattern"
2902 tmp-1))))))))))
2903 (quasilist*
2904 (lambda (x y)
2905 (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
2906 (quasivector
2907 (lambda (x)
2908 (let ((tmp x))
2909 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
2910 (if tmp
2911 (apply (lambda (x) (list "quote" (list->vector x))) tmp)
2912 (let f ((y x)
2913 (k (lambda (ls)
2914 (let ((tmp-1 ls))
2915 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2916 (if tmp
2917 (apply (lambda (t) (cons "vector" t)) tmp)
2918 (syntax-violation
2919 #f
2920 "source expression failed to match any pattern"
2921 tmp-1)))))))
2922 (let ((tmp y))
2923 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
2924 (if tmp-1
2925 (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
2926 tmp-1)
2927 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2928 (if tmp-1
2929 (apply (lambda (y) (k y)) tmp-1)
2930 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2931 (if tmp-1
2932 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
2933 (let ((else tmp))
2934 (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
2935 (emit (lambda (x)
2936 (let ((tmp x))
2937 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2938 (if tmp-1
2939 (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
2940 tmp-1)
2941 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2942 (if tmp-1
2943 (apply (lambda (x)
2944 (let ((tmp-1 (map emit x)))
2945 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2946 (if tmp
2947 (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
2948 tmp)
2949 (syntax-violation
2950 #f
2951 "source expression failed to match any pattern"
2952 tmp-1)))))
2953 tmp-1)
2954 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2955 (if tmp-1
2956 (apply (lambda (x y)
2957 (let f ((x* x))
2958 (if (null? x*)
2959 (emit y)
2960 (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
2961 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2962 (if tmp
2963 (apply (lambda (t-1 t)
2964 (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
2965 tmp)
2966 (syntax-violation
2967 #f
2968 "source expression failed to match any pattern"
2969 tmp-1)))))))
2970 tmp-1)
2971 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
2972 (if tmp-1
2973 (apply (lambda (x)
2974 (let ((tmp-1 (map emit x)))
2975 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2976 (if tmp
2977 (apply (lambda (t)
2978 (cons '#(syntax-object append ((top)) (hygiene guile)) t))
2979 tmp)
2980 (syntax-violation
2981 #f
2982 "source expression failed to match any pattern"
2983 tmp-1)))))
2984 tmp-1)
2985 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
2986 (if tmp-1
2987 (apply (lambda (x)
2988 (let ((tmp-1 (map emit x)))
2989 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2990 (if tmp
2991 (apply (lambda (t)
2992 (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
2993 tmp)
2994 (syntax-violation
2995 #f
2996 "source expression failed to match any pattern"
2997 tmp-1)))))
2998 tmp-1)
2999 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
3000 (if tmp-1
3001 (apply (lambda (x)
3002 (let ((tmp (emit x)))
3003 (let ((t tmp))
3004 (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
3005 tmp-1)
3006 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
3007 (if tmp-1
3008 (apply (lambda (x) x) tmp-1)
3009 (syntax-violation
3010 #f
3011 "source expression failed to match any pattern"
3012 tmp)))))))))))))))))))
3013 (lambda (x)
3014 (let ((tmp-1 x))
3015 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3016 (if tmp
3017 (apply (lambda (e) (emit (quasi e 0))) tmp)
3018 (syntax-violation
3019 #f
3020 "source expression failed to match any pattern"
3021 tmp-1))))))))
3022
3023 (define include
3024 (make-syntax-transformer
3025 'include
3026 'macro
3027 (lambda (x)
3028 (letrec*
3029 ((read-file
3030 (lambda (fn k)
3031 (let ((p (open-input-file fn)))
3032 (let f ((x (read p)) (result '()))
3033 (if (eof-object? x)
3034 (begin (close-input-port p) (reverse result))
3035 (f (read p) (cons (datum->syntax k x) result))))))))
3036 (let ((tmp-1 x))
3037 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3038 (if tmp
3039 (apply (lambda (k filename)
3040 (let ((fn (syntax->datum filename)))
3041 (let ((tmp-1 (read-file fn filename)))
3042 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
3043 (if tmp
3044 (apply (lambda (exp)
3045 (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
3046 tmp)
3047 (syntax-violation
3048 #f
3049 "source expression failed to match any pattern"
3050 tmp-1))))))
3051 tmp)
3052 (syntax-violation
3053 #f
3054 "source expression failed to match any pattern"
3055 tmp-1))))))))
3056
3057 (define include-from-path
3058 (make-syntax-transformer
3059 'include-from-path
3060 'macro
3061 (lambda (x)
3062 (let ((tmp-1 x))
3063 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3064 (if tmp
3065 (apply (lambda (k filename)
3066 (let ((fn (syntax->datum filename)))
3067 (let ((tmp (datum->syntax
3068 filename
3069 (let ((t (%search-load-path fn)))
3070 (if t
3071 t
3072 (syntax-violation
3073 'include-from-path
3074 "file not found in path"
3075 x
3076 filename))))))
3077 (let ((fn tmp))
3078 (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
3079 tmp)
3080 (syntax-violation
3081 #f
3082 "source expression failed to match any pattern"
3083 tmp-1)))))))
3084
3085 (define unquote
3086 (make-syntax-transformer
3087 'unquote
3088 'macro
3089 (lambda (x)
3090 (syntax-violation
3091 'unquote
3092 "expression not valid outside of quasiquote"
3093 x))))
3094
3095 (define unquote-splicing
3096 (make-syntax-transformer
3097 'unquote-splicing
3098 'macro
3099 (lambda (x)
3100 (syntax-violation
3101 'unquote-splicing
3102 "expression not valid outside of quasiquote"
3103 x))))
3104
3105 (define make-variable-transformer
3106 (lambda (proc)
3107 (if (procedure? proc)
3108 (let ((trans (lambda (x) (proc x))))
3109 (set-procedure-property! trans 'variable-transformer #t)
3110 trans)
3111 (error "variable transformer not a procedure" proc))))
3112
3113 (define identifier-syntax
3114 (make-syntax-transformer
3115 'identifier-syntax
3116 'macro
3117 (lambda (xx)
3118 (let ((tmp-1 xx))
3119 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3120 (if tmp
3121 (apply (lambda (e)
3122 (list '#(syntax-object lambda ((top)) (hygiene guile))
3123 '(#(syntax-object x ((top)) (hygiene guile)))
3124 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3125 .
3126 #(syntax-object
3127 identifier-syntax
3128 ((top)
3129 #(ribcage
3130 #(identifier-syntax)
3131 #((top))
3132 #(((hygiene guile)
3133 .
3134 #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
3135 (hygiene guile))))
3136 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3137 '#(syntax-object x ((top)) (hygiene guile))
3138 '()
3139 (list '#(syntax-object id ((top)) (hygiene guile))
3140 '(#(syntax-object identifier? ((top)) (hygiene guile))
3141 (#(syntax-object syntax ((top)) (hygiene guile))
3142 #(syntax-object id ((top)) (hygiene guile))))
3143 (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
3144 (list '(#(syntax-object _ ((top)) (hygiene guile))
3145 #(syntax-object x ((top)) (hygiene guile))
3146 #(syntax-object ... ((top)) (hygiene guile)))
3147 (list '#(syntax-object syntax ((top)) (hygiene guile))
3148 (cons e
3149 '(#(syntax-object x ((top)) (hygiene guile))
3150 #(syntax-object ... ((top)) (hygiene guile)))))))))
3151 tmp)
3152 (let ((tmp ($sc-dispatch
3153 tmp-1
3154 '(_ (any any)
3155 ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
3156 any)))))
3157 (if (if tmp
3158 (apply (lambda (id exp1 var val exp2)
3159 (if (identifier? id) (identifier? var) #f))
3160 tmp)
3161 #f)
3162 (apply (lambda (id exp1 var val exp2)
3163 (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
3164 (list '#(syntax-object lambda ((top)) (hygiene guile))
3165 '(#(syntax-object x ((top)) (hygiene guile)))
3166 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3167 .
3168 #(syntax-object variable-transformer ((top)) (hygiene guile))))
3169 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3170 '#(syntax-object x ((top)) (hygiene guile))
3171 '(#(syntax-object set! ((top)) (hygiene guile)))
3172 (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
3173 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
3174 (list (cons id
3175 '(#(syntax-object x ((top)) (hygiene guile))
3176 #(syntax-object ... ((top)) (hygiene guile))))
3177 (list '#(syntax-object syntax ((top)) (hygiene guile))
3178 (cons exp1
3179 '(#(syntax-object x ((top)) (hygiene guile))
3180 #(syntax-object ... ((top)) (hygiene guile))))))
3181 (list id
3182 (list '#(syntax-object identifier? ((top)) (hygiene guile))
3183 (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
3184 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
3185 tmp)
3186 (syntax-violation
3187 #f
3188 "source expression failed to match any pattern"
3189 tmp-1)))))))))
3190
3191 (define define*
3192 (make-syntax-transformer
3193 'define*
3194 'macro
3195 (lambda (x)
3196 (let ((tmp-1 x))
3197 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
3198 (if tmp
3199 (apply (lambda (id args b0 b1)
3200 (list '#(syntax-object define ((top)) (hygiene guile))
3201 id
3202 (cons '#(syntax-object lambda* ((top)) (hygiene guile))
3203 (cons args (cons b0 b1)))))
3204 tmp)
3205 (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
3206 (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
3207 (apply (lambda (id val)
3208 (list '#(syntax-object define ((top)) (hygiene guile)) id val))
3209 tmp)
3210 (syntax-violation
3211 #f
3212 "source expression failed to match any pattern"
3213 tmp-1)))))))))
3214
Unnamed repository; edit this file 'description' to name the repository.