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