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 e) 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))
1008 (let ((id (wrap value w mod))
1009 (label (gen-label))
1010 (trans-r (macros-only-env er)))
1011 (extend-ribcage! ribcage id label)
1012 (set-cdr!
1013 r
1014 (extend-env
1015 (list label)
1016 (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
1017 (cdr r)))
1018 (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
1019 ((memv key '(define-syntax-parameter-form))
1020 (let ((id (wrap value w mod))
1021 (label (gen-label))
1022 (trans-r (macros-only-env er)))
1023 (extend-ribcage! ribcage id label)
1024 (set-cdr!
1025 r
1026 (extend-env
1027 (list label)
1028 (list (cons 'syntax-parameter
1029 (list (eval-local-transformer (expand e trans-r w mod) mod))))
1030 (cdr r)))
1031 (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
1032 ((memv key '(begin-form))
1033 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
1034 (if tmp
1035 (apply (lambda (e1)
1036 (parse (let f ((forms e1))
1037 (if (null? forms)
1038 (cdr body)
1039 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1040 ids
1041 labels
1042 var-ids
1043 vars
1044 vals
1045 bindings))
1046 tmp)
1047 (syntax-violation
1048 #f
1049 "source expression failed to match any pattern"
1050 tmp-1))))
1051 ((memv key '(local-syntax-form))
1052 (expand-local-syntax
1053 value
1054 e
1055 er
1056 w
1057 s
1058 mod
1059 (lambda (forms er w s mod)
1060 (parse (let f ((forms forms))
1061 (if (null? forms)
1062 (cdr body)
1063 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1064 ids
1065 labels
1066 var-ids
1067 vars
1068 vals
1069 bindings))))
1070 ((null? ids)
1071 (build-sequence
1072 #f
1073 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1074 (cons (cons er (source-wrap e w s mod)) (cdr body)))))
1075 (else
1076 (if (not (valid-bound-ids? ids))
1077 (syntax-violation
1078 #f
1079 "invalid or duplicate identifier in definition"
1080 outer-form))
1081 (set-cdr! r (extend-env labels bindings (cdr r)))
1082 (build-letrec
1083 #f
1084 #t
1085 (reverse (map syntax->datum var-ids))
1086 (reverse vars)
1087 (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
1088 (build-sequence
1089 #f
1090 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1091 (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
1092 (expand-local-syntax
1093 (lambda (rec? e r w s mod k)
1094 (let* ((tmp e)
1095 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1096 (if tmp
1097 (apply (lambda (id val e1 e2)
1098 (let ((ids id))
1099 (if (not (valid-bound-ids? ids))
1100 (syntax-violation #f "duplicate bound keyword" e)
1101 (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
1102 (k (cons e1 e2)
1103 (extend-env
1104 labels
1105 (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
1106 (map (lambda (x)
1107 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1108 val))
1109 r)
1110 new-w
1111 s
1112 mod)))))
1113 tmp)
1114 (syntax-violation
1115 #f
1116 "bad local syntax definition"
1117 (source-wrap e w s mod))))))
1118 (eval-local-transformer
1119 (lambda (expanded mod)
1120 (let ((p (local-eval-hook expanded mod)))
1121 (if (procedure? p)
1122 p
1123 (syntax-violation #f "nonprocedure transformer" p)))))
1124 (expand-void (lambda () (build-void #f)))
1125 (ellipsis?
1126 (lambda (x)
1127 (and (nonsymbol-id? x)
1128 (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
1129 (lambda-formals
1130 (lambda (orig-args)
1131 (letrec*
1132 ((req (lambda (args rreq)
1133 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1134 (if tmp-1
1135 (apply (lambda () (check (reverse rreq) #f)) tmp-1)
1136 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1137 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1138 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1139 (let ((tmp-1 (list tmp)))
1140 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1141 (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
1142 (let ((else tmp))
1143 (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
1144 (check (lambda (req rest)
1145 (if (distinct-bound-ids? (if rest (cons rest req) req))
1146 (values req #f rest #f)
1147 (syntax-violation
1148 'lambda
1149 "duplicate identifier in argument list"
1150 orig-args)))))
1151 (req orig-args '()))))
1152 (expand-simple-lambda
1153 (lambda (e r w s mod req rest meta body)
1154 (let* ((ids (if rest (append req (list rest)) req))
1155 (vars (map gen-var ids))
1156 (labels (gen-labels ids)))
1157 (build-simple-lambda
1158 s
1159 (map syntax->datum req)
1160 (and rest (syntax->datum rest))
1161 vars
1162 meta
1163 (expand-body
1164 body
1165 (source-wrap e w s mod)
1166 (extend-var-env labels vars r)
1167 (make-binding-wrap ids labels w)
1168 mod)))))
1169 (lambda*-formals
1170 (lambda (orig-args)
1171 (letrec*
1172 ((req (lambda (args rreq)
1173 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1174 (if tmp-1
1175 (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
1176 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1177 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1178 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1179 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1180 (if (and tmp-1
1181 (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1))
1182 (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
1183 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1184 (if (and tmp-1
1185 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1186 (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
1187 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1188 (if (and tmp-1
1189 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1190 (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
1191 (let ((tmp-1 (list tmp)))
1192 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1193 (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
1194 (let ((else tmp))
1195 (syntax-violation
1196 'lambda*
1197 "invalid argument list"
1198 orig-args
1199 args))))))))))))))))
1200 (opt (lambda (args req ropt)
1201 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1202 (if tmp-1
1203 (apply (lambda () (check req (reverse ropt) #f '())) tmp-1)
1204 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1205 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1206 (apply (lambda (a b) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
1207 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1208 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1209 (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
1210 tmp-1)
1211 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1212 (if (and tmp-1
1213 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1214 (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
1215 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1216 (if (and tmp-1
1217 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1218 (apply (lambda (a b) (rest b req (reverse ropt) '())) tmp-1)
1219 (let ((tmp-1 (list tmp)))
1220 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1221 (apply (lambda (r) (rest r req (reverse ropt) '())) tmp-1)
1222 (let ((else tmp))
1223 (syntax-violation
1224 'lambda*
1225 "invalid optional argument list"
1226 orig-args
1227 args))))))))))))))))
1228 (key (lambda (args req opt rkey)
1229 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1230 (if tmp-1
1231 (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) tmp-1)
1232 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1233 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1234 (apply (lambda (a b)
1235 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1236 (key b req opt (cons (cons k (cons a '(#f))) rkey))))
1237 tmp-1)
1238 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1239 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1240 (apply (lambda (a init b)
1241 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1242 (key b req opt (cons (list k a init) rkey))))
1243 tmp-1)
1244 (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
1245 (if (and tmp-1
1246 (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
1247 tmp-1))
1248 (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
1249 tmp-1)
1250 (let ((tmp-1 ($sc-dispatch tmp '(any))))
1251 (if (and tmp-1
1252 (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys))
1253 tmp-1))
1254 (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
1255 tmp-1)
1256 (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
1257 (if (and tmp-1
1258 (apply (lambda (aok a b)
1259 (and (eq? (syntax->datum aok) #:allow-other-keys)
1260 (eq? (syntax->datum a) #:rest)))
1261 tmp-1))
1262 (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
1263 tmp-1)
1264 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1265 (if (and tmp-1
1266 (apply (lambda (aok r)
1267 (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r)))
1268 tmp-1))
1269 (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
1270 tmp-1)
1271 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1272 (if (and tmp-1
1273 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1274 (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
1275 tmp-1)
1276 (let ((tmp-1 (list tmp)))
1277 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1278 (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
1279 tmp-1)
1280 (let ((else tmp))
1281 (syntax-violation
1282 'lambda*
1283 "invalid keyword argument list"
1284 orig-args
1285 args))))))))))))))))))))))
1286 (rest (lambda (args req opt kw)
1287 (let* ((tmp-1 args) (tmp (list tmp-1)))
1288 (if (and tmp (apply (lambda (r) (id? r)) tmp))
1289 (apply (lambda (r) (check req opt r kw)) tmp)
1290 (let ((else tmp-1))
1291 (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
1292 (check (lambda (req opt rest kw)
1293 (if (distinct-bound-ids?
1294 (append
1295 req
1296 (map car opt)
1297 (if rest (list rest) '())
1298 (if (pair? kw) (map cadr (cdr kw)) '())))
1299 (values req opt rest kw)
1300 (syntax-violation
1301 'lambda*
1302 "duplicate identifier in argument list"
1303 orig-args)))))
1304 (req orig-args '()))))
1305 (expand-lambda-case
1306 (lambda (e r w s mod get-formals clauses)
1307 (letrec*
1308 ((parse-req
1309 (lambda (req opt rest kw body)
1310 (let ((vars (map gen-var req)) (labels (gen-labels req)))
1311 (let ((r* (extend-var-env labels vars r))
1312 (w* (make-binding-wrap req labels w)))
1313 (parse-opt
1314 (map syntax->datum req)
1315 opt
1316 rest
1317 kw
1318 body
1319 (reverse vars)
1320 r*
1321 w*
1322 '()
1323 '())))))
1324 (parse-opt
1325 (lambda (req opt rest kw body vars r* w* out inits)
1326 (cond ((pair? opt)
1327 (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
1328 (if tmp
1329 (apply (lambda (id i)
1330 (let* ((v (gen-var id))
1331 (l (gen-labels (list v)))
1332 (r** (extend-var-env l (list v) r*))
1333 (w** (make-binding-wrap (list id) l w*)))
1334 (parse-opt
1335 req
1336 (cdr opt)
1337 rest
1338 kw
1339 body
1340 (cons v vars)
1341 r**
1342 w**
1343 (cons (syntax->datum id) out)
1344 (cons (expand i r* w* mod) inits))))
1345 tmp)
1346 (syntax-violation
1347 #f
1348 "source expression failed to match any pattern"
1349 tmp-1))))
1350 (rest
1351 (let* ((v (gen-var rest))
1352 (l (gen-labels (list v)))
1353 (r* (extend-var-env l (list v) r*))
1354 (w* (make-binding-wrap (list rest) l w*)))
1355 (parse-kw
1356 req
1357 (and (pair? out) (reverse out))
1358 (syntax->datum rest)
1359 (if (pair? kw) (cdr kw) kw)
1360 body
1361 (cons v vars)
1362 r*
1363 w*
1364 (and (pair? kw) (car kw))
1365 '()
1366 inits)))
1367 (else
1368 (parse-kw
1369 req
1370 (and (pair? out) (reverse out))
1371 #f
1372 (if (pair? kw) (cdr kw) kw)
1373 body
1374 vars
1375 r*
1376 w*
1377 (and (pair? kw) (car kw))
1378 '()
1379 inits)))))
1380 (parse-kw
1381 (lambda (req opt rest kw body vars r* w* aok out inits)
1382 (if (pair? kw)
1383 (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
1384 (if tmp
1385 (apply (lambda (k id i)
1386 (let* ((v (gen-var id))
1387 (l (gen-labels (list v)))
1388 (r** (extend-var-env l (list v) r*))
1389 (w** (make-binding-wrap (list id) l w*)))
1390 (parse-kw
1391 req
1392 opt
1393 rest
1394 (cdr kw)
1395 body
1396 (cons v vars)
1397 r**
1398 w**
1399 aok
1400 (cons (list (syntax->datum k) (syntax->datum id) v) out)
1401 (cons (expand i r* w* mod) inits))))
1402 tmp)
1403 (syntax-violation
1404 #f
1405 "source expression failed to match any pattern"
1406 tmp-1)))
1407 (parse-body
1408 req
1409 opt
1410 rest
1411 (and (or aok (pair? out)) (cons aok (reverse out)))
1412 body
1413 (reverse vars)
1414 r*
1415 w*
1416 (reverse inits)
1417 '()))))
1418 (parse-body
1419 (lambda (req opt rest kw body vars r* w* inits meta)
1420 (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
1421 (if (and tmp-1
1422 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1423 tmp-1))
1424 (apply (lambda (docstring e1 e2)
1425 (parse-body
1426 req
1427 opt
1428 rest
1429 kw
1430 (cons e1 e2)
1431 vars
1432 r*
1433 w*
1434 inits
1435 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1436 tmp-1)
1437 (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
1438 (if tmp-1
1439 (apply (lambda (k v e1 e2)
1440 (parse-body
1441 req
1442 opt
1443 rest
1444 kw
1445 (cons e1 e2)
1446 vars
1447 r*
1448 w*
1449 inits
1450 (append meta (syntax->datum (map cons k v)))))
1451 tmp-1)
1452 (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
1453 (if tmp-1
1454 (apply (lambda (e1 e2)
1455 (values
1456 meta
1457 req
1458 opt
1459 rest
1460 kw
1461 inits
1462 vars
1463 (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
1464 tmp-1)
1465 (syntax-violation
1466 #f
1467 "source expression failed to match any pattern"
1468 tmp))))))))))
1469 (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
1470 (if tmp-1
1471 (apply (lambda () (values '() #f)) tmp-1)
1472 (let ((tmp-1 ($sc-dispatch
1473 tmp
1474 '((any any . each-any) . #(each (any any . each-any))))))
1475 (if tmp-1
1476 (apply (lambda (args e1 e2 args* e1* e2*)
1477 (call-with-values
1478 (lambda () (get-formals args))
1479 (lambda (req opt rest kw)
1480 (call-with-values
1481 (lambda () (parse-req req opt rest kw (cons e1 e2)))
1482 (lambda (meta req opt rest kw inits vars body)
1483 (call-with-values
1484 (lambda ()
1485 (expand-lambda-case
1486 e
1487 r
1488 w
1489 s
1490 mod
1491 get-formals
1492 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1493 e2*
1494 e1*
1495 args*)))
1496 (lambda (meta* else*)
1497 (values
1498 (append meta meta*)
1499 (build-lambda-case s req opt rest kw inits vars body else*)))))))))
1500 tmp-1)
1501 (syntax-violation
1502 #f
1503 "source expression failed to match any pattern"
1504 tmp))))))))
1505 (strip (lambda (x w)
1506 (if (memq 'top (car w))
1507 x
1508 (let f ((x x))
1509 (cond ((syntax-object? x)
1510 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1511 ((pair? x)
1512 (let ((a (f (car x))) (d (f (cdr x))))
1513 (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
1514 ((vector? x)
1515 (let* ((old (vector->list x)) (new (map f old)))
1516 (let lp ((l1 old) (l2 new))
1517 (cond ((null? l1) x)
1518 ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
1519 (else (list->vector new))))))
1520 (else x))))))
1521 (gen-var
1522 (lambda (id)
1523 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1524 (gensym (string-append (symbol->string id) "-")))))
1525 (lambda-var-list
1526 (lambda (vars)
1527 (let lvl ((vars vars) (ls '()) (w '(())))
1528 (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1529 ((id? vars) (cons (wrap vars w #f) ls))
1530 ((null? vars) ls)
1531 ((syntax-object? vars)
1532 (lvl (syntax-object-expression vars)
1533 ls
1534 (join-wraps w (syntax-object-wrap vars))))
1535 (else (cons vars ls)))))))
1536 (global-extend 'local-syntax 'letrec-syntax #t)
1537 (global-extend 'local-syntax 'let-syntax #f)
1538 (global-extend
1539 'core
1540 'syntax-parameterize
1541 (lambda (e r w s mod)
1542 (let* ((tmp e)
1543 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1544 (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
1545 (apply (lambda (var val e1 e2)
1546 (let ((names (map (lambda (x)
1547 (call-with-values
1548 (lambda () (resolve-identifier x w r mod #f))
1549 (lambda (type value mod)
1550 (let ((key type))
1551 (cond ((memv key '(displaced-lexical))
1552 (syntax-violation
1553 'syntax-parameterize
1554 "identifier out of context"
1555 e
1556 (source-wrap x w s mod)))
1557 ((memv key '(syntax-parameter)) value)
1558 (else
1559 (syntax-violation
1560 'syntax-parameterize
1561 "invalid syntax parameter"
1562 e
1563 (source-wrap x w s mod))))))))
1564 var))
1565 (bindings
1566 (let ((trans-r (macros-only-env r)))
1567 (map (lambda (x)
1568 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1569 val))))
1570 (expand-body
1571 (cons e1 e2)
1572 (source-wrap e w s mod)
1573 (extend-env names bindings r)
1574 w
1575 mod)))
1576 tmp)
1577 (syntax-violation
1578 'syntax-parameterize
1579 "bad syntax"
1580 (source-wrap e w s mod))))))
1581 (global-extend
1582 'core
1583 'quote
1584 (lambda (e r w s mod)
1585 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
1586 (if tmp
1587 (apply (lambda (e) (build-data s (strip e w))) tmp)
1588 (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
1589 (global-extend
1590 'core
1591 'syntax
1592 (letrec*
1593 ((gen-syntax
1594 (lambda (src e r maps ellipsis? mod)
1595 (if (id? e)
1596 (call-with-values
1597 (lambda () (resolve-identifier e '(()) r mod #f))
1598 (lambda (type value mod)
1599 (let ((key type))
1600 (cond ((memv key '(syntax))
1601 (call-with-values
1602 (lambda () (gen-ref src (car value) (cdr value) maps))
1603 (lambda (var maps) (values (list 'ref var) maps))))
1604 ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
1605 (else (values (list 'quote e) maps))))))
1606 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
1607 (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
1608 (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
1609 tmp-1)
1610 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
1611 (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
1612 (apply (lambda (x dots y)
1613 (let f ((y y)
1614 (k (lambda (maps)
1615 (call-with-values
1616 (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
1617 (lambda (x maps)
1618 (if (null? (car maps))
1619 (syntax-violation 'syntax "extra ellipsis" src)
1620 (values (gen-map x (car maps)) (cdr maps))))))))
1621 (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
1622 (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
1623 (apply (lambda (dots y)
1624 (f y
1625 (lambda (maps)
1626 (call-with-values
1627 (lambda () (k (cons '() maps)))
1628 (lambda (x maps)
1629 (if (null? (car maps))
1630 (syntax-violation 'syntax "extra ellipsis" src)
1631 (values (gen-mappend x (car maps)) (cdr maps))))))))
1632 tmp)
1633 (call-with-values
1634 (lambda () (gen-syntax src y r maps ellipsis? mod))
1635 (lambda (y maps)
1636 (call-with-values
1637 (lambda () (k maps))
1638 (lambda (x maps) (values (gen-append x y) maps)))))))))
1639 tmp-1)
1640 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1641 (if tmp-1
1642 (apply (lambda (x y)
1643 (call-with-values
1644 (lambda () (gen-syntax src x r maps ellipsis? mod))
1645 (lambda (x maps)
1646 (call-with-values
1647 (lambda () (gen-syntax src y r maps ellipsis? mod))
1648 (lambda (y maps) (values (gen-cons x y) maps))))))
1649 tmp-1)
1650 (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
1651 (if tmp
1652 (apply (lambda (e1 e2)
1653 (call-with-values
1654 (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
1655 (lambda (e maps) (values (gen-vector e) maps))))
1656 tmp)
1657 (values (list 'quote e) maps))))))))))))
1658 (gen-ref
1659 (lambda (src var level maps)
1660 (cond ((= level 0) (values var maps))
1661 ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
1662 (else
1663 (call-with-values
1664 (lambda () (gen-ref src var (- level 1) (cdr maps)))
1665 (lambda (outer-var outer-maps)
1666 (let ((b (assq outer-var (car maps))))
1667 (if b
1668 (values (cdr b) maps)
1669 (let ((inner-var (gen-var 'tmp)))
1670 (values
1671 inner-var
1672 (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
1673 (gen-mappend
1674 (lambda (e map-env)
1675 (list 'apply '(primitive append) (gen-map e map-env))))
1676 (gen-map
1677 (lambda (e map-env)
1678 (let ((formals (map cdr map-env))
1679 (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
1680 (cond ((eq? (car e) 'ref) (car actuals))
1681 ((and-map
1682 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1683 (cdr e))
1684 (cons 'map
1685 (cons (list 'primitive (car e))
1686 (map (let ((r (map cons formals actuals)))
1687 (lambda (x) (cdr (assq (cadr x) r))))
1688 (cdr e)))))
1689 (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
1690 (gen-cons
1691 (lambda (x y)
1692 (let ((key (car y)))
1693 (cond ((memv key '(quote))
1694 (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
1695 ((eq? (cadr y) '()) (list 'list x))
1696 (else (list 'cons x y))))
1697 ((memv key '(list)) (cons 'list (cons x (cdr y))))
1698 (else (list 'cons x y))))))
1699 (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
1700 (gen-vector
1701 (lambda (x)
1702 (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
1703 ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
1704 (else (list 'list->vector x)))))
1705 (regen (lambda (x)
1706 (let ((key (car x)))
1707 (cond ((memv key '(ref))
1708 (build-lexical-reference 'value #f (cadr x) (cadr x)))
1709 ((memv key '(primitive)) (build-primref #f (cadr x)))
1710 ((memv key '(quote)) (build-data #f (cadr x)))
1711 ((memv key '(lambda))
1712 (if (list? (cadr x))
1713 (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
1714 (error "how did we get here" x)))
1715 (else (build-primcall #f (car x) (map regen (cdr x)))))))))
1716 (lambda (e r w s mod)
1717 (let* ((e (source-wrap e w s mod))
1718 (tmp e)
1719 (tmp ($sc-dispatch tmp '(_ any))))
1720 (if tmp
1721 (apply (lambda (x)
1722 (call-with-values
1723 (lambda () (gen-syntax e x r '() ellipsis? mod))
1724 (lambda (e maps) (regen e))))
1725 tmp)
1726 (syntax-violation 'syntax "bad `syntax' form" e))))))
1727 (global-extend
1728 'core
1729 'lambda
1730 (lambda (e r w s mod)
1731 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1732 (if tmp
1733 (apply (lambda (args e1 e2)
1734 (call-with-values
1735 (lambda () (lambda-formals args))
1736 (lambda (req opt rest kw)
1737 (let lp ((body (cons e1 e2)) (meta '()))
1738 (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
1739 (if (and tmp
1740 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1741 tmp))
1742 (apply (lambda (docstring e1 e2)
1743 (lp (cons e1 e2)
1744 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1745 tmp)
1746 (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
1747 (if tmp
1748 (apply (lambda (k v e1 e2)
1749 (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
1750 tmp)
1751 (expand-simple-lambda e r w s mod req rest meta body)))))))))
1752 tmp)
1753 (syntax-violation 'lambda "bad lambda" e)))))
1754 (global-extend
1755 'core
1756 'lambda*
1757 (lambda (e r w s mod)
1758 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1759 (if tmp
1760 (apply (lambda (args e1 e2)
1761 (call-with-values
1762 (lambda ()
1763 (expand-lambda-case
1764 e
1765 r
1766 w
1767 s
1768 mod
1769 lambda*-formals
1770 (list (cons args (cons e1 e2)))))
1771 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1772 tmp)
1773 (syntax-violation 'lambda "bad lambda*" e)))))
1774 (global-extend
1775 'core
1776 'case-lambda
1777 (lambda (e r w s mod)
1778 (let* ((tmp e)
1779 (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
1780 (if tmp
1781 (apply (lambda (args e1 e2)
1782 (call-with-values
1783 (lambda ()
1784 (expand-lambda-case
1785 e
1786 r
1787 w
1788 s
1789 mod
1790 lambda-formals
1791 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1792 e2
1793 e1
1794 args)))
1795 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1796 tmp)
1797 (syntax-violation 'case-lambda "bad case-lambda" e)))))
1798 (global-extend
1799 'core
1800 'case-lambda*
1801 (lambda (e r w s mod)
1802 (let* ((tmp e)
1803 (tmp ($sc-dispatch tmp '(_ . #(each (any any . each-any))))))
1804 (if tmp
1805 (apply (lambda (args e1 e2)
1806 (call-with-values
1807 (lambda ()
1808 (expand-lambda-case
1809 e
1810 r
1811 w
1812 s
1813 mod
1814 lambda*-formals
1815 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1816 e2
1817 e1
1818 args)))
1819 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1820 tmp)
1821 (syntax-violation 'case-lambda "bad case-lambda*" e)))))
1822 (global-extend
1823 'core
1824 'let
1825 (letrec*
1826 ((expand-let
1827 (lambda (e r w s mod constructor ids vals exps)
1828 (if (not (valid-bound-ids? ids))
1829 (syntax-violation 'let "duplicate bound variable" e)
1830 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1831 (let ((nw (make-binding-wrap ids labels w))
1832 (nr (extend-var-env labels new-vars r)))
1833 (constructor
1834 s
1835 (map syntax->datum ids)
1836 new-vars
1837 (map (lambda (x) (expand x r w mod)) vals)
1838 (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
1839 (lambda (e r w s mod)
1840 (let* ((tmp-1 e)
1841 (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
1842 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1843 (apply (lambda (id val e1 e2)
1844 (expand-let e r w s mod build-let id val (cons e1 e2)))
1845 tmp)
1846 (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
1847 (if (and tmp
1848 (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
1849 (apply (lambda (f id val e1 e2)
1850 (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
1851 tmp)
1852 (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
1853 (global-extend
1854 'core
1855 'letrec
1856 (lambda (e r w s mod)
1857 (let* ((tmp e)
1858 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1859 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1860 (apply (lambda (id val e1 e2)
1861 (let ((ids id))
1862 (if (not (valid-bound-ids? ids))
1863 (syntax-violation 'letrec "duplicate bound variable" e)
1864 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1865 (let ((w (make-binding-wrap ids labels w))
1866 (r (extend-var-env labels new-vars r)))
1867 (build-letrec
1868 s
1869 #f
1870 (map syntax->datum ids)
1871 new-vars
1872 (map (lambda (x) (expand x r w mod)) val)
1873 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1874 tmp)
1875 (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
1876 (global-extend
1877 'core
1878 'letrec*
1879 (lambda (e r w s mod)
1880 (let* ((tmp e)
1881 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1882 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1883 (apply (lambda (id val e1 e2)
1884 (let ((ids id))
1885 (if (not (valid-bound-ids? ids))
1886 (syntax-violation 'letrec* "duplicate bound variable" e)
1887 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1888 (let ((w (make-binding-wrap ids labels w))
1889 (r (extend-var-env labels new-vars r)))
1890 (build-letrec
1891 s
1892 #t
1893 (map syntax->datum ids)
1894 new-vars
1895 (map (lambda (x) (expand x r w mod)) val)
1896 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1897 tmp)
1898 (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
1899 (global-extend
1900 'core
1901 'set!
1902 (lambda (e r w s mod)
1903 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
1904 (if (and tmp (apply (lambda (id val) (id? id)) tmp))
1905 (apply (lambda (id val)
1906 (call-with-values
1907 (lambda () (resolve-identifier id w r mod #t))
1908 (lambda (type value id-mod)
1909 (let ((key type))
1910 (cond ((memv key '(lexical))
1911 (build-lexical-assignment
1912 s
1913 (syntax->datum id)
1914 value
1915 (expand val r w mod)))
1916 ((memv key '(global))
1917 (build-global-assignment s value (expand val r w mod) id-mod))
1918 ((memv key '(macro))
1919 (if (procedure-property value 'variable-transformer)
1920 (expand (expand-macro value e r w s #f mod) r '(()) mod)
1921 (syntax-violation
1922 'set!
1923 "not a variable transformer"
1924 (wrap e w mod)
1925 (wrap id w id-mod))))
1926 ((memv key '(displaced-lexical))
1927 (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
1928 (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1929 tmp)
1930 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
1931 (if tmp
1932 (apply (lambda (head tail val)
1933 (call-with-values
1934 (lambda () (syntax-type head r '(()) #f #f mod #t))
1935 (lambda (type value ee* ee ww ss modmod)
1936 (let ((key type))
1937 (if (memv key '(module-ref))
1938 (let ((val (expand val r w mod)))
1939 (call-with-values
1940 (lambda () (value (cons head tail) r w))
1941 (lambda (e r w s* mod)
1942 (let* ((tmp-1 e) (tmp (list tmp-1)))
1943 (if (and tmp (apply (lambda (e) (id? e)) tmp))
1944 (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
1945 tmp)
1946 (syntax-violation
1947 #f
1948 "source expression failed to match any pattern"
1949 tmp-1))))))
1950 (build-call
1951 s
1952 (expand
1953 (list '#(syntax-object setter ((top)) (hygiene guile)) head)
1954 r
1955 w
1956 mod)
1957 (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
1958 tmp)
1959 (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1960 (global-extend
1961 'module-ref
1962 '@
1963 (lambda (e r w)
1964 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
1965 (if (and tmp
1966 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
1967 (apply (lambda (mod id)
1968 (values
1969 (syntax->datum id)
1970 r
1971 '((top))
1972 #f
1973 (syntax->datum
1974 (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
1975 tmp)
1976 (syntax-violation
1977 #f
1978 "source expression failed to match any pattern"
1979 tmp-1)))))
1980 (global-extend
1981 'module-ref
1982 '@@
1983 (lambda (e r w)
1984 (letrec*
1985 ((remodulate
1986 (lambda (x mod)
1987 (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
1988 ((syntax-object? x)
1989 (make-syntax-object
1990 (remodulate (syntax-object-expression x) mod)
1991 (syntax-object-wrap x)
1992 mod))
1993 ((vector? x)
1994 (let* ((n (vector-length x)) (v (make-vector n)))
1995 (let loop ((i 0))
1996 (if (= i n)
1997 (begin (if #f #f) v)
1998 (begin
1999 (vector-set! v i (remodulate (vector-ref x i) mod))
2000 (loop (+ i 1)))))))
2001 (else x)))))
2002 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
2003 (if (and tmp
2004 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
2005 (apply (lambda (mod id)
2006 (values
2007 (syntax->datum id)
2008 r
2009 '((top))
2010 #f
2011 (syntax->datum
2012 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2013 tmp)
2014 (let ((tmp ($sc-dispatch
2015 tmp-1
2016 '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
2017 each-any
2018 any))))
2019 (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp))
2020 (apply (lambda (mod exp)
2021 (let ((mod (syntax->datum
2022 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2023 (values (remodulate exp mod) r w (source-annotation exp) mod)))
2024 tmp)
2025 (syntax-violation
2026 #f
2027 "source expression failed to match any pattern"
2028 tmp-1))))))))
2029 (global-extend
2030 'core
2031 'if
2032 (lambda (e r w s mod)
2033 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
2034 (if tmp-1
2035 (apply (lambda (test then)
2036 (build-conditional
2037 s
2038 (expand test r w mod)
2039 (expand then r w mod)
2040 (build-void #f)))
2041 tmp-1)
2042 (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
2043 (if tmp-1
2044 (apply (lambda (test then else)
2045 (build-conditional
2046 s
2047 (expand test r w mod)
2048 (expand then r w mod)
2049 (expand else r w mod)))
2050 tmp-1)
2051 (syntax-violation
2052 #f
2053 "source expression failed to match any pattern"
2054 tmp)))))))
2055 (global-extend
2056 'core
2057 'with-fluids
2058 (lambda (e r w s mod)
2059 (let* ((tmp-1 e)
2060 (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
2061 (if tmp
2062 (apply (lambda (fluid val b b*)
2063 (build-dynlet
2064 s
2065 (map (lambda (x) (expand x r w mod)) fluid)
2066 (map (lambda (x) (expand x r w mod)) val)
2067 (expand-body (cons b b*) (source-wrap e w s mod) r w mod)))
2068 tmp)
2069 (syntax-violation
2070 #f
2071 "source expression failed to match any pattern"
2072 tmp-1)))))
2073 (global-extend 'begin 'begin '())
2074 (global-extend 'define 'define '())
2075 (global-extend 'define-syntax 'define-syntax '())
2076 (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
2077 (global-extend 'eval-when 'eval-when '())
2078 (global-extend
2079 'core
2080 'syntax-case
2081 (letrec*
2082 ((convert-pattern
2083 (lambda (pattern keys)
2084 (letrec*
2085 ((cvt* (lambda (p* n ids)
2086 (if (not (pair? p*))
2087 (cvt p* n ids)
2088 (call-with-values
2089 (lambda () (cvt* (cdr p*) n ids))
2090 (lambda (y ids)
2091 (call-with-values
2092 (lambda () (cvt (car p*) n ids))
2093 (lambda (x ids) (values (cons x y) ids))))))))
2094 (v-reverse
2095 (lambda (x)
2096 (let loop ((r '()) (x x))
2097 (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
2098 (cvt (lambda (p n ids)
2099 (if (id? p)
2100 (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
2101 ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
2102 (values '_ ids))
2103 (else (values 'any (cons (cons p n) ids))))
2104 (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
2105 (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
2106 (apply (lambda (x dots)
2107 (call-with-values
2108 (lambda () (cvt x (+ n 1) ids))
2109 (lambda (p ids)
2110 (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
2111 tmp-1)
2112 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
2113 (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
2114 (apply (lambda (x dots ys)
2115 (call-with-values
2116 (lambda () (cvt* ys n ids))
2117 (lambda (ys ids)
2118 (call-with-values
2119 (lambda () (cvt x (+ n 1) ids))
2120 (lambda (x ids)
2121 (call-with-values
2122 (lambda () (v-reverse ys))
2123 (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
2124 tmp-1)
2125 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2126 (if tmp-1
2127 (apply (lambda (x y)
2128 (call-with-values
2129 (lambda () (cvt y n ids))
2130 (lambda (y ids)
2131 (call-with-values
2132 (lambda () (cvt x n ids))
2133 (lambda (x ids) (values (cons x y) ids))))))
2134 tmp-1)
2135 (let ((tmp-1 ($sc-dispatch tmp '())))
2136 (if tmp-1
2137 (apply (lambda () (values '() ids)) tmp-1)
2138 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2139 (if tmp-1
2140 (apply (lambda (x)
2141 (call-with-values
2142 (lambda () (cvt x n ids))
2143 (lambda (p ids) (values (vector 'vector p) ids))))
2144 tmp-1)
2145 (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
2146 (cvt pattern 0 '()))))
2147 (build-dispatch-call
2148 (lambda (pvars exp y r mod)
2149 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2150 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2151 (build-primcall
2152 #f
2153 'apply
2154 (list (build-simple-lambda
2155 #f
2156 (map syntax->datum ids)
2157 #f
2158 new-vars
2159 '()
2160 (expand
2161 exp
2162 (extend-env
2163 labels
2164 (map (lambda (var level) (cons 'syntax (cons var level)))
2165 new-vars
2166 (map cdr pvars))
2167 r)
2168 (make-binding-wrap ids labels '(()))
2169 mod))
2170 y))))))
2171 (gen-clause
2172 (lambda (x keys clauses r pat fender exp mod)
2173 (call-with-values
2174 (lambda () (convert-pattern pat keys))
2175 (lambda (p pvars)
2176 (cond ((not (distinct-bound-ids? (map car pvars)))
2177 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2178 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2179 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2180 (else
2181 (let ((y (gen-var 'tmp)))
2182 (build-call
2183 #f
2184 (build-simple-lambda
2185 #f
2186 (list 'tmp)
2187 #f
2188 (list y)
2189 '()
2190 (let ((y (build-lexical-reference 'value #f 'tmp y)))
2191 (build-conditional
2192 #f
2193 (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
2194 (if tmp
2195 (apply (lambda () y) tmp)
2196 (build-conditional
2197 #f
2198 y
2199 (build-dispatch-call pvars fender y r mod)
2200 (build-data #f #f))))
2201 (build-dispatch-call pvars exp y r mod)
2202 (gen-syntax-case x keys clauses r mod))))
2203 (list (if (eq? p 'any)
2204 (build-primcall #f 'list (list x))
2205 (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
2206 (gen-syntax-case
2207 (lambda (x keys clauses r mod)
2208 (if (null? clauses)
2209 (build-primcall
2210 #f
2211 'syntax-violation
2212 (list (build-data #f #f)
2213 (build-data #f "source expression failed to match any pattern")
2214 x))
2215 (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
2216 (if tmp
2217 (apply (lambda (pat exp)
2218 (if (and (id? pat)
2219 (and-map
2220 (lambda (x) (not (free-id=? pat x)))
2221 (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
2222 (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
2223 (expand exp r '(()) mod)
2224 (let ((labels (list (gen-label))) (var (gen-var pat)))
2225 (build-call
2226 #f
2227 (build-simple-lambda
2228 #f
2229 (list (syntax->datum pat))
2230 #f
2231 (list var)
2232 '()
2233 (expand
2234 exp
2235 (extend-env labels (list (cons 'syntax (cons var 0))) r)
2236 (make-binding-wrap (list pat) labels '(()))
2237 mod))
2238 (list x))))
2239 (gen-clause x keys (cdr clauses) r pat #t exp mod)))
2240 tmp)
2241 (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
2242 (if tmp
2243 (apply (lambda (pat fender exp)
2244 (gen-clause x keys (cdr clauses) r pat fender exp mod))
2245 tmp)
2246 (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
2247 (lambda (e r w s mod)
2248 (let* ((e (source-wrap e w s mod))
2249 (tmp-1 e)
2250 (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
2251 (if tmp
2252 (apply (lambda (val key m)
2253 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
2254 (let ((x (gen-var 'tmp)))
2255 (build-call
2256 s
2257 (build-simple-lambda
2258 #f
2259 (list 'tmp)
2260 #f
2261 (list x)
2262 '()
2263 (gen-syntax-case
2264 (build-lexical-reference 'value #f 'tmp x)
2265 key
2266 m
2267 r
2268 mod))
2269 (list (expand val r '(()) mod))))
2270 (syntax-violation 'syntax-case "invalid literals list" e)))
2271 tmp)
2272 (syntax-violation
2273 #f
2274 "source expression failed to match any pattern"
2275 tmp-1))))))
2276 (set! macroexpand
2277 (lambda* (x #:optional (m 'e) (esew '(eval)))
2278 (expand-top-sequence
2279 (list x)
2280 '()
2281 '((top))
2282 #f
2283 m
2284 esew
2285 (cons 'hygiene (module-name (current-module))))))
2286 (set! identifier? (lambda (x) (nonsymbol-id? x)))
2287 (set! datum->syntax
2288 (lambda (id datum)
2289 (make-syntax-object
2290 datum
2291 (syntax-object-wrap id)
2292 (syntax-object-module id))))
2293 (set! syntax->datum (lambda (x) (strip x '(()))))
2294 (set! syntax-source (lambda (x) (source-annotation x)))
2295 (set! generate-temporaries
2296 (lambda (ls)
2297 (let ((x ls))
2298 (if (not (list? x))
2299 (syntax-violation 'generate-temporaries "invalid argument" x)))
2300 (let ((mod (cons 'hygiene (module-name (current-module)))))
2301 (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
2302 (set! free-identifier=?
2303 (lambda (x y)
2304 (let ((x x))
2305 (if (not (nonsymbol-id? x))
2306 (syntax-violation 'free-identifier=? "invalid argument" x)))
2307 (let ((x y))
2308 (if (not (nonsymbol-id? x))
2309 (syntax-violation 'free-identifier=? "invalid argument" x)))
2310 (free-id=? x y)))
2311 (set! bound-identifier=?
2312 (lambda (x y)
2313 (let ((x x))
2314 (if (not (nonsymbol-id? x))
2315 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2316 (let ((x y))
2317 (if (not (nonsymbol-id? x))
2318 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2319 (bound-id=? x y)))
2320 (set! syntax-violation
2321 (lambda* (who message form #:optional (subform #f))
2322 (let ((x who))
2323 (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
2324 (syntax-violation 'syntax-violation "invalid argument" x)))
2325 (let ((x message))
2326 (if (not (string? x))
2327 (syntax-violation 'syntax-violation "invalid argument" x)))
2328 (throw 'syntax-error
2329 who
2330 message
2331 (or (source-annotation subform) (source-annotation form))
2332 (strip form '(()))
2333 (and subform (strip subform '(()))))))
2334 (letrec*
2335 ((syntax-module
2336 (lambda (id)
2337 (let ((x id))
2338 (if (not (nonsymbol-id? x))
2339 (syntax-violation 'syntax-module "invalid argument" x)))
2340 (cdr (syntax-object-module id))))
2341 (syntax-local-binding
2342 (lambda* (id
2343 #:key
2344 (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
2345 (let ((x id))
2346 (if (not (nonsymbol-id? x))
2347 (syntax-violation 'syntax-local-binding "invalid argument" x)))
2348 (with-transformer-environment
2349 (lambda (e r w s rib mod)
2350 (letrec*
2351 ((strip-anti-mark
2352 (lambda (w)
2353 (let ((ms (car w)) (s (cdr w)))
2354 (if (and (pair? ms) (eq? (car ms) #f))
2355 (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
2356 (cons ms (if rib (cons rib s) s)))))))
2357 (call-with-values
2358 (lambda ()
2359 (resolve-identifier
2360 (syntax-object-expression id)
2361 (strip-anti-mark (syntax-object-wrap id))
2362 r
2363 (syntax-object-module id)
2364 resolve-syntax-parameters?))
2365 (lambda (type value mod)
2366 (let ((key type))
2367 (cond ((memv key '(lexical)) (values 'lexical value))
2368 ((memv key '(macro)) (values 'macro value))
2369 ((memv key '(syntax-parameter))
2370 (values 'syntax-parameter (car value)))
2371 ((memv key '(syntax)) (values 'pattern-variable value))
2372 ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
2373 ((memv key '(global)) (values 'global (cons value (cdr mod))))
2374 (else (values 'other #f)))))))))))
2375 (syntax-locally-bound-identifiers
2376 (lambda (id)
2377 (let ((x id))
2378 (if (not (nonsymbol-id? x))
2379 (syntax-violation
2380 'syntax-locally-bound-identifiers
2381 "invalid argument"
2382 x)))
2383 (locally-bound-identifiers
2384 (syntax-object-wrap id)
2385 (syntax-object-module id)))))
2386 (define! 'syntax-module syntax-module)
2387 (define! 'syntax-local-binding syntax-local-binding)
2388 (define!
2389 'syntax-locally-bound-identifiers
2390 syntax-locally-bound-identifiers))
2391 (letrec*
2392 ((match-each
2393 (lambda (e p w mod)
2394 (cond ((pair? e)
2395 (let ((first (match (car e) p w '() mod)))
2396 (and first
2397 (let ((rest (match-each (cdr e) p w mod)))
2398 (and rest (cons first rest))))))
2399 ((null? e) '())
2400 ((syntax-object? e)
2401 (match-each
2402 (syntax-object-expression e)
2403 p
2404 (join-wraps w (syntax-object-wrap e))
2405 (syntax-object-module e)))
2406 (else #f))))
2407 (match-each+
2408 (lambda (e x-pat y-pat z-pat w r mod)
2409 (let f ((e e) (w w))
2410 (cond ((pair? e)
2411 (call-with-values
2412 (lambda () (f (cdr e) w))
2413 (lambda (xr* y-pat r)
2414 (if r
2415 (if (null? y-pat)
2416 (let ((xr (match (car e) x-pat w '() mod)))
2417 (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
2418 (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
2419 (values #f #f #f)))))
2420 ((syntax-object? e)
2421 (f (syntax-object-expression e) (join-wraps w e)))
2422 (else (values '() y-pat (match e z-pat w r mod)))))))
2423 (match-each-any
2424 (lambda (e w mod)
2425 (cond ((pair? e)
2426 (let ((l (match-each-any (cdr e) w mod)))
2427 (and l (cons (wrap (car e) w mod) l))))
2428 ((null? e) '())
2429 ((syntax-object? e)
2430 (match-each-any
2431 (syntax-object-expression e)
2432 (join-wraps w (syntax-object-wrap e))
2433 mod))
2434 (else #f))))
2435 (match-empty
2436 (lambda (p r)
2437 (cond ((null? p) r)
2438 ((eq? p '_) r)
2439 ((eq? p 'any) (cons '() r))
2440 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2441 ((eq? p 'each-any) (cons '() r))
2442 (else
2443 (let ((key (vector-ref p 0)))
2444 (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
2445 ((memv key '(each+))
2446 (match-empty
2447 (vector-ref p 1)
2448 (match-empty
2449 (reverse (vector-ref p 2))
2450 (match-empty (vector-ref p 3) r))))
2451 ((memv key '(free-id atom)) r)
2452 ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
2453 (combine
2454 (lambda (r* r)
2455 (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
2456 (match*
2457 (lambda (e p w r mod)
2458 (cond ((null? p) (and (null? e) r))
2459 ((pair? p)
2460 (and (pair? e)
2461 (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
2462 ((eq? p 'each-any)
2463 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2464 (else
2465 (let ((key (vector-ref p 0)))
2466 (cond ((memv key '(each))
2467 (if (null? e)
2468 (match-empty (vector-ref p 1) r)
2469 (let ((l (match-each e (vector-ref p 1) w mod)))
2470 (and l
2471 (let collect ((l l))
2472 (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
2473 ((memv key '(each+))
2474 (call-with-values
2475 (lambda ()
2476 (match-each+
2477 e
2478 (vector-ref p 1)
2479 (vector-ref p 2)
2480 (vector-ref p 3)
2481 w
2482 r
2483 mod))
2484 (lambda (xr* y-pat r)
2485 (and r
2486 (null? y-pat)
2487 (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
2488 ((memv key '(free-id))
2489 (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2490 ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
2491 ((memv key '(vector))
2492 (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
2493 (match (lambda (e p w r mod)
2494 (cond ((not r) #f)
2495 ((eq? p '_) r)
2496 ((eq? p 'any) (cons (wrap e w mod) r))
2497 ((syntax-object? e)
2498 (match*
2499 (syntax-object-expression e)
2500 p
2501 (join-wraps w (syntax-object-wrap e))
2502 r
2503 (syntax-object-module e)))
2504 (else (match* e p w r mod))))))
2505 (set! $sc-dispatch
2506 (lambda (e p)
2507 (cond ((eq? p 'any) (list e))
2508 ((eq? p '_) '())
2509 ((syntax-object? e)
2510 (match*
2511 (syntax-object-expression e)
2512 p
2513 (syntax-object-wrap e)
2514 '()
2515 (syntax-object-module e)))
2516 (else (match* e p '(()) '() #f)))))))
2517
2518 (define with-syntax
2519 (make-syntax-transformer
2520 'with-syntax
2521 'macro
2522 (lambda (x)
2523 (let ((tmp x))
2524 (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
2525 (if tmp-1
2526 (apply (lambda (e1 e2)
2527 (cons '#(syntax-object let ((top)) (hygiene guile))
2528 (cons '() (cons e1 e2))))
2529 tmp-1)
2530 (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
2531 (if tmp-1
2532 (apply (lambda (out in e1 e2)
2533 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2534 in
2535 '()
2536 (list out
2537 (cons '#(syntax-object let ((top)) (hygiene guile))
2538 (cons '() (cons e1 e2))))))
2539 tmp-1)
2540 (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
2541 (if tmp-1
2542 (apply (lambda (out in e1 e2)
2543 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2544 (cons '#(syntax-object list ((top)) (hygiene guile)) in)
2545 '()
2546 (list out
2547 (cons '#(syntax-object let ((top)) (hygiene guile))
2548 (cons '() (cons e1 e2))))))
2549 tmp-1)
2550 (syntax-violation
2551 #f
2552 "source expression failed to match any pattern"
2553 tmp)))))))))))
2554
2555 (define syntax-rules
2556 (make-syntax-transformer
2557 'syntax-rules
2558 'macro
2559 (lambda (xx)
2560 (let ((tmp-1 xx))
2561 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
2562 (if tmp
2563 (apply (lambda (k keyword pattern template)
2564 (list '#(syntax-object lambda ((top)) (hygiene guile))
2565 '(#(syntax-object x ((top)) (hygiene guile)))
2566 (vector
2567 '(#(syntax-object macro-type ((top)) (hygiene guile))
2568 .
2569 #(syntax-object
2570 syntax-rules
2571 ((top)
2572 #(ribcage
2573 #(syntax-rules)
2574 #((top))
2575 #(((hygiene guile)
2576 .
2577 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2578 (hygiene guile)))
2579 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2580 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2581 (cons '#(syntax-object x ((top)) (hygiene guile))
2582 (cons k
2583 (map (lambda (tmp-1 tmp)
2584 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2585 (list '#(syntax-object syntax ((top)) (hygiene guile))
2586 tmp-1)))
2587 template
2588 pattern))))))
2589 tmp)
2590 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
2591 (if (if tmp
2592 (apply (lambda (k docstring keyword pattern template)
2593 (string? (syntax->datum docstring)))
2594 tmp)
2595 #f)
2596 (apply (lambda (k docstring keyword pattern template)
2597 (list '#(syntax-object lambda ((top)) (hygiene guile))
2598 '(#(syntax-object x ((top)) (hygiene guile)))
2599 docstring
2600 (vector
2601 '(#(syntax-object macro-type ((top)) (hygiene guile))
2602 .
2603 #(syntax-object
2604 syntax-rules
2605 ((top)
2606 #(ribcage
2607 #(syntax-rules)
2608 #((top))
2609 #(((hygiene guile)
2610 .
2611 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2612 (hygiene guile)))
2613 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2614 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2615 (cons '#(syntax-object x ((top)) (hygiene guile))
2616 (cons k
2617 (map (lambda (tmp-1 tmp)
2618 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2619 (list '#(syntax-object syntax ((top)) (hygiene guile))
2620 tmp-1)))
2621 template
2622 pattern))))))
2623 tmp)
2624 (syntax-violation
2625 #f
2626 "source expression failed to match any pattern"
2627 tmp-1)))))))))
2628
2629 (define define-syntax-rule
2630 (make-syntax-transformer
2631 'define-syntax-rule
2632 'macro
2633 (lambda (x)
2634 (let ((tmp-1 x))
2635 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
2636 (if tmp
2637 (apply (lambda (name pattern template)
2638 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2639 name
2640 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2641 '()
2642 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2643 template))))
2644 tmp)
2645 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
2646 (if (if tmp
2647 (apply (lambda (name pattern docstring template)
2648 (string? (syntax->datum docstring)))
2649 tmp)
2650 #f)
2651 (apply (lambda (name pattern docstring template)
2652 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2653 name
2654 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2655 '()
2656 docstring
2657 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2658 template))))
2659 tmp)
2660 (syntax-violation
2661 #f
2662 "source expression failed to match any pattern"
2663 tmp-1)))))))))
2664
2665 (define let*
2666 (make-syntax-transformer
2667 'let*
2668 'macro
2669 (lambda (x)
2670 (let ((tmp-1 x))
2671 (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
2672 (if (if tmp
2673 (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
2674 #f)
2675 (apply (lambda (let* x v e1 e2)
2676 (let f ((bindings (map list x v)))
2677 (if (null? bindings)
2678 (cons '#(syntax-object let ((top)) (hygiene guile))
2679 (cons '() (cons e1 e2)))
2680 (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
2681 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2682 (if tmp
2683 (apply (lambda (body binding)
2684 (list '#(syntax-object let ((top)) (hygiene guile))
2685 (list binding)
2686 body))
2687 tmp)
2688 (syntax-violation
2689 #f
2690 "source expression failed to match any pattern"
2691 tmp-1)))))))
2692 tmp)
2693 (syntax-violation
2694 #f
2695 "source expression failed to match any pattern"
2696 tmp-1)))))))
2697
2698 (define quasiquote
2699 (make-syntax-transformer
2700 'quasiquote
2701 'macro
2702 (letrec*
2703 ((quasi (lambda (p lev)
2704 (let ((tmp p))
2705 (let ((tmp-1 ($sc-dispatch
2706 tmp
2707 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
2708 (if tmp-1
2709 (apply (lambda (p)
2710 (if (= lev 0)
2711 (list "value" p)
2712 (quasicons
2713 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2714 (quasi (list p) (- lev 1)))))
2715 tmp-1)
2716 (let ((tmp-1 ($sc-dispatch
2717 tmp
2718 '(#(free-id
2719 #(syntax-object
2720 quasiquote
2721 ((top)
2722 #(ribcage
2723 #(quasiquote)
2724 #((top))
2725 #(((hygiene guile)
2726 .
2727 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2728 (hygiene guile)))
2729 any))))
2730 (if tmp-1
2731 (apply (lambda (p)
2732 (quasicons
2733 '("quote"
2734 #(syntax-object
2735 quasiquote
2736 ((top)
2737 #(ribcage
2738 #(quasiquote)
2739 #((top))
2740 #(((hygiene guile)
2741 .
2742 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2743 (hygiene guile)))
2744 (quasi (list p) (+ lev 1))))
2745 tmp-1)
2746 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2747 (if tmp-1
2748 (apply (lambda (p q)
2749 (let ((tmp-1 p))
2750 (let ((tmp ($sc-dispatch
2751 tmp-1
2752 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2753 .
2754 each-any))))
2755 (if tmp
2756 (apply (lambda (p)
2757 (if (= lev 0)
2758 (quasilist*
2759 (map (lambda (tmp) (list "value" tmp)) p)
2760 (quasi q lev))
2761 (quasicons
2762 (quasicons
2763 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2764 (quasi p (- lev 1)))
2765 (quasi q lev))))
2766 tmp)
2767 (let ((tmp ($sc-dispatch
2768 tmp-1
2769 '(#(free-id
2770 #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2771 .
2772 each-any))))
2773 (if tmp
2774 (apply (lambda (p)
2775 (if (= lev 0)
2776 (quasiappend
2777 (map (lambda (tmp) (list "value" tmp)) p)
2778 (quasi q lev))
2779 (quasicons
2780 (quasicons
2781 '("quote"
2782 #(syntax-object
2783 unquote-splicing
2784 ((top))
2785 (hygiene guile)))
2786 (quasi p (- lev 1)))
2787 (quasi q lev))))
2788 tmp)
2789 (quasicons (quasi p lev) (quasi q lev))))))))
2790 tmp-1)
2791 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2792 (if tmp-1
2793 (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
2794 (let ((p tmp)) (list "quote" p)))))))))))))
2795 (vquasi
2796 (lambda (p lev)
2797 (let ((tmp p))
2798 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2799 (if tmp-1
2800 (apply (lambda (p q)
2801 (let ((tmp-1 p))
2802 (let ((tmp ($sc-dispatch
2803 tmp-1
2804 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2805 .
2806 each-any))))
2807 (if tmp
2808 (apply (lambda (p)
2809 (if (= lev 0)
2810 (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
2811 (quasicons
2812 (quasicons
2813 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2814 (quasi p (- lev 1)))
2815 (vquasi q lev))))
2816 tmp)
2817 (let ((tmp ($sc-dispatch
2818 tmp-1
2819 '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2820 .
2821 each-any))))
2822 (if tmp
2823 (apply (lambda (p)
2824 (if (= lev 0)
2825 (quasiappend
2826 (map (lambda (tmp) (list "value" tmp)) p)
2827 (vquasi q lev))
2828 (quasicons
2829 (quasicons
2830 '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2831 (quasi p (- lev 1)))
2832 (vquasi q lev))))
2833 tmp)
2834 (quasicons (quasi p lev) (vquasi q lev))))))))
2835 tmp-1)
2836 (let ((tmp-1 ($sc-dispatch tmp '())))
2837 (if tmp-1
2838 (apply (lambda () '("quote" ())) tmp-1)
2839 (syntax-violation
2840 #f
2841 "source expression failed to match any pattern"
2842 tmp))))))))
2843 (quasicons
2844 (lambda (x y)
2845 (let ((tmp-1 (list x y)))
2846 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2847 (if tmp
2848 (apply (lambda (x y)
2849 (let ((tmp y))
2850 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2851 (if tmp-1
2852 (apply (lambda (dy)
2853 (let ((tmp x))
2854 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
2855 (if tmp
2856 (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
2857 (if (null? dy) (list "list" x) (list "list*" x y))))))
2858 tmp-1)
2859 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
2860 (if tmp-1
2861 (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
2862 (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
2863 (if tmp
2864 (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
2865 (list "list*" x y)))))))))
2866 tmp)
2867 (syntax-violation
2868 #f
2869 "source expression failed to match any pattern"
2870 tmp-1))))))
2871 (quasiappend
2872 (lambda (x y)
2873 (let ((tmp y))
2874 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
2875 (if tmp
2876 (apply (lambda ()
2877 (if (null? x)
2878 '("quote" ())
2879 (if (null? (cdr x))
2880 (car x)
2881 (let ((tmp-1 x))
2882 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2883 (if tmp
2884 (apply (lambda (p) (cons "append" p)) tmp)
2885 (syntax-violation
2886 #f
2887 "source expression failed to match any pattern"
2888 tmp-1)))))))
2889 tmp)
2890 (if (null? x)
2891 y
2892 (let ((tmp-1 (list x y)))
2893 (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
2894 (if tmp
2895 (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
2896 (syntax-violation
2897 #f
2898 "source expression failed to match any pattern"
2899 tmp-1))))))))))
2900 (quasilist*
2901 (lambda (x y)
2902 (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
2903 (quasivector
2904 (lambda (x)
2905 (let ((tmp x))
2906 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
2907 (if tmp
2908 (apply (lambda (x) (list "quote" (list->vector x))) tmp)
2909 (let f ((y x)
2910 (k (lambda (ls)
2911 (let ((tmp-1 ls))
2912 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2913 (if tmp
2914 (apply (lambda (t) (cons "vector" t)) tmp)
2915 (syntax-violation
2916 #f
2917 "source expression failed to match any pattern"
2918 tmp-1)))))))
2919 (let ((tmp y))
2920 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
2921 (if tmp-1
2922 (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
2923 tmp-1)
2924 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2925 (if tmp-1
2926 (apply (lambda (y) (k y)) tmp-1)
2927 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2928 (if tmp-1
2929 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
2930 (let ((else tmp))
2931 (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
2932 (emit (lambda (x)
2933 (let ((tmp x))
2934 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2935 (if tmp-1
2936 (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
2937 tmp-1)
2938 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2939 (if tmp-1
2940 (apply (lambda (x)
2941 (let ((tmp-1 (map emit x)))
2942 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2943 (if tmp
2944 (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
2945 tmp)
2946 (syntax-violation
2947 #f
2948 "source expression failed to match any pattern"
2949 tmp-1)))))
2950 tmp-1)
2951 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2952 (if tmp-1
2953 (apply (lambda (x y)
2954 (let f ((x* x))
2955 (if (null? x*)
2956 (emit y)
2957 (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
2958 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2959 (if tmp
2960 (apply (lambda (t-1 t)
2961 (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
2962 tmp)
2963 (syntax-violation
2964 #f
2965 "source expression failed to match any pattern"
2966 tmp-1)))))))
2967 tmp-1)
2968 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
2969 (if tmp-1
2970 (apply (lambda (x)
2971 (let ((tmp-1 (map emit x)))
2972 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2973 (if tmp
2974 (apply (lambda (t)
2975 (cons '#(syntax-object append ((top)) (hygiene guile)) t))
2976 tmp)
2977 (syntax-violation
2978 #f
2979 "source expression failed to match any pattern"
2980 tmp-1)))))
2981 tmp-1)
2982 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
2983 (if tmp-1
2984 (apply (lambda (x)
2985 (let ((tmp-1 (map emit x)))
2986 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2987 (if tmp
2988 (apply (lambda (t)
2989 (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
2990 tmp)
2991 (syntax-violation
2992 #f
2993 "source expression failed to match any pattern"
2994 tmp-1)))))
2995 tmp-1)
2996 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
2997 (if tmp-1
2998 (apply (lambda (x)
2999 (let ((tmp (emit x)))
3000 (let ((t tmp))
3001 (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
3002 tmp-1)
3003 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
3004 (if tmp-1
3005 (apply (lambda (x) x) tmp-1)
3006 (syntax-violation
3007 #f
3008 "source expression failed to match any pattern"
3009 tmp)))))))))))))))))))
3010 (lambda (x)
3011 (let ((tmp-1 x))
3012 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3013 (if tmp
3014 (apply (lambda (e) (emit (quasi e 0))) tmp)
3015 (syntax-violation
3016 #f
3017 "source expression failed to match any pattern"
3018 tmp-1))))))))
3019
3020 (define include
3021 (make-syntax-transformer
3022 'include
3023 'macro
3024 (lambda (x)
3025 (letrec*
3026 ((read-file
3027 (lambda (fn dir k)
3028 (let ((p (open-input-file
3029 (if (absolute-file-name? fn) fn (in-vicinity dir fn)))))
3030 (let f ((x (read p)) (result '()))
3031 (if (eof-object? x)
3032 (begin (close-input-port p) (reverse result))
3033 (f (read p) (cons (datum->syntax k x) result))))))))
3034 (let ((src (syntax-source x)))
3035 (let ((file (if src (assq-ref src 'filename) #f)))
3036 (let ((dir (if (string? file) (dirname file) #f)))
3037 (let ((tmp-1 x))
3038 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3039 (if tmp
3040 (apply (lambda (k filename)
3041 (let ((fn (syntax->datum filename)))
3042 (let ((tmp-1 (read-file fn dir filename)))
3043 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
3044 (if tmp
3045 (apply (lambda (exp)
3046 (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
3047 tmp)
3048 (syntax-violation
3049 #f
3050 "source expression failed to match any pattern"
3051 tmp-1))))))
3052 tmp)
3053 (syntax-violation
3054 #f
3055 "source expression failed to match any pattern"
3056 tmp-1)))))))))))
3057
3058 (define include-from-path
3059 (make-syntax-transformer
3060 'include-from-path
3061 'macro
3062 (lambda (x)
3063 (let ((tmp-1 x))
3064 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3065 (if tmp
3066 (apply (lambda (k filename)
3067 (let ((fn (syntax->datum filename)))
3068 (let ((tmp (datum->syntax
3069 filename
3070 (let ((t (%search-load-path fn)))
3071 (if t
3072 t
3073 (syntax-violation
3074 'include-from-path
3075 "file not found in path"
3076 x
3077 filename))))))
3078 (let ((fn tmp))
3079 (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
3080 tmp)
3081 (syntax-violation
3082 #f
3083 "source expression failed to match any pattern"
3084 tmp-1)))))))
3085
3086 (define unquote
3087 (make-syntax-transformer
3088 'unquote
3089 'macro
3090 (lambda (x)
3091 (syntax-violation
3092 'unquote
3093 "expression not valid outside of quasiquote"
3094 x))))
3095
3096 (define unquote-splicing
3097 (make-syntax-transformer
3098 'unquote-splicing
3099 'macro
3100 (lambda (x)
3101 (syntax-violation
3102 'unquote-splicing
3103 "expression not valid outside of quasiquote"
3104 x))))
3105
3106 (define make-variable-transformer
3107 (lambda (proc)
3108 (if (procedure? proc)
3109 (let ((trans (lambda (x) (proc x))))
3110 (set-procedure-property! trans 'variable-transformer #t)
3111 trans)
3112 (error "variable transformer not a procedure" proc))))
3113
3114 (define identifier-syntax
3115 (make-syntax-transformer
3116 'identifier-syntax
3117 'macro
3118 (lambda (xx)
3119 (let ((tmp-1 xx))
3120 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3121 (if tmp
3122 (apply (lambda (e)
3123 (list '#(syntax-object lambda ((top)) (hygiene guile))
3124 '(#(syntax-object x ((top)) (hygiene guile)))
3125 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3126 .
3127 #(syntax-object
3128 identifier-syntax
3129 ((top)
3130 #(ribcage
3131 #(identifier-syntax)
3132 #((top))
3133 #(((hygiene guile)
3134 .
3135 #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
3136 (hygiene guile))))
3137 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3138 '#(syntax-object x ((top)) (hygiene guile))
3139 '()
3140 (list '#(syntax-object id ((top)) (hygiene guile))
3141 '(#(syntax-object identifier? ((top)) (hygiene guile))
3142 (#(syntax-object syntax ((top)) (hygiene guile))
3143 #(syntax-object id ((top)) (hygiene guile))))
3144 (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
3145 (list '(#(syntax-object _ ((top)) (hygiene guile))
3146 #(syntax-object x ((top)) (hygiene guile))
3147 #(syntax-object ... ((top)) (hygiene guile)))
3148 (list '#(syntax-object syntax ((top)) (hygiene guile))
3149 (cons e
3150 '(#(syntax-object x ((top)) (hygiene guile))
3151 #(syntax-object ... ((top)) (hygiene guile)))))))))
3152 tmp)
3153 (let ((tmp ($sc-dispatch
3154 tmp-1
3155 '(_ (any any)
3156 ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
3157 any)))))
3158 (if (if tmp
3159 (apply (lambda (id exp1 var val exp2)
3160 (if (identifier? id) (identifier? var) #f))
3161 tmp)
3162 #f)
3163 (apply (lambda (id exp1 var val exp2)
3164 (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
3165 (list '#(syntax-object lambda ((top)) (hygiene guile))
3166 '(#(syntax-object x ((top)) (hygiene guile)))
3167 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3168 .
3169 #(syntax-object variable-transformer ((top)) (hygiene guile))))
3170 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3171 '#(syntax-object x ((top)) (hygiene guile))
3172 '(#(syntax-object set! ((top)) (hygiene guile)))
3173 (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
3174 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
3175 (list (cons id
3176 '(#(syntax-object x ((top)) (hygiene guile))
3177 #(syntax-object ... ((top)) (hygiene guile))))
3178 (list '#(syntax-object syntax ((top)) (hygiene guile))
3179 (cons exp1
3180 '(#(syntax-object x ((top)) (hygiene guile))
3181 #(syntax-object ... ((top)) (hygiene guile))))))
3182 (list id
3183 (list '#(syntax-object identifier? ((top)) (hygiene guile))
3184 (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
3185 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
3186 tmp)
3187 (syntax-violation
3188 #f
3189 "source expression failed to match any pattern"
3190 tmp-1)))))))))
3191
3192 (define define*
3193 (make-syntax-transformer
3194 'define*
3195 'macro
3196 (lambda (x)
3197 (let ((tmp-1 x))
3198 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
3199 (if tmp
3200 (apply (lambda (id args b0 b1)
3201 (list '#(syntax-object define ((top)) (hygiene guile))
3202 id
3203 (cons '#(syntax-object lambda* ((top)) (hygiene guile))
3204 (cons args (cons b0 b1)))))
3205 tmp)
3206 (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
3207 (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
3208 (apply (lambda (id val)
3209 (list '#(syntax-object define ((top)) (hygiene guile)) id val))
3210 tmp)
3211 (syntax-violation
3212 #f
3213 "source expression failed to match any pattern"
3214 tmp-1)))))))))
3215
Unnamed repository; edit this file 'description' to name the repository.