1 (eval-when (compile) (set-current-module (resolve-module (quote (guile)))))
6 (lambda (src) (make-struct (vector-ref %expanded-vtables 0) 0 src)))
9 (make-struct (vector-ref %expanded-vtables 1) 0 src exp)))
12 (make-struct (vector-ref %expanded-vtables 2) 0 src name)))
14 (lambda (src name gensym)
15 (make-struct (vector-ref %expanded-vtables 3) 0 src name gensym)))
17 (lambda (src name gensym exp)
18 (make-struct (vector-ref %expanded-vtables 4) 0 src name gensym exp)))
20 (lambda (src mod name public?)
21 (make-struct (vector-ref %expanded-vtables 5) 0 src mod name public?)))
23 (lambda (src mod name public? exp)
25 (vector-ref %expanded-vtables 6)
34 (make-struct (vector-ref %expanded-vtables 7) 0 src name)))
36 (lambda (src name exp)
37 (make-struct (vector-ref %expanded-vtables 8) 0 src name exp)))
39 (lambda (src name exp)
40 (make-struct (vector-ref %expanded-vtables 9) 0 src name exp)))
42 (lambda (src test consequent alternate)
44 (vector-ref %expanded-vtables 10)
51 (lambda (src proc args)
52 (make-struct (vector-ref %expanded-vtables 11) 0 src proc args)))
54 (lambda (src name args)
55 (make-struct (vector-ref %expanded-vtables 12) 0 src name args)))
57 (lambda (src head tail)
58 (make-struct (vector-ref %expanded-vtables 13) 0 src head tail)))
60 (lambda (src meta body)
61 (make-struct (vector-ref %expanded-vtables 14) 0 src meta body)))
63 (lambda (src req opt rest kw inits gensyms body alternate)
65 (vector-ref %expanded-vtables 15)
77 (lambda (src names gensyms vals body)
79 (vector-ref %expanded-vtables 16)
87 (lambda (src in-order? names gensyms vals body)
89 (vector-ref %expanded-vtables 17)
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)))
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)
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))
124 (let ((val (variable-ref v)))
127 (cons (macro-type val) (macro-binding val)))))))))
130 (if (and s (supports-source-properties? e))
131 (set-source-properties! e s))
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)))
141 (lambda (source fun-exp arg-exps)
142 (make-call source fun-exp arg-exps)))
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)))
153 (lambda (mod var modref-cont bare-cont)
156 (let ((kind (car mod)) (mod (cdr mod)))
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)
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)
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)
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)
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)))
193 (lambda (src req rest vars meta exp)
197 (make-lambda-case src req #f rest #f '() vars exp #f))))
199 (lambda (src meta body) (make-lambda src meta body)))
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)))
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)))
209 (if (null? (cdr exps))
211 (make-seq src (car exps) (build-sequence #f (cdr exps))))))
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))))
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)
228 (build-call src (build-lexical-reference 'fun src f-name f) val-exps))))))
230 (lambda (src in-order? ids vars val-exps body-exp)
234 (for-each maybe-name-value! ids val-exps)
235 (make-letrec src in-order? ids vars val-exps body-exp)))))
237 (lambda (expression wrap module)
238 (vector 'syntax-object expression wrap module)))
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)))
255 (let ((props (source-properties
256 (if (syntax-object? x) (syntax-object-expression x) x))))
257 (and (pair? props) props))))
259 (lambda (labels bindings r)
265 (cons (cons (car labels) (car bindings)) r)))))
267 (lambda (labels vars r)
273 (cons (cons (car labels) (cons 'lexical (car vars))) r)))))
279 (if (memq (cadr a) '(macro syntax-parameter))
280 (cons a (macros-only-env (cdr r)))
281 (macros-only-env (cdr r)))))))
283 (lambda (type sym val) (put-global-definition-hook sym type val)))
286 (and (syntax-object? x) (symbol? (syntax-object-expression x)))))
290 (and (syntax-object? x) (symbol? (syntax-object-expression x))))))
293 (if (syntax-object? x)
295 (syntax-object-expression x)
296 (join-marks (car w) (car (syntax-object-wrap x))))
297 (values x (car w)))))
300 (string-append "l-" (session-id) (symbol->string (gensym "-")))))
303 (if (null? ls) '() (cons (gen-label) (gen-labels (cdr ls))))))
305 (lambda (symnames marks labels)
306 (vector 'ribcage symnames marks labels)))
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)))
319 (lambda (w) (cons (cons #f (car w)) (cons 'shift (cdr w)))))
321 (lambda (ribcage id label)
322 (set-ribcage-symnames!
324 (cons (syntax-object-expression id) (ribcage-symnames ribcage)))
327 (cons (car (syntax-object-wrap id)) (ribcage-marks ribcage)))
328 (set-ribcage-labels! ribcage (cons label (ribcage-labels ribcage)))))
330 (lambda (ids labels 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))
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)))
346 (smart-append (lambda (m1 m2) (if (null? m2) m1 (append m1 m2))))
349 (let ((m1 (car w1)) (s1 (cdr w1)))
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)))
359 (eq? (car x) (car y))
360 (same-marks? (cdr x) (cdr y))))))
365 (lambda (sym subst marks mod)
368 (let ((fst (car subst)))
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))))))))
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)))
383 (if (equal? mod (car n))
384 (values (cdr n) marks)
385 (f (cdr symnames) (+ i 1)))
387 (else (f (cdr symnames) (+ i 1)))))))
389 (lambda (sym subst marks symnames ribcage mod)
390 (let ((n (vector-length symnames)))
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)))
397 (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1)))
399 (else (f (+ i 1)))))))))
400 (cond ((symbol? id) (or (search id (cdr w) (car w) mod) 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))))
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
413 ((scan (lambda (subst results)
416 (let ((fst (car subst)))
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))))))))
424 (lambda (subst symnames marks results)
425 (let f ((symnames symnames) (marks marks) (results results))
427 (scan (cdr subst) results)
430 (cons (wrap (car symnames) (anti-mark (cons (car marks) subst)) mod)
433 (lambda (subst symnames marks results)
434 (let ((n (vector-length symnames)))
435 (let f ((i 0) (results results))
437 (scan (cdr subst) results)
439 (cons (wrap (vector-ref symnames i)
440 (anti-mark (cons (vector-ref marks i) subst))
443 (scan (cdr w) '()))))
445 (lambda (id w r mod resolve-syntax-parameters?)
447 ((resolve-syntax-parameters
449 (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter))
450 (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b))))
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)))))
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 (resolve-identifier n w r mod resolve-syntax-parameters?))
470 (if (syntax-object? id) (syntax-object-module id) mod)))
474 (if (syntax-object? id) (syntax-object-module id) mod)))
475 (else (error "unexpected id-var-name" id w n)))))))
476 (transformer-environment
479 (error "called outside the dynamic extent of a syntax transformer"))))
480 (with-transformer-environment
481 (lambda (k) ((fluid-ref transformer-environment) k)))
484 (let* ((mi (and (syntax-object? i) (syntax-object-module i)))
485 (mj (and (syntax-object? j) (syntax-object-module j)))
486 (ni (id-var-name i '(()) mi))
487 (nj (id-var-name j '(()) mj)))
492 (if mod (resolve-module (cdr mod)) (current-module))
493 (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x))))))
494 (cond ((syntax-object? ni) (free-id=? ni j))
495 ((syntax-object? nj) (free-id=? i nj))
498 (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x)))
499 (let ((bi (id-module-binding i mi)))
501 (eq? bi (id-module-binding j mj))
502 (and (not (id-module-binding j mj)) (eq? ni nj))))
503 (eq? (id-module-binding i mi) (id-module-binding j mj))))
504 (else (equal? ni nj)))))))
507 (if (and (syntax-object? i) (syntax-object? j))
508 (and (eq? (syntax-object-expression i) (syntax-object-expression j))
510 (car (syntax-object-wrap i))
511 (car (syntax-object-wrap j))))
515 (and (let all-ids? ((ids ids))
516 (or (null? ids) (and (id? (car ids)) (all-ids? (cdr ids)))))
517 (distinct-bound-ids? ids))))
520 (let distinct? ((ids ids))
522 (and (not (bound-id-member? (car ids) (cdr ids)))
523 (distinct? (cdr ids)))))))
526 (and (not (null? list))
527 (or (bound-id=? x (car list)) (bound-id-member? x (cdr list))))))
528 (wrap (lambda (x w defmod)
529 (cond ((and (null? (car w)) (null? (cdr w))) x)
532 (syntax-object-expression x)
533 (join-wraps w (syntax-object-wrap x))
534 (syntax-object-module x)))
536 (else (make-syntax-object x w defmod)))))
538 (lambda (x w s defmod) (wrap (decorate-source x s) w defmod)))
540 (lambda (body r w s mod)
543 (let dobody ((body body) (r r) (w w) (mod mod))
546 (let ((first (expand (car body) r w mod)))
547 (cons first (dobody (cdr body) r w mod))))))))
549 (lambda (body r w s m esew mod)
550 (let* ((r (cons '("placeholder" placeholder) r))
551 (ribcage (make-ribcage '() '() '()))
552 (w (cons (car w) (cons ribcage (cdr w)))))
556 (let ((mod (cons 'hygiene (module-name (current-module)))))
560 (cons (syntax-object-module id) (wrap var '((top)) mod))))))
561 (macro-introduced-identifier?
562 (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top)))))
564 (lambda (id orig-form)
566 (syntax-object-expression id)
570 (hash (syntax->datum orig-form) most-positive-fixnum)
572 (parse (lambda (body r w s m esew mod)
573 (let lp ((body body) (exps '()))
576 (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps))))))
578 (lambda (x r w s m esew mod)
580 (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f))
581 (lambda (type value form e w s mod)
583 (cond ((memv key '(define-form))
584 (let* ((id (wrap value w mod))
586 (var (if (macro-introduced-identifier? id)
587 (fresh-derived-name id x)
588 (syntax-object-expression id))))
589 (record-definition! id var)
590 (list (if (eq? m 'c&e)
591 (let ((x (build-global-definition s var (expand e r w mod))))
592 (top-level-eval-hook x mod)
594 (lambda () (build-global-definition s var (expand e r w mod)))))))
595 ((memv key '(define-syntax-form define-syntax-parameter-form))
596 (let* ((id (wrap value w mod))
598 (var (if (macro-introduced-identifier? id)
599 (fresh-derived-name id x)
600 (syntax-object-expression id))))
601 (record-definition! id var)
603 (cond ((memv key '(c))
604 (cond ((memq 'compile esew)
605 (let ((e (expand-install-global var type (expand e r w mod))))
606 (top-level-eval-hook e mod)
607 (if (memq 'load esew) (list (lambda () e)) '())))
609 (list (lambda () (expand-install-global var type (expand e r w mod)))))
612 (let ((e (expand-install-global var type (expand e r w mod))))
613 (top-level-eval-hook e mod)
614 (list (lambda () e))))
616 (if (memq 'eval esew)
618 (expand-install-global var type (expand e r w mod))
621 ((memv key '(begin-form))
622 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
624 (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp)
627 "source expression failed to match any pattern"
629 ((memv key '(local-syntax-form))
637 (lambda (forms r w s mod) (parse forms r w s m esew mod))))
638 ((memv key '(eval-when-form))
639 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
641 (apply (lambda (x e1 e2)
642 (let ((when-list (parse-when-list e x)) (body (cons e1 e2)))
644 ((recurse (lambda (m esew) (parse body r w s m esew mod))))
646 (if (memq 'eval when-list)
647 (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval))
649 (if (memq 'expand when-list)
651 (expand-top-sequence body r w s 'e '(eval) mod)
654 ((memq 'load when-list)
655 (cond ((or (memq 'compile when-list)
656 (memq 'expand when-list)
657 (and (eq? m 'c&e) (memq 'eval when-list)))
658 (recurse 'c&e '(compile load)))
659 ((memq m '(c c&e)) (recurse 'c '(load)))
661 ((or (memq 'compile when-list)
662 (memq 'expand when-list)
663 (and (eq? m 'c&e) (memq 'eval when-list)))
665 (expand-top-sequence body r w s 'e '(eval) mod)
672 "source expression failed to match any pattern"
675 (list (if (eq? m 'c&e)
676 (let ((x (expand-expr type value form e r w s mod)))
677 (top-level-eval-hook x mod)
679 (lambda () (expand-expr type value form e r w s mod))))))))))))
680 (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod)))))
681 (if (null? exps) (build-void s) (build-sequence s exps)))))))
682 (expand-install-global
683 (lambda (name type e)
684 (build-global-definition
689 'make-syntax-transformer
690 (if (eq? type 'define-syntax-parameter-form)
691 (list (build-data #f name)
692 (build-data #f 'syntax-parameter)
693 (build-primcall #f 'list (list e)))
694 (list (build-data #f name) (build-data #f 'macro) e))))))
696 (lambda (e when-list)
697 (let ((result (strip when-list '(()))))
699 (cond ((null? l) result)
700 ((memq (car l) '(compile load eval expand)) (lp (cdr l)))
701 (else (syntax-violation 'eval-when "invalid situation" e (car l))))))))
703 (lambda (e r w s rib mod for-car?)
706 (lambda () (resolve-identifier e w r mod #t))
707 (lambda (type value mod*)
709 (cond ((memv key '(macro))
711 (values type value e e w s mod)
713 (expand-macro value e r w s rib mod)
720 ((memv key '(global)) (values type value e value w s mod*))
721 (else (values type value e e w s mod)))))))
723 (let ((first (car e)))
725 (lambda () (syntax-type first r w s rib mod #t))
726 (lambda (ftype fval fform fe fw fs fmod)
728 (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
729 ((memv key '(global))
730 (if (equal? fmod '(primitive))
731 (values 'primitive-call fval e e w s mod)
732 (values 'global-call (make-syntax-object fval w fmod) e e w s mod)))
735 (expand-macro fval e r w s rib mod)
742 ((memv key '(module-ref))
744 (lambda () (fval e r w mod))
745 (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?))))
746 ((memv key '(core)) (values 'core-form fval e e w s mod))
747 ((memv key '(local-syntax))
748 (values 'local-syntax-form fval e e w s mod))
749 ((memv key '(begin)) (values 'begin-form #f e e w s mod))
750 ((memv key '(eval-when)) (values 'eval-when-form #f e e w s mod))
751 ((memv key '(define))
752 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
753 (if (and tmp-1 (apply (lambda (name val) (id? name)) tmp-1))
754 (apply (lambda (name val) (values 'define-form name e val w s mod))
756 (let ((tmp-1 ($sc-dispatch tmp '(_ (any . any) any . each-any))))
758 (apply (lambda (name args e1 e2)
759 (and (id? name) (valid-bound-ids? (lambda-var-list args))))
761 (apply (lambda (name args e1 e2)
767 (cons '#(syntax-object lambda ((top)) (hygiene guile))
768 (wrap (cons args (cons e1 e2)) w mod))
774 (let ((tmp-1 ($sc-dispatch tmp '(_ any))))
775 (if (and tmp-1 (apply (lambda (name) (id? name)) tmp-1))
776 (apply (lambda (name)
781 '(#(syntax-object if ((top)) (hygiene guile)) #f #f)
788 "source expression failed to match any pattern"
790 ((memv key '(define-syntax))
791 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
792 (if (and tmp (apply (lambda (name val) (id? name)) tmp))
793 (apply (lambda (name val) (values 'define-syntax-form name e val w s mod))
797 "source expression failed to match any pattern"
799 ((memv key '(define-syntax-parameter))
800 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
801 (if (and tmp (apply (lambda (name val) (id? name)) tmp))
802 (apply (lambda (name val)
803 (values 'define-syntax-parameter-form name e val w s mod))
807 "source expression failed to match any pattern"
809 (else (values 'call #f e e w s mod))))))))
812 (syntax-object-expression e)
814 (join-wraps w (syntax-object-wrap e))
815 (or (source-annotation e) s)
817 (or (syntax-object-module e) mod)
819 ((self-evaluating? e) (values 'constant #f e e w s mod))
820 (else (values 'other #f e e w s mod)))))
824 (lambda () (syntax-type e r w (source-annotation e) #f mod #f))
825 (lambda (type value form e w s mod)
826 (expand-expr type value form e r w s mod)))))
828 (lambda (type value form e r w s mod)
830 (cond ((memv key '(lexical)) (build-lexical-reference 'value s e value))
831 ((memv key '(core core-form)) (value e r w s mod))
832 ((memv key '(module-ref))
834 (lambda () (value e r w mod))
835 (lambda (e r w s mod) (expand e r w mod))))
836 ((memv key '(lexical-call))
839 (build-lexical-reference
841 (source-annotation id)
842 (if (syntax-object? id) (syntax->datum id) id)
849 ((memv key '(global-call))
851 (build-global-reference
852 (source-annotation (car e))
853 (if (syntax-object? value) (syntax-object-expression value) value)
854 (if (syntax-object? value) (syntax-object-module value) mod))
860 ((memv key '(primitive-call))
861 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
864 (build-primcall s value (map (lambda (e) (expand e r w mod)) e)))
868 "source expression failed to match any pattern"
870 ((memv key '(constant))
871 (build-data s (strip (source-wrap e w s mod) '(()))))
872 ((memv key '(global)) (build-global-reference s value mod))
874 (expand-call (expand (car e) r w mod) e r w s mod))
875 ((memv key '(begin-form))
876 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any))))
878 (apply (lambda (e1 e2) (expand-sequence (cons e1 e2) r w s mod))
880 (let ((tmp-1 ($sc-dispatch tmp '(_))))
885 "sequence of zero expressions"
886 (source-wrap e w s mod)))
890 "source expression failed to match any pattern"
892 ((memv key '(local-syntax-form))
893 (expand-local-syntax value e r w s mod expand-sequence))
894 ((memv key '(eval-when-form))
895 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any))))
897 (apply (lambda (x e1 e2)
898 (let ((when-list (parse-when-list e x)))
899 (if (memq 'eval when-list)
900 (expand-sequence (cons e1 e2) r w s mod)
905 "source expression failed to match any pattern"
908 '(define-form define-syntax-form define-syntax-parameter-form))
911 "definition in expression context, where definitions are not allowed,"
912 (source-wrap form w s mod)))
913 ((memv key '(syntax))
916 "reference to pattern variable outside syntax form"
917 (source-wrap e w s mod)))
918 ((memv key '(displaced-lexical))
921 "reference to identifier outside its scope"
922 (source-wrap e w s mod)))
924 (syntax-violation #f "unexpected syntax" (source-wrap e w s mod)))))))
926 (lambda (x e r w s mod)
927 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any))))
929 (apply (lambda (e0 e1)
930 (build-call s x (map (lambda (e) (expand e r w mod)) e1)))
934 "source expression failed to match any pattern"
937 (lambda (p e r w s rib mod)
939 ((rebuild-macro-output
943 (cons (rebuild-macro-output (car x) m)
944 (rebuild-macro-output (cdr x) m))
947 (let ((w (syntax-object-wrap x)))
948 (let ((ms (car w)) (ss (cdr w)))
949 (if (and (pair? ms) (eq? (car ms) #f))
951 (syntax-object-expression x)
952 (cons (cdr ms) (if rib (cons rib (cdr ss)) (cdr ss)))
953 (syntax-object-module x))
955 (decorate-source (syntax-object-expression x) s)
957 (if rib (cons rib (cons 'shift ss)) (cons 'shift ss)))
958 (syntax-object-module x))))))
960 (let* ((n (vector-length x)) (v (decorate-source (make-vector n) s)))
965 (vector-set! v i (rebuild-macro-output (vector-ref x i) m))
970 "encountered raw symbol in macro output"
971 (source-wrap e w (cdr w) mod)
973 (else (decorate-source x s))))))
974 (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod))))
979 (rebuild-macro-output
980 (p (source-wrap e (anti-mark w) s mod))
981 (gensym (string-append "m-" (session-id) "-")))))))))
983 (lambda (body outer-form r w mod)
984 (let* ((r (cons '("placeholder" placeholder) r))
985 (ribcage (make-ribcage '() '() '()))
986 (w (cons (car w) (cons ribcage (cdr w)))))
987 (let parse ((body (map (lambda (x) (cons r (wrap x w mod))) body))
995 (syntax-violation #f "no expressions in body" outer-form)
996 (let ((e (cdar body)) (er (caar body)))
999 (syntax-type e er '(()) (source-annotation e) ribcage mod #f))
1000 (lambda (type value form e w s mod)
1002 (cond ((memv key '(define-form))
1003 (let ((id (wrap value w mod)) (label (gen-label)))
1004 (let ((var (gen-var id)))
1005 (extend-ribcage! ribcage id label)
1011 (cons (cons er (wrap e w mod)) vals)
1012 (cons (cons 'lexical var) bindings)))))
1013 ((memv key '(define-syntax-form))
1014 (let ((id (wrap value w mod))
1016 (trans-r (macros-only-env er)))
1017 (extend-ribcage! ribcage id label)
1022 (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod)))
1024 (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
1025 ((memv key '(define-syntax-parameter-form))
1026 (let ((id (wrap value w mod))
1028 (trans-r (macros-only-env er)))
1029 (extend-ribcage! ribcage id label)
1034 (list (cons 'syntax-parameter
1035 (list (eval-local-transformer (expand e trans-r w mod) mod))))
1037 (parse (cdr body) (cons id ids) labels var-ids vars vals bindings)))
1038 ((memv key '(begin-form))
1039 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any))))
1042 (parse (let f ((forms e1))
1045 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1055 "source expression failed to match any pattern"
1057 ((memv key '(local-syntax-form))
1058 (expand-local-syntax
1065 (lambda (forms er w s mod)
1066 (parse (let f ((forms forms))
1069 (cons (cons er (wrap (car forms) w mod)) (f (cdr forms)))))
1079 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1080 (cons (cons er (source-wrap e w s mod)) (cdr body)))))
1082 (if (not (valid-bound-ids? ids))
1085 "invalid or duplicate identifier in definition"
1087 (set-cdr! r (extend-env labels bindings (cdr r)))
1091 (reverse (map syntax->datum var-ids))
1093 (map (lambda (x) (expand (cdr x) (car x) '(()) mod)) (reverse vals))
1096 (map (lambda (x) (expand (cdr x) (car x) '(()) mod))
1097 (cons (cons er (source-wrap e w s mod)) (cdr body))))))))))))))))
1098 (expand-local-syntax
1099 (lambda (rec? e r w s mod k)
1101 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1103 (apply (lambda (id val e1 e2)
1105 (if (not (valid-bound-ids? ids))
1106 (syntax-violation #f "duplicate bound keyword" e)
1107 (let* ((labels (gen-labels ids)) (new-w (make-binding-wrap ids labels w)))
1111 (let ((w (if rec? new-w w)) (trans-r (macros-only-env r)))
1113 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1122 "bad local syntax definition"
1123 (source-wrap e w s mod))))))
1124 (eval-local-transformer
1125 (lambda (expanded mod)
1126 (let ((p (local-eval-hook expanded mod)))
1129 (syntax-violation #f "nonprocedure transformer" p)))))
1130 (expand-void (lambda () (build-void #f)))
1133 (and (nonsymbol-id? x)
1134 (free-id=? x '#(syntax-object ... ((top)) (hygiene guile))))))
1138 ((req (lambda (args rreq)
1139 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1141 (apply (lambda () (check (reverse rreq) #f)) tmp-1)
1142 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1143 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1144 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1145 (let ((tmp-1 (list tmp)))
1146 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1147 (apply (lambda (r) (check (reverse rreq) r)) tmp-1)
1149 (syntax-violation 'lambda "invalid argument list" orig-args args))))))))))
1150 (check (lambda (req rest)
1151 (if (distinct-bound-ids? (if rest (cons rest req) req))
1152 (values req #f rest #f)
1155 "duplicate identifier in argument list"
1157 (req orig-args '()))))
1158 (expand-simple-lambda
1159 (lambda (e r w s mod req rest meta body)
1160 (let* ((ids (if rest (append req (list rest)) req))
1161 (vars (map gen-var ids))
1162 (labels (gen-labels ids)))
1163 (build-simple-lambda
1165 (map syntax->datum req)
1166 (and rest (syntax->datum rest))
1171 (source-wrap e w s mod)
1172 (extend-var-env labels vars r)
1173 (make-binding-wrap ids labels w)
1178 ((req (lambda (args rreq)
1179 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1181 (apply (lambda () (check (reverse rreq) '() #f '())) tmp-1)
1182 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1183 (if (and tmp-1 (apply (lambda (a b) (id? a)) tmp-1))
1184 (apply (lambda (a b) (req b (cons a rreq))) tmp-1)
1185 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1187 (apply (lambda (a b) (eq? (syntax->datum a) #:optional)) tmp-1))
1188 (apply (lambda (a b) (opt b (reverse rreq) '())) tmp-1)
1189 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1191 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1192 (apply (lambda (a b) (key b (reverse rreq) '() '())) tmp-1)
1193 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1195 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1196 (apply (lambda (a b) (rest b (reverse rreq) '() '())) tmp-1)
1197 (let ((tmp-1 (list tmp)))
1198 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1199 (apply (lambda (r) (rest r (reverse rreq) '() '())) tmp-1)
1203 "invalid argument list"
1205 args))))))))))))))))
1206 (opt (lambda (args req ropt)
1207 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1209 (apply (lambda () (check req (reverse ropt) #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) (opt b req (cons (cons a '(#f)) ropt))) tmp-1)
1213 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1214 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1215 (apply (lambda (a init b) (opt b req (cons (list a init) ropt)))
1217 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1219 (apply (lambda (a b) (eq? (syntax->datum a) #:key)) tmp-1))
1220 (apply (lambda (a b) (key b req (reverse ropt) '())) tmp-1)
1221 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1223 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1224 (apply (lambda (a b) (rest b req (reverse ropt) '())) 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 req (reverse ropt) '())) tmp-1)
1231 "invalid optional argument list"
1233 args))))))))))))))))
1234 (key (lambda (args req opt rkey)
1235 (let* ((tmp args) (tmp-1 ($sc-dispatch tmp '())))
1237 (apply (lambda () (check req opt #f (cons #f (reverse rkey)))) 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)
1241 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1242 (key b req opt (cons (cons k (cons a '(#f))) rkey))))
1244 (let ((tmp-1 ($sc-dispatch tmp '((any any) . any))))
1245 (if (and tmp-1 (apply (lambda (a init b) (id? a)) tmp-1))
1246 (apply (lambda (a init b)
1247 (let* ((tmp (symbol->keyword (syntax->datum a))) (k tmp))
1248 (key b req opt (cons (list k a init) rkey))))
1250 (let ((tmp-1 ($sc-dispatch tmp '((any any any) . any))))
1252 (apply (lambda (a init k b) (and (id? a) (keyword? (syntax->datum k))))
1254 (apply (lambda (a init k b) (key b req opt (cons (list k a init) rkey)))
1256 (let ((tmp-1 ($sc-dispatch tmp '(any))))
1258 (apply (lambda (aok) (eq? (syntax->datum aok) #:allow-other-keys))
1260 (apply (lambda (aok) (check req opt #f (cons #t (reverse rkey))))
1262 (let ((tmp-1 ($sc-dispatch tmp '(any any any))))
1264 (apply (lambda (aok a b)
1265 (and (eq? (syntax->datum aok) #:allow-other-keys)
1266 (eq? (syntax->datum a) #:rest)))
1268 (apply (lambda (aok a b) (rest b req opt (cons #t (reverse rkey))))
1270 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1272 (apply (lambda (aok r)
1273 (and (eq? (syntax->datum aok) #:allow-other-keys) (id? r)))
1275 (apply (lambda (aok r) (rest r req opt (cons #t (reverse rkey))))
1277 (let ((tmp-1 ($sc-dispatch tmp '(any any))))
1279 (apply (lambda (a b) (eq? (syntax->datum a) #:rest)) tmp-1))
1280 (apply (lambda (a b) (rest b req opt (cons #f (reverse rkey))))
1282 (let ((tmp-1 (list tmp)))
1283 (if (and tmp-1 (apply (lambda (r) (id? r)) tmp-1))
1284 (apply (lambda (r) (rest r req opt (cons #f (reverse rkey))))
1289 "invalid keyword argument list"
1291 args))))))))))))))))))))))
1292 (rest (lambda (args req opt kw)
1293 (let* ((tmp-1 args) (tmp (list tmp-1)))
1294 (if (and tmp (apply (lambda (r) (id? r)) tmp))
1295 (apply (lambda (r) (check req opt r kw)) tmp)
1297 (syntax-violation 'lambda* "invalid rest argument" orig-args args))))))
1298 (check (lambda (req opt rest kw)
1299 (if (distinct-bound-ids?
1303 (if rest (list rest) '())
1304 (if (pair? kw) (map cadr (cdr kw)) '())))
1305 (values req opt rest kw)
1308 "duplicate identifier in argument list"
1310 (req orig-args '()))))
1312 (lambda (e r w s mod get-formals clauses)
1315 (lambda (req opt rest kw body)
1316 (let ((vars (map gen-var req)) (labels (gen-labels req)))
1317 (let ((r* (extend-var-env labels vars r))
1318 (w* (make-binding-wrap req labels w)))
1320 (map syntax->datum req)
1331 (lambda (req opt rest kw body vars r* w* out inits)
1333 (let* ((tmp-1 (car opt)) (tmp ($sc-dispatch tmp-1 '(any any))))
1335 (apply (lambda (id i)
1336 (let* ((v (gen-var id))
1337 (l (gen-labels (list v)))
1338 (r** (extend-var-env l (list v) r*))
1339 (w** (make-binding-wrap (list id) l w*)))
1349 (cons (syntax->datum id) out)
1350 (cons (expand i r* w* mod) inits))))
1354 "source expression failed to match any pattern"
1357 (let* ((v (gen-var rest))
1358 (l (gen-labels (list v)))
1359 (r* (extend-var-env l (list v) r*))
1360 (w* (make-binding-wrap (list rest) l w*)))
1363 (and (pair? out) (reverse out))
1364 (syntax->datum rest)
1365 (if (pair? kw) (cdr kw) kw)
1370 (and (pair? kw) (car kw))
1376 (and (pair? out) (reverse out))
1378 (if (pair? kw) (cdr kw) kw)
1383 (and (pair? kw) (car kw))
1387 (lambda (req opt rest kw body vars r* w* aok out inits)
1389 (let* ((tmp-1 (car kw)) (tmp ($sc-dispatch tmp-1 '(any any any))))
1391 (apply (lambda (k id i)
1392 (let* ((v (gen-var id))
1393 (l (gen-labels (list v)))
1394 (r** (extend-var-env l (list v) r*))
1395 (w** (make-binding-wrap (list id) l w*)))
1406 (cons (list (syntax->datum k) (syntax->datum id) v) out)
1407 (cons (expand i r* w* mod) inits))))
1411 "source expression failed to match any pattern"
1417 (and (or aok (pair? out)) (cons aok (reverse out)))
1425 (lambda (req opt rest kw body vars r* w* inits meta)
1426 (let* ((tmp body) (tmp-1 ($sc-dispatch tmp '(any any . each-any))))
1428 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1430 (apply (lambda (docstring e1 e2)
1441 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1443 (let ((tmp-1 ($sc-dispatch tmp '(#(vector #(each (any . any))) any . each-any))))
1445 (apply (lambda (k v e1 e2)
1456 (append meta (syntax->datum (map cons k v)))))
1458 (let ((tmp-1 ($sc-dispatch tmp '(any . each-any))))
1460 (apply (lambda (e1 e2)
1469 (expand-body (cons e1 e2) (source-wrap e w s mod) r* w* mod)))
1473 "source expression failed to match any pattern"
1475 (let* ((tmp clauses) (tmp-1 ($sc-dispatch tmp '())))
1477 (apply (lambda () (values '() #f)) tmp-1)
1478 (let ((tmp-1 ($sc-dispatch
1480 '((any any . each-any) . #(each (any any . each-any))))))
1482 (apply (lambda (args e1 e2 args* e1* e2*)
1484 (lambda () (get-formals args))
1485 (lambda (req opt rest kw)
1487 (lambda () (parse-req req opt rest kw (cons e1 e2)))
1488 (lambda (meta req opt rest kw inits vars body)
1498 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1502 (lambda (meta* else*)
1505 (build-lambda-case s req opt rest kw inits vars body else*)))))))))
1509 "source expression failed to match any pattern"
1511 (strip (lambda (x w)
1512 (if (memq 'top (car w))
1515 (cond ((syntax-object? x)
1516 (strip (syntax-object-expression x) (syntax-object-wrap x)))
1518 (let ((a (f (car x))) (d (f (cdr x))))
1519 (if (and (eq? a (car x)) (eq? d (cdr x))) x (cons a d))))
1521 (let* ((old (vector->list x)) (new (map f old)))
1522 (let lp ((l1 old) (l2 new))
1523 (cond ((null? l1) x)
1524 ((eq? (car l1) (car l2)) (lp (cdr l1) (cdr l2)))
1525 (else (list->vector new))))))
1529 (let ((id (if (syntax-object? id) (syntax-object-expression id) id)))
1530 (gensym (string-append (symbol->string id) "-")))))
1533 (let lvl ((vars vars) (ls '()) (w '(())))
1534 (cond ((pair? vars) (lvl (cdr vars) (cons (wrap (car vars) w #f) ls) w))
1535 ((id? vars) (cons (wrap vars w #f) ls))
1537 ((syntax-object? vars)
1538 (lvl (syntax-object-expression vars)
1540 (join-wraps w (syntax-object-wrap vars))))
1541 (else (cons vars ls)))))))
1542 (global-extend 'local-syntax 'letrec-syntax #t)
1543 (global-extend 'local-syntax 'let-syntax #f)
1546 'syntax-parameterize
1547 (lambda (e r w s mod)
1549 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1550 (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp))
1551 (apply (lambda (var val e1 e2)
1552 (let ((names (map (lambda (x)
1554 (lambda () (resolve-identifier x w r mod #f))
1555 (lambda (type value mod)
1557 (cond ((memv key '(displaced-lexical))
1559 'syntax-parameterize
1560 "identifier out of context"
1562 (source-wrap x w s mod)))
1563 ((memv key '(syntax-parameter)) value)
1566 'syntax-parameterize
1567 "invalid syntax parameter"
1569 (source-wrap x w s mod))))))))
1572 (let ((trans-r (macros-only-env r)))
1574 (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod)))
1578 (source-wrap e w s mod)
1579 (extend-env names bindings r)
1584 'syntax-parameterize
1586 (source-wrap e w s mod))))))
1590 (lambda (e r w s mod)
1591 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any))))
1593 (apply (lambda (e) (build-data s (strip e w))) tmp)
1594 (syntax-violation 'quote "bad syntax" (source-wrap e w s mod))))))
1600 (lambda (src e r maps ellipsis? mod)
1603 (lambda () (resolve-identifier e '(()) r mod #f))
1604 (lambda (type value mod)
1606 (cond ((memv key '(syntax))
1608 (lambda () (gen-ref src (car value) (cdr value) maps))
1609 (lambda (var maps) (values (list 'ref var) maps))))
1610 ((ellipsis? e) (syntax-violation 'syntax "misplaced ellipsis" src))
1611 (else (values (list 'quote e) maps))))))
1612 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any))))
1613 (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots)) tmp-1))
1614 (apply (lambda (dots e) (gen-syntax src e r maps (lambda (x) #f) mod))
1616 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
1617 (if (and tmp-1 (apply (lambda (x dots y) (ellipsis? dots)) tmp-1))
1618 (apply (lambda (x dots y)
1622 (lambda () (gen-syntax src x r (cons '() maps) ellipsis? mod))
1624 (if (null? (car maps))
1625 (syntax-violation 'syntax "extra ellipsis" src)
1626 (values (gen-map x (car maps)) (cdr maps))))))))
1627 (let* ((tmp y) (tmp ($sc-dispatch tmp '(any . any))))
1628 (if (and tmp (apply (lambda (dots y) (ellipsis? dots)) tmp))
1629 (apply (lambda (dots y)
1633 (lambda () (k (cons '() maps)))
1635 (if (null? (car maps))
1636 (syntax-violation 'syntax "extra ellipsis" src)
1637 (values (gen-mappend x (car maps)) (cdr maps))))))))
1640 (lambda () (gen-syntax src y r maps ellipsis? mod))
1643 (lambda () (k maps))
1644 (lambda (x maps) (values (gen-append x y) maps)))))))))
1646 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
1648 (apply (lambda (x y)
1650 (lambda () (gen-syntax src x r maps ellipsis? mod))
1653 (lambda () (gen-syntax src y r maps ellipsis? mod))
1654 (lambda (y maps) (values (gen-cons x y) maps))))))
1656 (let ((tmp ($sc-dispatch tmp '#(vector (any . each-any)))))
1658 (apply (lambda (e1 e2)
1660 (lambda () (gen-syntax src (cons e1 e2) r maps ellipsis? mod))
1661 (lambda (e maps) (values (gen-vector e) maps))))
1663 (values (list 'quote e) maps))))))))))))
1665 (lambda (src var level maps)
1666 (cond ((= level 0) (values var maps))
1667 ((null? maps) (syntax-violation 'syntax "missing ellipsis" src))
1670 (lambda () (gen-ref src var (- level 1) (cdr maps)))
1671 (lambda (outer-var outer-maps)
1672 (let ((b (assq outer-var (car maps))))
1674 (values (cdr b) maps)
1675 (let ((inner-var (gen-var 'tmp)))
1678 (cons (cons (cons outer-var inner-var) (car maps)) outer-maps)))))))))))
1681 (list 'apply '(primitive append) (gen-map e map-env))))
1684 (let ((formals (map cdr map-env))
1685 (actuals (map (lambda (x) (list 'ref (car x))) map-env)))
1686 (cond ((eq? (car e) 'ref) (car actuals))
1688 (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
1691 (cons (list 'primitive (car e))
1692 (map (let ((r (map cons formals actuals)))
1693 (lambda (x) (cdr (assq (cadr x) r))))
1695 (else (cons 'map (cons (list 'lambda formals e) actuals)))))))
1698 (let ((key (car y)))
1699 (cond ((memv key '(quote))
1700 (cond ((eq? (car x) 'quote) (list 'quote (cons (cadr x) (cadr y))))
1701 ((eq? (cadr y) '()) (list 'list x))
1702 (else (list 'cons x y))))
1703 ((memv key '(list)) (cons 'list (cons x (cdr y))))
1704 (else (list 'cons x y))))))
1705 (gen-append (lambda (x y) (if (equal? y ''()) x (list 'append x y))))
1708 (cond ((eq? (car x) 'list) (cons 'vector (cdr x)))
1709 ((eq? (car x) 'quote) (list 'quote (list->vector (cadr x))))
1710 (else (list 'list->vector x)))))
1712 (let ((key (car x)))
1713 (cond ((memv key '(ref))
1714 (build-lexical-reference 'value #f (cadr x) (cadr x)))
1715 ((memv key '(primitive)) (build-primref #f (cadr x)))
1716 ((memv key '(quote)) (build-data #f (cadr x)))
1717 ((memv key '(lambda))
1718 (if (list? (cadr x))
1719 (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x)))
1720 (error "how did we get here" x)))
1721 (else (build-primcall #f (car x) (map regen (cdr x)))))))))
1722 (lambda (e r w s mod)
1723 (let* ((e (source-wrap e w s mod))
1725 (tmp ($sc-dispatch tmp '(_ any))))
1729 (lambda () (gen-syntax e x r '() ellipsis? mod))
1730 (lambda (e maps) (regen e))))
1732 (syntax-violation 'syntax "bad `syntax' form" e))))))
1736 (lambda (e r w s mod)
1737 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1739 (apply (lambda (args e1 e2)
1741 (lambda () (lambda-formals args))
1742 (lambda (req opt rest kw)
1743 (let lp ((body (cons e1 e2)) (meta '()))
1744 (let* ((tmp-1 body) (tmp ($sc-dispatch tmp-1 '(any any . each-any))))
1746 (apply (lambda (docstring e1 e2) (string? (syntax->datum docstring)))
1748 (apply (lambda (docstring e1 e2)
1750 (append meta (list (cons 'documentation (syntax->datum docstring))))))
1752 (let ((tmp ($sc-dispatch tmp-1 '(#(vector #(each (any . any))) any . each-any))))
1754 (apply (lambda (k v e1 e2)
1755 (lp (cons e1 e2) (append meta (syntax->datum (map cons k v)))))
1757 (expand-simple-lambda e r w s mod req rest meta body)))))))))
1759 (syntax-violation 'lambda "bad lambda" e)))))
1763 (lambda (e r w s mod)
1764 (let* ((tmp e) (tmp ($sc-dispatch tmp '(_ any any . each-any))))
1766 (apply (lambda (args e1 e2)
1776 (list (cons args (cons e1 e2)))))
1777 (lambda (meta lcase) (build-case-lambda s meta lcase))))
1779 (syntax-violation 'lambda "bad lambda*" e)))))
1783 (lambda (e r w s mod)
1786 (lambda (meta clauses)
1788 (lambda () (expand-lambda-case e r w s mod lambda-formals clauses))
1789 (lambda (meta* lcase)
1790 (build-case-lambda s (append meta meta*) lcase))))))
1792 (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
1794 (apply (lambda (args e1 e2)
1797 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1802 (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
1804 (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
1806 (apply (lambda (docstring args e1 e2)
1808 (list (cons 'documentation (syntax->datum docstring)))
1809 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1814 (syntax-violation 'case-lambda "bad case-lambda" e))))))))
1818 (lambda (e r w s mod)
1821 (lambda (meta clauses)
1823 (lambda () (expand-lambda-case e r w s mod lambda*-formals clauses))
1824 (lambda (meta* lcase)
1825 (build-case-lambda s (append meta meta*) lcase))))))
1827 (tmp ($sc-dispatch tmp-1 '(_ . #(each (any any . each-any))))))
1829 (apply (lambda (args e1 e2)
1832 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1837 (let ((tmp ($sc-dispatch tmp-1 '(_ any . #(each (any any . each-any))))))
1839 (apply (lambda (docstring args e1 e2) (string? (syntax->datum docstring)))
1841 (apply (lambda (docstring args e1 e2)
1843 (list (cons 'documentation (syntax->datum docstring)))
1844 (map (lambda (tmp-2 tmp-1 tmp) (cons tmp (cons tmp-1 tmp-2)))
1849 (syntax-violation 'case-lambda "bad case-lambda*" e))))))))
1855 (lambda (e r w s mod constructor ids vals exps)
1856 (if (not (valid-bound-ids? ids))
1857 (syntax-violation 'let "duplicate bound variable" e)
1858 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1859 (let ((nw (make-binding-wrap ids labels w))
1860 (nr (extend-var-env labels new-vars r)))
1863 (map syntax->datum ids)
1865 (map (lambda (x) (expand x r w mod)) vals)
1866 (expand-body exps (source-wrap e nw s mod) nr nw mod))))))))
1867 (lambda (e r w s mod)
1869 (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any))))
1870 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1871 (apply (lambda (id val e1 e2)
1872 (expand-let e r w s mod build-let id val (cons e1 e2)))
1874 (let ((tmp ($sc-dispatch tmp-1 '(_ any #(each (any any)) any . each-any))))
1876 (apply (lambda (f id val e1 e2) (and (id? f) (and-map id? id))) tmp))
1877 (apply (lambda (f id val e1 e2)
1878 (expand-let e r w s mod build-named-let (cons f id) val (cons e1 e2)))
1880 (syntax-violation 'let "bad let" (source-wrap e w s mod)))))))))
1884 (lambda (e r w s mod)
1886 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1887 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1888 (apply (lambda (id val e1 e2)
1890 (if (not (valid-bound-ids? ids))
1891 (syntax-violation 'letrec "duplicate bound variable" e)
1892 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1893 (let ((w (make-binding-wrap ids labels w))
1894 (r (extend-var-env labels new-vars r)))
1898 (map syntax->datum ids)
1900 (map (lambda (x) (expand x r w mod)) val)
1901 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1903 (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
1907 (lambda (e r w s mod)
1909 (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
1910 (if (and tmp (apply (lambda (id val e1 e2) (and-map id? id)) tmp))
1911 (apply (lambda (id val e1 e2)
1913 (if (not (valid-bound-ids? ids))
1914 (syntax-violation 'letrec* "duplicate bound variable" e)
1915 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
1916 (let ((w (make-binding-wrap ids labels w))
1917 (r (extend-var-env labels new-vars r)))
1921 (map syntax->datum ids)
1923 (map (lambda (x) (expand x r w mod)) val)
1924 (expand-body (cons e1 e2) (source-wrap e w s mod) r w mod)))))))
1926 (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
1930 (lambda (e r w s mod)
1931 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any))))
1932 (if (and tmp (apply (lambda (id val) (id? id)) tmp))
1933 (apply (lambda (id val)
1935 (lambda () (resolve-identifier id w r mod #t))
1936 (lambda (type value id-mod)
1938 (cond ((memv key '(lexical))
1939 (build-lexical-assignment
1943 (expand val r w mod)))
1944 ((memv key '(global))
1945 (build-global-assignment s value (expand val r w mod) id-mod))
1946 ((memv key '(macro))
1947 (if (procedure-property value 'variable-transformer)
1948 (expand (expand-macro value e r w s #f mod) r '(()) mod)
1951 "not a variable transformer"
1953 (wrap id w id-mod))))
1954 ((memv key '(displaced-lexical))
1955 (syntax-violation 'set! "identifier out of context" (wrap id w mod)))
1956 (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1958 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any))))
1960 (apply (lambda (head tail val)
1962 (lambda () (syntax-type head r '(()) #f #f mod #t))
1963 (lambda (type value ee* ee ww ss modmod)
1965 (if (memv key '(module-ref))
1966 (let ((val (expand val r w mod)))
1968 (lambda () (value (cons head tail) r w mod))
1969 (lambda (e r w s* mod)
1970 (let* ((tmp-1 e) (tmp (list tmp-1)))
1971 (if (and tmp (apply (lambda (e) (id? e)) tmp))
1972 (apply (lambda (e) (build-global-assignment s (syntax->datum e) val mod))
1976 "source expression failed to match any pattern"
1981 (list '#(syntax-object setter ((top)) (hygiene guile)) head)
1985 (map (lambda (e) (expand e r w mod)) (append tail (list val)))))))))
1987 (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))))
1992 (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
1994 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
1995 (apply (lambda (mod id)
2002 (cons '#(syntax-object public ((top)) (hygiene guile)) mod))))
2006 "source expression failed to match any pattern"
2015 (cond ((pair? x) (cons (remodulate (car x) mod) (remodulate (cdr x) mod)))
2018 (remodulate (syntax-object-expression x) mod)
2019 (syntax-object-wrap x)
2022 (let* ((n (vector-length x)) (v (make-vector n)))
2025 (begin (if #f #f) v)
2027 (vector-set! v i (remodulate (vector-ref x i) mod))
2031 (tmp-1 ($sc-dispatch
2033 '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
2038 (cdr (if (syntax-object? id) (syntax-object-module id) mod))
2041 (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
2043 (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
2045 (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
2046 (apply (lambda (mod id)
2053 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2055 (let ((tmp-1 ($sc-dispatch
2057 '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile)))
2060 (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1))
2061 (apply (lambda (mod exp)
2062 (let ((mod (syntax->datum
2063 (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
2064 (values (remodulate exp mod) r w (source-annotation exp) mod)))
2068 "source expression failed to match any pattern"
2073 (lambda (e r w s mod)
2074 (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any any))))
2076 (apply (lambda (test then)
2079 (expand test r w mod)
2080 (expand then r w mod)
2083 (let ((tmp-1 ($sc-dispatch tmp '(_ any any any))))
2085 (apply (lambda (test then else)
2088 (expand test r w mod)
2089 (expand then r w mod)
2090 (expand else r w mod)))
2094 "source expression failed to match any pattern"
2096 (global-extend 'begin 'begin '())
2097 (global-extend 'define 'define '())
2098 (global-extend 'define-syntax 'define-syntax '())
2099 (global-extend 'define-syntax-parameter 'define-syntax-parameter '())
2100 (global-extend 'eval-when 'eval-when '())
2106 (lambda (pattern keys)
2108 ((cvt* (lambda (p* n ids)
2109 (if (not (pair? p*))
2112 (lambda () (cvt* (cdr p*) n ids))
2115 (lambda () (cvt (car p*) n ids))
2116 (lambda (x ids) (values (cons x y) ids))))))))
2119 (let loop ((r '()) (x x))
2120 (if (not (pair? x)) (values r x) (loop (cons (car x) r) (cdr x))))))
2121 (cvt (lambda (p n ids)
2123 (cond ((bound-id-member? p keys) (values (vector 'free-id p) ids))
2124 ((free-id=? p '#(syntax-object _ ((top)) (hygiene guile)))
2126 (else (values 'any (cons (cons p n) ids))))
2127 (let* ((tmp p) (tmp-1 ($sc-dispatch tmp '(any any))))
2128 (if (and tmp-1 (apply (lambda (x dots) (ellipsis? dots)) tmp-1))
2129 (apply (lambda (x dots)
2131 (lambda () (cvt x (+ n 1) ids))
2133 (values (if (eq? p 'any) 'each-any (vector 'each p)) ids))))
2135 (let ((tmp-1 ($sc-dispatch tmp '(any any . any))))
2136 (if (and tmp-1 (apply (lambda (x dots ys) (ellipsis? dots)) tmp-1))
2137 (apply (lambda (x dots ys)
2139 (lambda () (cvt* ys n ids))
2142 (lambda () (cvt x (+ n 1) ids))
2145 (lambda () (v-reverse ys))
2146 (lambda (ys e) (values (vector 'each+ x ys e) ids))))))))
2148 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2150 (apply (lambda (x y)
2152 (lambda () (cvt y n ids))
2155 (lambda () (cvt x n ids))
2156 (lambda (x ids) (values (cons x y) ids))))))
2158 (let ((tmp-1 ($sc-dispatch tmp '())))
2160 (apply (lambda () (values '() ids)) tmp-1)
2161 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2165 (lambda () (cvt x n ids))
2166 (lambda (p ids) (values (vector 'vector p) ids))))
2168 (let ((x tmp)) (values (vector 'atom (strip p '(()))) ids))))))))))))))))
2169 (cvt pattern 0 '()))))
2170 (build-dispatch-call
2171 (lambda (pvars exp y r mod)
2172 (let ((ids (map car pvars)) (levels (map cdr pvars)))
2173 (let ((labels (gen-labels ids)) (new-vars (map gen-var ids)))
2177 (list (build-simple-lambda
2179 (map syntax->datum ids)
2187 (map (lambda (var level) (cons 'syntax (cons var level)))
2191 (make-binding-wrap ids labels '(()))
2195 (lambda (x keys clauses r pat fender exp mod)
2197 (lambda () (convert-pattern pat keys))
2199 (cond ((not (distinct-bound-ids? (map car pvars)))
2200 (syntax-violation 'syntax-case "duplicate pattern variable" pat))
2201 ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
2202 (syntax-violation 'syntax-case "misplaced ellipsis" pat))
2204 (let ((y (gen-var 'tmp)))
2207 (build-simple-lambda
2213 (let ((y (build-lexical-reference 'value #f 'tmp y)))
2216 (let* ((tmp fender) (tmp ($sc-dispatch tmp '#(atom #t))))
2218 (apply (lambda () y) tmp)
2222 (build-dispatch-call pvars fender y r mod)
2223 (build-data #f #f))))
2224 (build-dispatch-call pvars exp y r mod)
2225 (gen-syntax-case x keys clauses r mod))))
2226 (list (if (eq? p 'any)
2227 (build-primcall #f 'list (list x))
2228 (build-primcall #f '$sc-dispatch (list x (build-data #f p)))))))))))))
2230 (lambda (x keys clauses r mod)
2235 (list (build-data #f #f)
2236 (build-data #f "source expression failed to match any pattern")
2238 (let* ((tmp-1 (car clauses)) (tmp ($sc-dispatch tmp-1 '(any any))))
2240 (apply (lambda (pat exp)
2243 (lambda (x) (not (free-id=? pat x)))
2244 (cons '#(syntax-object ... ((top)) (hygiene guile)) keys)))
2245 (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile)))
2246 (expand exp r '(()) mod)
2247 (let ((labels (list (gen-label))) (var (gen-var pat)))
2250 (build-simple-lambda
2252 (list (syntax->datum pat))
2258 (extend-env labels (list (cons 'syntax (cons var 0))) r)
2259 (make-binding-wrap (list pat) labels '(()))
2262 (gen-clause x keys (cdr clauses) r pat #t exp mod)))
2264 (let ((tmp ($sc-dispatch tmp-1 '(any any any))))
2266 (apply (lambda (pat fender exp)
2267 (gen-clause x keys (cdr clauses) r pat fender exp mod))
2269 (syntax-violation 'syntax-case "invalid clause" (car clauses))))))))))
2270 (lambda (e r w s mod)
2271 (let* ((e (source-wrap e w s mod))
2273 (tmp ($sc-dispatch tmp-1 '(_ any each-any . each-any))))
2275 (apply (lambda (val key m)
2276 (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) key)
2277 (let ((x (gen-var 'tmp)))
2280 (build-simple-lambda
2287 (build-lexical-reference 'value #f 'tmp x)
2292 (list (expand val r '(()) mod))))
2293 (syntax-violation 'syntax-case "invalid literals list" e)))
2297 "source expression failed to match any pattern"
2300 (lambda* (x #:optional (m 'e) (esew '(eval)))
2301 (expand-top-sequence
2308 (cons 'hygiene (module-name (current-module))))))
2309 (set! identifier? (lambda (x) (nonsymbol-id? x)))
2314 (syntax-object-wrap id)
2315 (syntax-object-module id))))
2316 (set! syntax->datum (lambda (x) (strip x '(()))))
2317 (set! syntax-source (lambda (x) (source-annotation x)))
2318 (set! generate-temporaries
2322 (syntax-violation 'generate-temporaries "invalid argument" x)))
2323 (let ((mod (cons 'hygiene (module-name (current-module)))))
2324 (map (lambda (x) (wrap (gensym "t-") '((top)) mod)) ls))))
2325 (set! free-identifier=?
2328 (if (not (nonsymbol-id? x))
2329 (syntax-violation 'free-identifier=? "invalid argument" x)))
2331 (if (not (nonsymbol-id? x))
2332 (syntax-violation 'free-identifier=? "invalid argument" x)))
2334 (set! bound-identifier=?
2337 (if (not (nonsymbol-id? x))
2338 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2340 (if (not (nonsymbol-id? x))
2341 (syntax-violation 'bound-identifier=? "invalid argument" x)))
2343 (set! syntax-violation
2344 (lambda* (who message form #:optional (subform #f))
2346 (if (not (let ((x x)) (or (not x) (string? x) (symbol? x))))
2347 (syntax-violation 'syntax-violation "invalid argument" x)))
2349 (if (not (string? x))
2350 (syntax-violation 'syntax-violation "invalid argument" x)))
2351 (throw 'syntax-error
2354 (or (source-annotation subform) (source-annotation form))
2356 (and subform (strip subform '(()))))))
2361 (if (not (nonsymbol-id? x))
2362 (syntax-violation 'syntax-module "invalid argument" x)))
2363 (let ((mod (syntax-object-module id)))
2364 (and (not (equal? mod '(primitive))) (cdr mod)))))
2365 (syntax-local-binding
2368 (resolve-syntax-parameters? #t #:resolve-syntax-parameters?))
2370 (if (not (nonsymbol-id? x))
2371 (syntax-violation 'syntax-local-binding "invalid argument" x)))
2372 (with-transformer-environment
2373 (lambda (e r w s rib mod)
2377 (let ((ms (car w)) (s (cdr w)))
2378 (if (and (pair? ms) (eq? (car ms) #f))
2379 (cons (cdr ms) (if rib (cons rib (cdr s)) (cdr s)))
2380 (cons ms (if rib (cons rib s) s)))))))
2384 (syntax-object-expression id)
2385 (strip-anti-mark (syntax-object-wrap id))
2387 (syntax-object-module id)
2388 resolve-syntax-parameters?))
2389 (lambda (type value mod)
2391 (cond ((memv key '(lexical)) (values 'lexical value))
2392 ((memv key '(macro)) (values 'macro value))
2393 ((memv key '(syntax-parameter))
2394 (values 'syntax-parameter (car value)))
2395 ((memv key '(syntax)) (values 'pattern-variable value))
2396 ((memv key '(displaced-lexical)) (values 'displaced-lexical #f))
2397 ((memv key '(global))
2398 (if (equal? mod '(primitive))
2399 (values 'primitive value)
2400 (values 'global (cons value (cdr mod)))))
2401 (else (values 'other #f)))))))))))
2402 (syntax-locally-bound-identifiers
2405 (if (not (nonsymbol-id? x))
2407 'syntax-locally-bound-identifiers
2410 (locally-bound-identifiers
2411 (syntax-object-wrap id)
2412 (syntax-object-module id)))))
2413 (define! 'syntax-module syntax-module)
2414 (define! 'syntax-local-binding syntax-local-binding)
2416 'syntax-locally-bound-identifiers
2417 syntax-locally-bound-identifiers))
2422 (let ((first (match (car e) p w '() mod)))
2424 (let ((rest (match-each (cdr e) p w mod)))
2425 (and rest (cons first rest))))))
2429 (syntax-object-expression e)
2431 (join-wraps w (syntax-object-wrap e))
2432 (syntax-object-module e)))
2435 (lambda (e x-pat y-pat z-pat w r mod)
2436 (let f ((e e) (w w))
2439 (lambda () (f (cdr e) w))
2440 (lambda (xr* y-pat r)
2443 (let ((xr (match (car e) x-pat w '() mod)))
2444 (if xr (values (cons xr xr*) y-pat r) (values #f #f #f)))
2445 (values '() (cdr y-pat) (match (car e) (car y-pat) w r mod)))
2446 (values #f #f #f)))))
2448 (f (syntax-object-expression e) (join-wraps w e)))
2449 (else (values '() y-pat (match e z-pat w r mod)))))))
2453 (let ((l (match-each-any (cdr e) w mod)))
2454 (and l (cons (wrap (car e) w mod) l))))
2458 (syntax-object-expression e)
2459 (join-wraps w (syntax-object-wrap e))
2466 ((eq? p 'any) (cons '() r))
2467 ((pair? p) (match-empty (car p) (match-empty (cdr p) r)))
2468 ((eq? p 'each-any) (cons '() r))
2470 (let ((key (vector-ref p 0)))
2471 (cond ((memv key '(each)) (match-empty (vector-ref p 1) r))
2472 ((memv key '(each+))
2476 (reverse (vector-ref p 2))
2477 (match-empty (vector-ref p 3) r))))
2478 ((memv key '(free-id atom)) r)
2479 ((memv key '(vector)) (match-empty (vector-ref p 1) r))))))))
2482 (if (null? (car r*)) r (cons (map car r*) (combine (map cdr r*) r)))))
2484 (lambda (e p w r mod)
2485 (cond ((null? p) (and (null? e) r))
2488 (match (car e) (car p) w (match (cdr e) (cdr p) w r mod) mod)))
2490 (let ((l (match-each-any e w mod))) (and l (cons l r))))
2492 (let ((key (vector-ref p 0)))
2493 (cond ((memv key '(each))
2495 (match-empty (vector-ref p 1) r)
2496 (let ((l (match-each e (vector-ref p 1) w mod)))
2498 (let collect ((l l))
2499 (if (null? (car l)) r (cons (map car l) (collect (map cdr l)))))))))
2500 ((memv key '(each+))
2511 (lambda (xr* y-pat r)
2514 (if (null? xr*) (match-empty (vector-ref p 1) r) (combine xr* r))))))
2515 ((memv key '(free-id))
2516 (and (id? e) (free-id=? (wrap e w mod) (vector-ref p 1)) r))
2517 ((memv key '(atom)) (and (equal? (vector-ref p 1) (strip e w)) r))
2518 ((memv key '(vector))
2519 (and (vector? e) (match (vector->list e) (vector-ref p 1) w r mod)))))))))
2520 (match (lambda (e p w r mod)
2523 ((eq? p 'any) (cons (wrap e w mod) r))
2526 (syntax-object-expression e)
2528 (join-wraps w (syntax-object-wrap e))
2530 (syntax-object-module e)))
2531 (else (match* e p w r mod))))))
2534 (cond ((eq? p 'any) (list e))
2538 (syntax-object-expression e)
2540 (syntax-object-wrap e)
2542 (syntax-object-module e)))
2543 (else (match* e p '(()) '() #f)))))))
2546 (make-syntax-transformer
2551 (let ((tmp-1 ($sc-dispatch tmp '(_ () any . each-any))))
2553 (apply (lambda (e1 e2)
2554 (cons '#(syntax-object let ((top)) (hygiene guile))
2555 (cons '() (cons e1 e2))))
2557 (let ((tmp-1 ($sc-dispatch tmp '(_ ((any any)) any . each-any))))
2559 (apply (lambda (out in e1 e2)
2560 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2564 (cons '#(syntax-object let ((top)) (hygiene guile))
2565 (cons '() (cons e1 e2))))))
2567 (let ((tmp-1 ($sc-dispatch tmp '(_ #(each (any any)) any . each-any))))
2569 (apply (lambda (out in e1 e2)
2570 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
2571 (cons '#(syntax-object list ((top)) (hygiene guile)) in)
2574 (cons '#(syntax-object let ((top)) (hygiene guile))
2575 (cons '() (cons e1 e2))))))
2579 "source expression failed to match any pattern"
2582 (define syntax-rules
2583 (make-syntax-transformer
2588 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any . #(each ((any . any) any))))))
2590 (apply (lambda (k keyword pattern template)
2591 (list '#(syntax-object lambda ((top)) (hygiene guile))
2592 '(#(syntax-object x ((top)) (hygiene guile)))
2594 '(#(syntax-object macro-type ((top)) (hygiene guile))
2604 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2606 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2607 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2608 (cons '#(syntax-object x ((top)) (hygiene guile))
2610 (map (lambda (tmp-1 tmp)
2611 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2612 (list '#(syntax-object syntax ((top)) (hygiene guile))
2617 (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any))))))
2619 (apply (lambda (k docstring keyword pattern template)
2620 (string? (syntax->datum docstring)))
2623 (apply (lambda (k docstring keyword pattern template)
2624 (list '#(syntax-object lambda ((top)) (hygiene guile))
2625 '(#(syntax-object x ((top)) (hygiene guile)))
2628 '(#(syntax-object macro-type ((top)) (hygiene guile))
2638 #(syntax-object syntax-rules ((top)) (hygiene guile))))))
2640 (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern))
2641 (cons '#(syntax-object syntax-case ((top)) (hygiene guile))
2642 (cons '#(syntax-object x ((top)) (hygiene guile))
2644 (map (lambda (tmp-1 tmp)
2645 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) tmp)
2646 (list '#(syntax-object syntax ((top)) (hygiene guile))
2653 "source expression failed to match any pattern"
2656 (define define-syntax-rule
2657 (make-syntax-transformer
2662 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any))))
2664 (apply (lambda (name pattern template)
2665 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2667 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2669 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2672 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any))))
2674 (apply (lambda (name pattern docstring template)
2675 (string? (syntax->datum docstring)))
2678 (apply (lambda (name pattern docstring template)
2679 (list '#(syntax-object define-syntax ((top)) (hygiene guile))
2681 (list '#(syntax-object syntax-rules ((top)) (hygiene guile))
2684 (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern)
2689 "source expression failed to match any pattern"
2693 (make-syntax-transformer
2698 (let ((tmp ($sc-dispatch tmp-1 '(any #(each (any any)) any . each-any))))
2700 (apply (lambda (let* x v e1 e2) (and-map identifier? x)) tmp)
2702 (apply (lambda (let* x v e1 e2)
2703 (let f ((bindings (map list x v)))
2704 (if (null? bindings)
2705 (cons '#(syntax-object let ((top)) (hygiene guile))
2706 (cons '() (cons e1 e2)))
2707 (let ((tmp-1 (list (f (cdr bindings)) (car bindings))))
2708 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2710 (apply (lambda (body binding)
2711 (list '#(syntax-object let ((top)) (hygiene guile))
2717 "source expression failed to match any pattern"
2722 "source expression failed to match any pattern"
2726 (make-syntax-transformer
2730 ((quasi (lambda (p lev)
2732 (let ((tmp-1 ($sc-dispatch
2734 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile))) any))))
2740 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2741 (quasi (list p) (- lev 1)))))
2743 (let ((tmp-1 ($sc-dispatch
2754 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2769 #(syntax-object quasiquote ((top)) (hygiene guile))))))
2771 (quasi (list p) (+ lev 1))))
2773 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2775 (apply (lambda (p q)
2777 (let ((tmp ($sc-dispatch
2779 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2786 (map (lambda (tmp) (list "value" tmp)) p)
2790 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2791 (quasi p (- lev 1)))
2794 (let ((tmp ($sc-dispatch
2797 #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2804 (map (lambda (tmp) (list "value" tmp)) p)
2813 (quasi p (- lev 1)))
2816 (quasicons (quasi p lev) (quasi q lev))))))))
2818 (let ((tmp-1 ($sc-dispatch tmp '#(vector each-any))))
2820 (apply (lambda (x) (quasivector (vquasi x lev))) tmp-1)
2821 (let ((p tmp)) (list "quote" p)))))))))))))
2825 (let ((tmp-1 ($sc-dispatch tmp '(any . any))))
2827 (apply (lambda (p q)
2829 (let ((tmp ($sc-dispatch
2831 '(#(free-id #(syntax-object unquote ((top)) (hygiene guile)))
2837 (quasilist* (map (lambda (tmp) (list "value" tmp)) p) (vquasi q lev))
2840 '("quote" #(syntax-object unquote ((top)) (hygiene guile)))
2841 (quasi p (- lev 1)))
2844 (let ((tmp ($sc-dispatch
2846 '(#(free-id #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2853 (map (lambda (tmp) (list "value" tmp)) p)
2857 '("quote" #(syntax-object unquote-splicing ((top)) (hygiene guile)))
2858 (quasi p (- lev 1)))
2861 (quasicons (quasi p lev) (vquasi q lev))))))))
2863 (let ((tmp-1 ($sc-dispatch tmp '())))
2865 (apply (lambda () '("quote" ())) tmp-1)
2868 "source expression failed to match any pattern"
2872 (let ((tmp-1 (list x y)))
2873 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2875 (apply (lambda (x y)
2877 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2881 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") any))))
2883 (apply (lambda (dx) (list "quote" (cons dx dy))) tmp)
2884 (if (null? dy) (list "list" x) (list "list*" x y))))))
2886 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . any))))
2888 (apply (lambda (stuff) (cons "list" (cons x stuff))) tmp-1)
2889 (let ((tmp ($sc-dispatch tmp '(#(atom "list*") . any))))
2891 (apply (lambda (stuff) (cons "list*" (cons x stuff))) tmp)
2892 (list "list*" x y)))))))))
2896 "source expression failed to match any pattern"
2901 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") ()))))
2909 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2911 (apply (lambda (p) (cons "append" p)) tmp)
2914 "source expression failed to match any pattern"
2919 (let ((tmp-1 (list x y)))
2920 (let ((tmp ($sc-dispatch tmp-1 '(each-any any))))
2922 (apply (lambda (p y) (cons "append" (append p (list y)))) tmp)
2925 "source expression failed to match any pattern"
2929 (let f ((x x)) (if (null? x) y (quasicons (car x) (f (cdr x)))))))
2933 (let ((tmp ($sc-dispatch tmp '(#(atom "quote") each-any))))
2935 (apply (lambda (x) (list "quote" (list->vector x))) tmp)
2939 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2941 (apply (lambda (t) (cons "vector" t)) tmp)
2944 "source expression failed to match any pattern"
2947 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
2949 (apply (lambda (y) (k (map (lambda (tmp) (list "quote" tmp)) y)))
2951 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2953 (apply (lambda (y) (k y)) tmp-1)
2954 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2956 (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
2958 (let ((tmp x)) (let ((t tmp)) (list "list->vector" t)))))))))))))))))
2961 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
2963 (apply (lambda (x) (list '#(syntax-object quote ((top)) (hygiene guile)) x))
2965 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
2968 (let ((tmp-1 (map emit x)))
2969 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
2971 (apply (lambda (t) (cons '#(syntax-object list ((top)) (hygiene guile)) t))
2975 "source expression failed to match any pattern"
2978 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list*") . #(each+ any (any) ())))))
2980 (apply (lambda (x y)
2984 (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
2985 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
2987 (apply (lambda (t-1 t)
2988 (list '#(syntax-object cons ((top)) (hygiene guile)) t-1 t))
2992 "source expression failed to match any pattern"
2995 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "append") . each-any))))
2998 (let ((tmp-1 (map emit x)))
2999 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
3002 (cons '#(syntax-object append ((top)) (hygiene guile)) t))
3006 "source expression failed to match any pattern"
3009 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "vector") . each-any))))
3012 (let ((tmp-1 (map emit x)))
3013 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
3016 (cons '#(syntax-object vector ((top)) (hygiene guile)) t))
3020 "source expression failed to match any pattern"
3023 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list->vector") any))))
3026 (let ((tmp (emit x)))
3028 (list '#(syntax-object list->vector ((top)) (hygiene guile)) t))))
3030 (let ((tmp-1 ($sc-dispatch tmp '(#(atom "value") any))))
3032 (apply (lambda (x) x) tmp-1)
3035 "source expression failed to match any pattern"
3036 tmp)))))))))))))))))))
3039 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3041 (apply (lambda (e) (emit (quasi e 0))) tmp)
3044 "source expression failed to match any pattern"
3048 (make-syntax-transformer
3055 (let ((p (open-input-file
3056 (if (absolute-file-name? fn)
3059 (in-vicinity dir fn)
3062 "relative file name only allowed when the include form is in a file"
3064 (let ((enc (file-encoding p)))
3065 (set-port-encoding! p (let ((t enc)) (if t t "UTF-8")))
3066 (let f ((x (read p)) (result '()))
3068 (begin (close-input-port p) (reverse result))
3069 (f (read p) (cons (datum->syntax k x) result)))))))))
3070 (let ((src (syntax-source x)))
3071 (let ((file (if src (assq-ref src 'filename) #f)))
3072 (let ((dir (if (string? file) (dirname file) #f)))
3074 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3076 (apply (lambda (k filename)
3077 (let ((fn (syntax->datum filename)))
3078 (let ((tmp-1 (read-file fn dir filename)))
3079 (let ((tmp ($sc-dispatch tmp-1 'each-any)))
3081 (apply (lambda (exp)
3082 (cons '#(syntax-object begin ((top)) (hygiene guile)) exp))
3086 "source expression failed to match any pattern"
3091 "source expression failed to match any pattern"
3094 (define include-from-path
3095 (make-syntax-transformer
3100 (let ((tmp ($sc-dispatch tmp-1 '(any any))))
3102 (apply (lambda (k filename)
3103 (let ((fn (syntax->datum filename)))
3104 (let ((tmp (datum->syntax
3106 (let ((t (%search-load-path fn)))
3111 "file not found in path"
3115 (list '#(syntax-object include ((top)) (hygiene guile)) fn)))))
3119 "source expression failed to match any pattern"
3123 (make-syntax-transformer
3129 "expression not valid outside of quasiquote"
3132 (define unquote-splicing
3133 (make-syntax-transformer
3139 "expression not valid outside of quasiquote"
3142 (define make-variable-transformer
3144 (if (procedure? proc)
3145 (let ((trans (lambda (x) (proc x))))
3146 (set-procedure-property! trans 'variable-transformer #t)
3148 (error "variable transformer not a procedure" proc))))
3150 (define identifier-syntax
3151 (make-syntax-transformer
3156 (let ((tmp ($sc-dispatch tmp-1 '(_ any))))
3159 (list '#(syntax-object lambda ((top)) (hygiene guile))
3160 '(#(syntax-object x ((top)) (hygiene guile)))
3161 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3167 #(identifier-syntax)
3171 #(syntax-object identifier-syntax ((top)) (hygiene guile))))))
3173 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3174 '#(syntax-object x ((top)) (hygiene guile))
3176 (list '#(syntax-object id ((top)) (hygiene guile))
3177 '(#(syntax-object identifier? ((top)) (hygiene guile))
3178 (#(syntax-object syntax ((top)) (hygiene guile))
3179 #(syntax-object id ((top)) (hygiene guile))))
3180 (list '#(syntax-object syntax ((top)) (hygiene guile)) e))
3181 (list '(#(syntax-object _ ((top)) (hygiene guile))
3182 #(syntax-object x ((top)) (hygiene guile))
3183 #(syntax-object ... ((top)) (hygiene guile)))
3184 (list '#(syntax-object syntax ((top)) (hygiene guile))
3186 '(#(syntax-object x ((top)) (hygiene guile))
3187 #(syntax-object ... ((top)) (hygiene guile)))))))))
3189 (let ((tmp ($sc-dispatch
3192 ((#(free-id #(syntax-object set! ((top)) (hygiene guile))) any any)
3195 (apply (lambda (id exp1 var val exp2)
3196 (if (identifier? id) (identifier? var) #f))
3199 (apply (lambda (id exp1 var val exp2)
3200 (list '#(syntax-object make-variable-transformer ((top)) (hygiene guile))
3201 (list '#(syntax-object lambda ((top)) (hygiene guile))
3202 '(#(syntax-object x ((top)) (hygiene guile)))
3203 '#((#(syntax-object macro-type ((top)) (hygiene guile))
3205 #(syntax-object variable-transformer ((top)) (hygiene guile))))
3206 (list '#(syntax-object syntax-case ((top)) (hygiene guile))
3207 '#(syntax-object x ((top)) (hygiene guile))
3208 '(#(syntax-object set! ((top)) (hygiene guile)))
3209 (list (list '#(syntax-object set! ((top)) (hygiene guile)) var val)
3210 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp2))
3212 '(#(syntax-object x ((top)) (hygiene guile))
3213 #(syntax-object ... ((top)) (hygiene guile))))
3214 (list '#(syntax-object syntax ((top)) (hygiene guile))
3216 '(#(syntax-object x ((top)) (hygiene guile))
3217 #(syntax-object ... ((top)) (hygiene guile))))))
3219 (list '#(syntax-object identifier? ((top)) (hygiene guile))
3220 (list '#(syntax-object syntax ((top)) (hygiene guile)) id))
3221 (list '#(syntax-object syntax ((top)) (hygiene guile)) exp1))))))
3225 "source expression failed to match any pattern"
3229 (make-syntax-transformer
3234 (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any . each-any))))
3236 (apply (lambda (id args b0 b1)
3237 (list '#(syntax-object define ((top)) (hygiene guile))
3239 (cons '#(syntax-object lambda* ((top)) (hygiene guile))
3240 (cons args (cons b0 b1)))))
3242 (let ((tmp ($sc-dispatch tmp-1 '(_ any any))))
3243 (if (if tmp (apply (lambda (id val) (identifier? id)) tmp) #f)
3244 (apply (lambda (id val)
3245 (list '#(syntax-object define ((top)) (hygiene guile)) id val))
3249 "source expression failed to match any pattern"