diff options
Diffstat (limited to 'module/ice-9/psyntax-pp.scm')
-rw-r--r-- | module/ice-9/psyntax-pp.scm | 892 |
1 files changed, 497 insertions, 395 deletions
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index d6547aa09..7ad8a7018 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -47,19 +47,22 @@ test consequent alternate))) - (make-application + (make-call (lambda (src proc args) (make-struct (vector-ref %expanded-vtables 11) 0 src proc args))) - (make-sequence - (lambda (src exps) - (make-struct (vector-ref %expanded-vtables 12) 0 src exps))) + (make-primcall + (lambda (src name args) + (make-struct (vector-ref %expanded-vtables 12) 0 src name args))) + (make-seq + (lambda (src head tail) + (make-struct (vector-ref %expanded-vtables 13) 0 src head tail))) (make-lambda (lambda (src meta body) - (make-struct (vector-ref %expanded-vtables 13) 0 src meta body))) + (make-struct (vector-ref %expanded-vtables 14) 0 src meta body))) (make-lambda-case (lambda (src req opt rest kw inits gensyms body alternate) (make-struct - (vector-ref %expanded-vtables 14) + (vector-ref %expanded-vtables 15) 0 src req @@ -73,7 +76,7 @@ (make-let (lambda (src names gensyms vals body) (make-struct - (vector-ref %expanded-vtables 15) + (vector-ref %expanded-vtables 16) 0 src names @@ -83,7 +86,7 @@ (make-letrec (lambda (src in-order? names gensyms vals body) (make-struct - (vector-ref %expanded-vtables 16) + (vector-ref %expanded-vtables 17) 0 src in-order? @@ -91,19 +94,10 @@ gensyms vals body))) - (make-dynlet - (lambda (src fluids vals body) - (make-struct - (vector-ref %expanded-vtables 17) - 0 - src - fluids - vals - body))) (lambda? (lambda (x) (and (struct? x) - (eq? (struct-vtable x) (vector-ref %expanded-vtables 13))))) + (eq? (struct-vtable x) (vector-ref %expanded-vtables 14))))) (lambda-meta (lambda (x) (struct-ref x 1))) (set-lambda-meta! (lambda (x v) (struct-set! x 1 v))) (top-level-eval-hook (lambda (x mod) (primitive-eval x))) @@ -121,15 +115,16 @@ (lambda (symbol module) (if (and (not module) (current-module)) (warn "module system is booted, we should have a module" symbol)) - (let ((v (module-variable - (if module (resolve-module (cdr module)) (current-module)) - symbol))) - (and v - (variable-bound? v) - (let ((val (variable-ref v))) - (and (macro? val) - (macro-type val) - (cons (macro-type val) (macro-binding val)))))))) + (and (not (equal? module '(primitive))) + (let ((v (module-variable + (if module (resolve-module (cdr module)) (current-module)) + symbol))) + (and v + (variable-bound? v) + (let ((val (variable-ref v))) + (and (macro? val) + (macro-type val) + (cons (macro-type val) (macro-binding val))))))))) (decorate-source (lambda (e s) (if (and s (supports-source-properties? e)) @@ -142,15 +137,12 @@ (if (not (assq 'name meta)) (set-lambda-meta! val (acons 'name name meta))))))) (build-void (lambda (source) (make-void source))) - (build-application + (build-call (lambda (source fun-exp arg-exps) - (make-application source fun-exp arg-exps))) + (make-call source fun-exp arg-exps))) (build-conditional (lambda (source test-exp then-exp else-exp) (make-conditional source test-exp then-exp else-exp))) - (build-dynlet - (lambda (source fluids vals body) - (make-dynlet source fluids vals body))) (build-lexical-reference (lambda (type source name var) (make-lexical-ref source name var))) (build-lexical-assignment @@ -174,6 +166,8 @@ (module-variable (resolve-module mod) var)) (modref-cont mod var #f) (bare-cont var))) + ((memv key '(primitive)) + (syntax-violation #f "primitive not in operator position" var)) (else (syntax-violation #f "bad module kind" var mod)))))))) (build-global-reference (lambda (source var mod) @@ -206,15 +200,15 @@ (build-lambda-case (lambda (src req opt rest kw inits vars body else-case) (make-lambda-case src req opt rest kw inits vars body else-case))) - (build-primref - (lambda (src name) - (if (equal? (module-name (current-module)) '(guile)) - (make-toplevel-ref src name) - (make-module-ref src '(guile) name #f)))) + (build-primcall + (lambda (src name args) (make-primcall src name args))) + (build-primref (lambda (src name) (make-primitive-ref src name))) (build-data (lambda (src exp) (make-const src exp))) (build-sequence (lambda (src exps) - (if (null? (cdr exps)) (car exps) (make-sequence src exps)))) + (if (null? (cdr exps)) + (car exps) + (make-seq src (car exps) (build-sequence #f (cdr exps)))))) (build-let (lambda (src ids vars val-exps body-exp) (for-each maybe-name-value! ids val-exps) @@ -231,10 +225,7 @@ (list f-name) (list f) (list proc) - (build-application - src - (build-lexical-reference 'fun src f-name f) - val-exps)))))) + (build-call src (build-lexical-reference 'fun src f-name f) val-exps)))))) (build-letrec (lambda (src in-order? ids vars val-exps body-exp) (if (null? vars) @@ -285,15 +276,9 @@ (if (null? r) '() (let ((a (car r))) - (if (memq (cadr a) '(macro ellipsis)) + (if (memq (cadr a) '(macro syntax-parameter ellipsis)) (cons a (macros-only-env (cdr r))) (macros-only-env (cdr r))))))) - (lookup - (lambda (x r mod) - (let ((t (assq x r))) - (cond (t (cdr t)) - ((symbol? x) (or (get-global-definition-hook x mod) '(global))) - (else '(displaced-lexical)))))) (global-extend (lambda (type sym val) (put-global-definition-hook sym type val))) (nonsymbol-id? @@ -374,43 +359,53 @@ (eq? (car x) (car y)) (same-marks? (cdr x) (cdr y)))))) (id-var-name - (lambda (id w) + (lambda (id w mod) (letrec* ((search - (lambda (sym subst marks) + (lambda (sym subst marks mod) (if (null? subst) (values #f marks) (let ((fst (car subst))) (if (eq? fst 'shift) - (search sym (cdr subst) (cdr marks)) + (search sym (cdr subst) (cdr marks) mod) (let ((symnames (ribcage-symnames fst))) (if (vector? symnames) - (search-vector-rib sym subst marks symnames fst) - (search-list-rib sym subst marks symnames fst)))))))) + (search-vector-rib sym subst marks symnames fst mod) + (search-list-rib sym subst marks symnames fst mod)))))))) (search-list-rib - (lambda (sym subst marks symnames ribcage) + (lambda (sym subst marks symnames ribcage mod) (let f ((symnames symnames) (i 0)) - (cond ((null? symnames) (search sym (cdr subst) marks)) + (cond ((null? symnames) (search sym (cdr subst) marks mod)) ((and (eq? (car symnames) sym) (same-marks? marks (list-ref (ribcage-marks ribcage) i))) - (values (list-ref (ribcage-labels ribcage) i) marks)) + (let ((n (list-ref (ribcage-labels ribcage) i))) + (if (pair? n) + (if (equal? mod (car n)) + (values (cdr n) marks) + (f (cdr symnames) (+ i 1))) + (values n marks)))) (else (f (cdr symnames) (+ i 1))))))) (search-vector-rib - (lambda (sym subst marks symnames ribcage) + (lambda (sym subst marks symnames ribcage mod) (let ((n (vector-length symnames))) (let f ((i 0)) - (cond ((= i n) (search sym (cdr subst) marks)) + (cond ((= i n) (search sym (cdr subst) marks mod)) ((and (eq? (vector-ref symnames i) sym) (same-marks? marks (vector-ref (ribcage-marks ribcage) i))) - (values (vector-ref (ribcage-labels ribcage) i) marks)) + (let ((n (vector-ref (ribcage-labels ribcage) i))) + (if (pair? n) + (if (equal? mod (car n)) (values (cdr n) marks) (f (+ i 1))) + (values n marks)))) (else (f (+ i 1))))))))) - (cond ((symbol? id) (or (search id (cdr w) (car w)) id)) + (cond ((symbol? id) (or (search id (cdr w) (car w) mod) id)) ((syntax-object? id) - (let ((id (syntax-object-expression id)) (w1 (syntax-object-wrap id))) + (let ((id (syntax-object-expression id)) + (w1 (syntax-object-wrap id)) + (mod (syntax-object-module id))) (let ((marks (join-marks (car w) (car w1)))) (call-with-values - (lambda () (search id (cdr w) marks)) - (lambda (new-id marks) (or new-id (search id (cdr w1) marks) id)))))) + (lambda () (search id (cdr w) marks mod)) + (lambda (new-id marks) (or new-id (search id (cdr w1) marks mod) id)))))) (else (syntax-violation 'id-var-name "invalid id" id)))))) (locally-bound-identifiers (lambda (w mod) @@ -447,20 +442,29 @@ results)))))))) (scan (cdr w) '())))) (resolve-identifier - (lambda (id w r mod) + (lambda (id w r mod resolve-syntax-parameters?) (letrec* - ((resolve-global + ((resolve-syntax-parameters + (lambda (b) + (if (and resolve-syntax-parameters? (eq? (car b) 'syntax-parameter)) + (or (assq-ref r (cdr b)) (cons 'macro (car (cdr b)))) + b))) + (resolve-global (lambda (var mod) - (let ((b (or (get-global-definition-hook var mod) '(global)))) + (let ((b (resolve-syntax-parameters + (or (get-global-definition-hook var mod) '(global))))) (if (eq? (car b) 'global) (values 'global var mod) (values (car b) (cdr b) mod))))) (resolve-lexical (lambda (label mod) - (let ((b (or (assq-ref r label) '(displaced-lexical)))) + (let ((b (resolve-syntax-parameters + (or (assq-ref r label) '(displaced-lexical))))) (values (car b) (cdr b) mod))))) - (let ((n (id-var-name id w))) - (cond ((symbol? n) + (let ((n (id-var-name id w mod))) + (cond ((syntax-object? n) + (resolve-identifier n w r mod resolve-syntax-parameters?)) + ((symbol? n) (resolve-global n (if (syntax-object? id) (syntax-object-module id) mod))) @@ -477,9 +481,27 @@ (lambda (k) ((fluid-ref transformer-environment) k))) (free-id=? (lambda (i j) - (and (eq? (let ((x i)) (if (syntax-object? x) (syntax-object-expression x) x)) - (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) - (eq? (id-var-name i '(())) (id-var-name j '(())))))) + (let* ((mi (and (syntax-object? i) (syntax-object-module i))) + (mj (and (syntax-object? j) (syntax-object-module j))) + (ni (id-var-name i '(()) mi)) + (nj (id-var-name j '(()) mj))) + (letrec* + ((id-module-binding + (lambda (id mod) + (module-variable + (if mod (resolve-module (cdr mod)) (current-module)) + (let ((x id)) (if (syntax-object? x) (syntax-object-expression x) x)))))) + (cond ((syntax-object? ni) (free-id=? ni j)) + ((syntax-object? nj) (free-id=? i nj)) + ((symbol? ni) + (and (eq? nj + (let ((x j)) (if (syntax-object? x) (syntax-object-expression x) x))) + (let ((bi (id-module-binding i mi))) + (if bi + (eq? bi (id-module-binding j mj)) + (and (not (id-module-binding j mj)) (eq? ni nj)))) + (eq? (id-module-binding i mi) (id-module-binding j mj)))) + (else (equal? ni nj))))))) (bound-id=? (lambda (i j) (if (and (syntax-object? i) (syntax-object? j)) @@ -525,164 +547,158 @@ (cons first (dobody (cdr body) r w mod)))))))) (expand-top-sequence (lambda (body r w s m esew mod) - (letrec* - ((scan (lambda (body r w s m esew mod exps) - (if (null? body) - exps - (call-with-values - (lambda () - (call-with-values - (lambda () - (let ((e (car body))) - (syntax-type e r w (or (source-annotation e) s) #f mod #f))) - (lambda (type value form e w s mod) - (let ((key type)) - (cond ((memv key '(begin-form)) - (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_)))) - (if tmp-1 - (apply (lambda () exps) tmp-1) - (let ((tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) - (if tmp-1 - (apply (lambda (e1 e2) (scan (cons e1 e2) r w s m esew mod exps)) - tmp-1) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp)))))) - ((memv key '(local-syntax-form)) - (expand-local-syntax - value - e - r - w - s - mod - (lambda (body r w s mod) (scan body r w s m esew mod exps)))) - ((memv key '(eval-when-form)) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) - (if tmp - (apply (lambda (x e1 e2) - (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) - (cond ((eq? m 'e) - (if (memq 'eval when-list) - (scan body - r - w - s - (if (memq 'expand when-list) 'c&e 'e) - '(eval) - mod - exps) - (begin - (if (memq 'expand when-list) - (top-level-eval-hook - (expand-top-sequence body r w s 'e '(eval) mod) - mod)) - (values exps)))) - ((memq 'load when-list) - (cond ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) - (scan body r w s 'c&e '(compile load) mod exps)) - ((memq m '(c c&e)) - (scan body r w s 'c '(load) mod exps)) - (else (values exps)))) - ((or (memq 'compile when-list) - (memq 'expand when-list) - (and (eq? m 'c&e) (memq 'eval when-list))) + (let* ((r (cons '("placeholder" placeholder) r)) + (ribcage (make-ribcage '() '() '())) + (w (cons (car w) (cons ribcage (cdr w))))) + (letrec* + ((record-definition! + (lambda (id var) + (let ((mod (cons 'hygiene (module-name (current-module))))) + (extend-ribcage! + ribcage + id + (cons (syntax-object-module id) (wrap var '((top)) mod)))))) + (macro-introduced-identifier? + (lambda (id) (not (equal? (car (syntax-object-wrap id)) '(top))))) + (fresh-derived-name + (lambda (id orig-form) + (symbol-append + (syntax-object-expression id) + '- + (string->symbol + (number->string + (hash (syntax->datum orig-form) most-positive-fixnum) + 16))))) + (parse (lambda (body r w s m esew mod) + (let lp ((body body) (exps '())) + (if (null? body) + exps + (lp (cdr body) (append (parse1 (car body) r w s m esew mod) exps)))))) + (parse1 + (lambda (x r w s m esew mod) + (call-with-values + (lambda () (syntax-type x r w (source-annotation x) ribcage mod #f)) + (lambda (type value form e w s mod) + (let ((key type)) + (cond ((memv key '(define-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (list (if (eq? m 'c&e) + (let ((x (build-global-definition s var (expand e r w mod)))) + (top-level-eval-hook x mod) + (lambda () x)) + (call-with-values + (lambda () (resolve-identifier id '(()) r mod #t)) + (lambda (type* value* mod*) + (if (eq? type* 'macro) + (top-level-eval-hook + (build-global-definition s var (build-void s)) + mod)) + (lambda () (build-global-definition s var (expand e r w mod))))))))) + ((memv key '(define-syntax-form define-syntax-parameter-form)) + (let* ((id (wrap value w mod)) + (label (gen-label)) + (var (if (macro-introduced-identifier? id) + (fresh-derived-name id x) + (syntax-object-expression id)))) + (record-definition! id var) + (let ((key m)) + (cond ((memv key '(c)) + (cond ((memq 'compile esew) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (if (memq 'load esew) (list (lambda () e)) '()))) + ((memq 'load esew) + (list (lambda () (expand-install-global var type (expand e r w mod))))) + (else '()))) + ((memv key '(c&e)) + (let ((e (expand-install-global var type (expand e r w mod)))) + (top-level-eval-hook e mod) + (list (lambda () e)))) + (else + (if (memq 'eval esew) + (top-level-eval-hook + (expand-install-global var type (expand e r w mod)) + mod)) + '()))))) + ((memv key '(begin-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e1) (parse e1 r w s m esew mod)) tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + ((memv key '(local-syntax-form)) + (expand-local-syntax + value + e + r + w + s + mod + (lambda (forms r w s mod) (parse forms r w s m esew mod)))) + ((memv key '(eval-when-form)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any . each-any)))) + (if tmp + (apply (lambda (x e1 e2) + (let ((when-list (parse-when-list e x)) (body (cons e1 e2))) + (letrec* + ((recurse (lambda (m esew) (parse body r w s m esew mod)))) + (cond ((eq? m 'e) + (if (memq 'eval when-list) + (recurse (if (memq 'expand when-list) 'c&e 'e) '(eval)) + (begin + (if (memq 'expand when-list) (top-level-eval-hook (expand-top-sequence body r w s 'e '(eval) mod) - mod) - (values exps)) - (else (values exps))))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))) - ((memv key '(define-syntax-form define-syntax-parameter-form)) - (let ((n (id-var-name value w)) (r (macros-only-env r))) - (let ((key m)) - (cond ((memv key '(c)) - (cond ((memq 'compile esew) - (let ((e (expand-install-global n (expand e r w mod)))) - (top-level-eval-hook e mod) - (if (memq 'load esew) (values (cons e exps)) (values exps)))) - ((memq 'load esew) - (values - (cons (expand-install-global n (expand e r w mod)) exps))) - (else (values exps)))) - ((memv key '(c&e)) - (let ((e (expand-install-global n (expand e r w mod)))) - (top-level-eval-hook e mod) - (values (cons e exps)))) - (else - (if (memq 'eval esew) - (top-level-eval-hook - (expand-install-global n (expand e r w mod)) - mod)) - (values exps)))))) - ((memv key '(define-form)) - (let* ((n (id-var-name value w)) (type (car (lookup n r mod))) (key type)) - (cond ((memv key '(global core macro module-ref)) - (if (and (memq m '(c c&e)) - (not (module-local-variable (current-module) n)) - (current-module)) - (let ((old (module-variable (current-module) n))) - (if (and (variable? old) - (variable-bound? old) - (not (macro? (variable-ref old)))) - (module-define! (current-module) n (variable-ref old)) - (module-add! (current-module) n (make-undefined-variable))))) - (values - (cons (if (eq? m 'c&e) - (let ((x (build-global-definition s n (expand e r w mod)))) - (top-level-eval-hook x mod) - x) - (lambda () (build-global-definition s n (expand e r w mod)))) - exps))) - ((memv key '(displaced-lexical)) - (syntax-violation - #f - "identifier out of context" - (source-wrap form w s mod) - (wrap value w mod))) - (else - (syntax-violation - #f - "cannot define keyword at top level" - (source-wrap form w s mod) - (wrap value w mod)))))) - (else - (values - (cons (if (eq? m 'c&e) - (let ((x (expand-expr type value form e r w s mod))) - (top-level-eval-hook x mod) - x) - (lambda () (expand-expr type value form e r w s mod))) - exps)))))))) - (lambda (exps) (scan (cdr body) r w s m esew mod exps))))))) - (call-with-values - (lambda () (scan body r w s m esew mod '())) - (lambda (exps) - (if (null? exps) - (build-void s) - (build-sequence - s - (let lp ((in exps) (out '())) - (if (null? in) - out - (let ((e (car in))) - (lp (cdr in) (cons (if (procedure? e) (e) e) out)))))))))))) + mod)) + '()))) + ((memq 'load when-list) + (cond ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (recurse 'c&e '(compile load))) + ((memq m '(c c&e)) (recurse 'c '(load))) + (else '()))) + ((or (memq 'compile when-list) + (memq 'expand when-list) + (and (eq? m 'c&e) (memq 'eval when-list))) + (top-level-eval-hook + (expand-top-sequence body r w s 'e '(eval) mod) + mod) + '()) + (else '()))))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) + (else + (list (if (eq? m 'c&e) + (let ((x (expand-expr type value form e r w s mod))) + (top-level-eval-hook x mod) + (lambda () x)) + (lambda () (expand-expr type value form e r w s mod)))))))))))) + (let ((exps (map (lambda (x) (x)) (reverse (parse body r w s m esew mod))))) + (if (null? exps) (build-void s) (build-sequence s exps))))))) (expand-install-global - (lambda (name e) + (lambda (name type e) (build-global-definition #f name - (build-application + (build-primcall #f - (build-primref #f 'make-syntax-transformer) - (list (build-data #f name) (build-data #f 'macro) e))))) + 'make-syntax-transformer + (if (eq? type 'define-syntax-parameter-form) + (list (build-data #f name) + (build-data #f 'syntax-parameter) + (build-primcall #f 'list (list e))) + (list (build-data #f name) (build-data #f 'macro) e)))))) (parse-when-list (lambda (e when-list) (let ((result (strip when-list '(())))) @@ -693,24 +709,23 @@ (syntax-type (lambda (e r w s rib mod for-car?) (cond ((symbol? e) - (let* ((n (id-var-name e w)) - (b (lookup n r mod)) - (type (car b)) - (key type)) - (cond ((memv key '(lexical)) (values type (cdr b) e e w s mod)) - ((memv key '(global)) (values type n e e w s mod)) - ((memv key '(macro)) - (if for-car? - (values type (cdr b) e e w s mod) - (syntax-type - (expand-macro (cdr b) e r w s rib mod) - r - '(()) - s - rib - mod - #f))) - (else (values type (cdr b) e e w s mod))))) + (call-with-values + (lambda () (resolve-identifier e w r mod #t)) + (lambda (type value mod*) + (let ((key type)) + (cond ((memv key '(macro)) + (if for-car? + (values type value e e w s mod) + (syntax-type + (expand-macro value e r w s rib mod) + r + '(()) + s + rib + mod + #f))) + ((memv key '(global)) (values type value e value w s mod*)) + (else (values type value e e w s mod))))))) ((pair? e) (let ((first (car e))) (call-with-values @@ -719,7 +734,9 @@ (let ((key ftype)) (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) ((memv key '(global)) - (values 'global-call (make-syntax-object fval w fmod) e e w s mod)) + (if (equal? fmod '(primitive)) + (values 'primitive-call fval e e w s mod) + (values 'global-call (make-syntax-object fval w fmod) e e w s mod))) ((memv key '(macro)) (syntax-type (expand-macro fval e r w s rib mod) @@ -731,7 +748,7 @@ for-car?)) ((memv key '(module-ref)) (call-with-values - (lambda () (fval e r w)) + (lambda () (fval e r w mod)) (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) ((memv key '(core)) (values 'core-form fval e e w s mod)) ((memv key '(local-syntax)) @@ -821,10 +838,10 @@ ((memv key '(core core-form)) (value e r w s mod)) ((memv key '(module-ref)) (call-with-values - (lambda () (value e r w)) + (lambda () (value e r w mod)) (lambda (e r w s mod) (expand e r w mod)))) ((memv key '(lexical-call)) - (expand-application + (expand-call (let ((id (car e))) (build-lexical-reference 'fun @@ -837,7 +854,7 @@ s mod)) ((memv key '(global-call)) - (expand-application + (expand-call (build-global-reference (source-annotation (car e)) (if (syntax-object? value) (syntax-object-expression value) value) @@ -847,11 +864,21 @@ w s mod)) + ((memv key '(primitive-call)) + (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) + (if tmp + (apply (lambda (e) + (build-primcall s value (map (lambda (e) (expand e r w mod)) e))) + tmp) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp-1)))) ((memv key '(constant)) (build-data s (strip (source-wrap e w s mod) '(())))) ((memv key '(global)) (build-global-reference s value mod)) ((memv key '(call)) - (expand-application (expand (car e) r w mod) e r w s mod)) + (expand-call (expand (car e) r w mod) e r w s mod)) ((memv key '(begin-form)) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(_ any . each-any)))) (if tmp-1 @@ -860,15 +887,10 @@ (let ((tmp-1 ($sc-dispatch tmp '(_)))) (if tmp-1 (apply (lambda () - (if (include-deprecated-features) - (begin - (issue-deprecation-warning - "Sequences of zero expressions are deprecated. Use *unspecified*.") - (expand-void)) - (syntax-violation - #f - "sequence of zero expressions" - (source-wrap e w s mod)))) + (syntax-violation + #f + "sequence of zero expressions" + (source-wrap e w s mod))) tmp-1) (syntax-violation #f @@ -907,12 +929,12 @@ (source-wrap e w s mod))) (else (syntax-violation #f "unexpected syntax" (source-wrap e w s mod))))))) - (expand-application + (expand-call (lambda (x e r w s mod) (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(any . each-any)))) (if tmp (apply (lambda (e0 e1) - (build-application s x (map (lambda (e) (expand e r w mod)) e1))) + (build-call s x (map (lambda (e) (expand e r w mod)) e1))) tmp) (syntax-violation #f @@ -956,11 +978,14 @@ (source-wrap e w (cdr w) mod) x)) (else (decorate-source x s)))))) - (with-fluids - ((transformer-environment (lambda (k) (k e r w s rib mod)))) - (rebuild-macro-output - (p (source-wrap e (anti-mark w) s mod)) - (gensym (string-append "m-" (session-id) "-"))))))) + (let* ((t-1 transformer-environment) (t (lambda (k) (k e r w s rib mod)))) + (with-fluid* + t-1 + t + (lambda () + (rebuild-macro-output + (p (source-wrap e (anti-mark w) s mod)) + (gensym (string-append "m-" (session-id) "-"))))))))) (expand-body (lambda (body outer-form r w mod) (let* ((r (cons '("placeholder" placeholder) r)) @@ -992,7 +1017,7 @@ (cons var vars) (cons (cons er (wrap e w mod)) vals) (cons (cons 'lexical var) bindings))))) - ((memv key '(define-syntax-form define-syntax-parameter-form)) + ((memv key '(define-syntax-form)) (let ((id (wrap value w mod)) (label (gen-label)) (trans-r (macros-only-env er))) @@ -1004,6 +1029,19 @@ (list (cons 'macro (eval-local-transformer (expand e trans-r w mod) mod))) (cdr r))) (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) + ((memv key '(define-syntax-parameter-form)) + (let ((id (wrap value w mod)) + (label (gen-label)) + (trans-r (macros-only-env er))) + (extend-ribcage! ribcage id label) + (set-cdr! + r + (extend-env + (list label) + (list (cons 'syntax-parameter + (list (eval-local-transformer (expand e trans-r w mod) mod)))) + (cdr r))) + (parse (cdr body) (cons id ids) labels var-ids vars vals bindings))) ((memv key '(begin-form)) (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ . each-any)))) (if tmp @@ -1100,15 +1138,21 @@ (ellipsis? (lambda (e r mod) (and (nonsymbol-id? e) - (let* ((id (make-syntax-object - '#{ $sc-ellipsis }# - (syntax-object-wrap e) - (syntax-object-module e))) - (n (id-var-name id '(()))) - (b (lookup n r mod))) - (if (eq? (car b) 'ellipsis) - (bound-id=? e (cdr b)) - (free-id=? e '#(syntax-object ... ((top)) (hygiene guile)))))))) + (call-with-values + (lambda () + (resolve-identifier + (make-syntax-object + '#{ $sc-ellipsis }# + (syntax-object-wrap e) + (syntax-object-module e)) + '(()) + r + mod + #f)) + (lambda (type value mod) + (if (eq? type 'ellipsis) + (bound-id=? e value) + (free-id=? e '#(syntax-object ... ((top)) (hygiene guile))))))))) (lambda-formals (lambda (orig-args) (letrec* @@ -1526,28 +1570,34 @@ (tmp ($sc-dispatch tmp '(_ #(each (any any)) any . each-any)))) (if (and tmp (apply (lambda (var val e1 e2) (valid-bound-ids? var)) tmp)) (apply (lambda (var val e1 e2) - (let ((names (map (lambda (x) (id-var-name x w)) var))) - (for-each - (lambda (id n) - (let ((key (car (lookup n r mod)))) - (if (memv key '(displaced-lexical)) - (syntax-violation - 'syntax-parameterize - "identifier out of context" - e - (source-wrap id w s mod))))) - var - names) + (let ((names (map (lambda (x) + (call-with-values + (lambda () (resolve-identifier x w r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(displaced-lexical)) + (syntax-violation + 'syntax-parameterize + "identifier out of context" + e + (source-wrap x w s mod))) + ((memv key '(syntax-parameter)) value) + (else + (syntax-violation + 'syntax-parameterize + "invalid syntax parameter" + e + (source-wrap x w s mod)))))))) + var)) + (bindings + (let ((trans-r (macros-only-env r))) + (map (lambda (x) + (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) + val)))) (expand-body (cons e1 e2) (source-wrap e w s mod) - (extend-env - names - (let ((trans-r (macros-only-env r))) - (map (lambda (x) - (cons 'macro (eval-local-transformer (expand x trans-r w mod) mod))) - val)) - r) + (extend-env names bindings r) w mod))) tmp) @@ -1570,16 +1620,17 @@ ((gen-syntax (lambda (src e r maps ellipsis? mod) (if (id? e) - (let* ((label (id-var-name e '(()))) (b (lookup label r mod))) - (cond ((eq? (car b) 'syntax) - (call-with-values - (lambda () - (let ((var.lev (cdr b))) - (gen-ref src (car var.lev) (cdr var.lev) maps))) - (lambda (var maps) (values (list 'ref var) maps)))) - ((ellipsis? e r mod) - (syntax-violation 'syntax "misplaced ellipsis" src)) - (else (values (list 'quote e) maps)))) + (call-with-values + (lambda () (resolve-identifier e '(()) r mod #f)) + (lambda (type value mod) + (let ((key type)) + (cond ((memv key '(syntax)) + (call-with-values + (lambda () (gen-ref src (car value) (cdr value) maps)) + (lambda (var maps) (values (list 'ref var) maps)))) + ((ellipsis? e r mod) + (syntax-violation 'syntax "misplaced ellipsis" src)) + (else (values (list 'quote e) maps)))))) (let* ((tmp e) (tmp-1 ($sc-dispatch tmp '(any any)))) (if (and tmp-1 (apply (lambda (dots e) (ellipsis? dots r mod)) tmp-1)) (apply (lambda (dots e) (gen-syntax src e r maps (lambda (e r mod) #f) mod)) @@ -1689,8 +1740,7 @@ (if (list? (cadr x)) (build-simple-lambda #f (cadr x) #f (cadr x) '() (regen (caddr x))) (error "how did we get here" x))) - (else - (build-application #f (build-primref #f (car x)) (map regen (cdr x))))))))) + (else (build-primcall #f (car x) (map regen (cdr x))))))))) (lambda (e r w s mod) (let* ((e (source-wrap e w s mod)) (tmp e) @@ -1927,41 +1977,41 @@ (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ any any)))) (if (and tmp (apply (lambda (id val) (id? id)) tmp)) (apply (lambda (id val) - (let ((n (id-var-name id w)) - (id-mod (if (syntax-object? id) (syntax-object-module id) mod))) - (let* ((b (lookup n r id-mod)) (key (car b))) - (cond ((memv key '(lexical)) - (build-lexical-assignment - s - (syntax->datum id) - (cdr b) - (expand val r w mod))) - ((memv key '(global)) - (build-global-assignment s n (expand val r w mod) id-mod)) - ((memv key '(macro)) - (let ((p (cdr b))) - (if (procedure-property p 'variable-transformer) - (expand (expand-macro p e r w s #f mod) r '(()) mod) + (call-with-values + (lambda () (resolve-identifier id w r mod #t)) + (lambda (type value id-mod) + (let ((key type)) + (cond ((memv key '(lexical)) + (build-lexical-assignment + s + (syntax->datum id) + value + (expand val r w mod))) + ((memv key '(global)) + (build-global-assignment s value (expand val r w mod) id-mod)) + ((memv key '(macro)) + (if (procedure-property value 'variable-transformer) + (expand (expand-macro value e r w s #f mod) r '(()) mod) (syntax-violation 'set! "not a variable transformer" (wrap e w mod) - (wrap id w id-mod))))) - ((memv key '(displaced-lexical)) - (syntax-violation 'set! "identifier out of context" (wrap id w mod))) - (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))) + (wrap id w id-mod)))) + ((memv key '(displaced-lexical)) + (syntax-violation 'set! "identifier out of context" (wrap id w mod))) + (else (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))))) tmp) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . each-any) any)))) (if tmp (apply (lambda (head tail val) (call-with-values (lambda () (syntax-type head r '(()) #f #f mod #t)) - (lambda (type value formform ee ww ss modmod) + (lambda (type value ee* ee ww ss modmod) (let ((key type)) (if (memv key '(module-ref)) (let ((val (expand val r w mod))) (call-with-values - (lambda () (value (cons head tail) r w)) + (lambda () (value (cons head tail) r w mod)) (lambda (e r w s* mod) (let* ((tmp-1 e) (tmp (list tmp-1))) (if (and tmp (apply (lambda (e) (id? e)) tmp)) @@ -1971,7 +2021,7 @@ #f "source expression failed to match any pattern" tmp-1)))))) - (build-application + (build-call s (expand (list '#(syntax-object setter ((top)) (hygiene guile)) head) @@ -1984,7 +2034,7 @@ (global-extend 'module-ref '@ - (lambda (e r w) + (lambda (e r w mod) (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) (if (and tmp (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) @@ -2004,7 +2054,7 @@ (global-extend 'module-ref '@@ - (lambda (e r w) + (lambda (e r w mod) (letrec* ((remodulate (lambda (x mod) @@ -2023,33 +2073,46 @@ (vector-set! v i (remodulate (vector-ref x i) mod)) (loop (+ i 1))))))) (else x))))) - (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) - (if (and tmp - (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) - (apply (lambda (mod id) - (values - (syntax->datum id) - r - '((top)) - #f - (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) - tmp) - (let ((tmp ($sc-dispatch - tmp-1 - '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) - each-any - any)))) - (if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp)) - (apply (lambda (mod exp) - (let ((mod (syntax->datum - (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) - (values (remodulate exp mod) r w (source-annotation exp) mod))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1)))))))) + (let* ((tmp e) + (tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any)))) + (if (and tmp-1 + (apply (lambda (id) + (and (id? id) + (equal? + (cdr (if (syntax-object? id) (syntax-object-module id) mod)) + '(guile)))) + tmp-1)) + (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive))) + tmp-1) + (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any)))) + (if (and tmp-1 + (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1)) + (apply (lambda (mod id) + (values + (syntax->datum id) + r + '((top)) + #f + (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + tmp-1) + (let ((tmp-1 ($sc-dispatch + tmp + '(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) + each-any + any)))) + (if (and tmp-1 (apply (lambda (mod exp) (and-map id? mod)) tmp-1)) + (apply (lambda (mod exp) + (let ((mod (syntax->datum + (cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) + (values (remodulate exp mod) r w (source-annotation exp) mod))) + tmp-1) + (syntax-violation + #f + "source expression failed to match any pattern" + tmp)))))))))) (global-extend 'core 'if @@ -2076,24 +2139,6 @@ #f "source expression failed to match any pattern" tmp))))))) - (global-extend - 'core - 'with-fluids - (lambda (e r w s mod) - (let* ((tmp-1 e) - (tmp ($sc-dispatch tmp-1 '(_ #(each (any any)) any . each-any)))) - (if tmp - (apply (lambda (fluid val b b*) - (build-dynlet - s - (map (lambda (x) (expand x r w mod)) fluid) - (map (lambda (x) (expand x r w mod)) val) - (expand-body (cons b b*) (source-wrap e w s mod) r w mod))) - tmp) - (syntax-violation - #f - "source expression failed to match any pattern" - tmp-1))))) (global-extend 'begin 'begin '()) (global-extend 'define 'define '()) (global-extend 'define-syntax 'define-syntax '()) @@ -2175,9 +2220,9 @@ (lambda (pvars exp y r mod) (let ((ids (map car pvars)) (levels (map cdr pvars))) (let ((labels (gen-labels ids)) (new-vars (map gen-var ids))) - (build-application + (build-primcall #f - (build-primref #f 'apply) + 'apply (list (build-simple-lambda #f (map syntax->datum ids) @@ -2207,7 +2252,7 @@ (syntax-violation 'syntax-case "duplicate pattern variable" pat)) (else (let ((y (gen-var 'tmp))) - (build-application + (build-call #f (build-simple-lambda #f @@ -2229,17 +2274,14 @@ (build-dispatch-call pvars exp y r mod) (gen-syntax-case x keys clauses r mod)))) (list (if (eq? p 'any) - (build-application #f (build-primref #f 'list) (list x)) - (build-application - #f - (build-primref #f '$sc-dispatch) - (list x (build-data #f p))))))))))))) + (build-primcall #f 'list (list x)) + (build-primcall #f '$sc-dispatch (list x (build-data #f p))))))))))))) (gen-syntax-case (lambda (x keys clauses r mod) (if (null? clauses) - (build-application + (build-primcall #f - (build-primref #f 'syntax-violation) + 'syntax-violation (list (build-data #f #f) (build-data #f "source expression failed to match any pattern") x)) @@ -2253,7 +2295,7 @@ (if (free-id=? pat '#(syntax-object _ ((top)) (hygiene guile))) (expand exp r '(()) mod) (let ((labels (list (gen-label))) (var (gen-var pat))) - (build-application + (build-call #f (build-simple-lambda #f @@ -2283,7 +2325,7 @@ (apply (lambda (val key m) (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x r mod)))) key) (let ((x (gen-var 'tmp))) - (build-application + (build-call s (build-simple-lambda #f @@ -2368,9 +2410,12 @@ (let ((x id)) (if (not (nonsymbol-id? x)) (syntax-violation 'syntax-module "invalid argument" x))) - (cdr (syntax-object-module id)))) + (let ((mod (syntax-object-module id))) + (and (not (equal? mod '(primitive))) (cdr mod))))) (syntax-local-binding - (lambda (id) + (lambda* (id + #:key + (resolve-syntax-parameters? #t #:resolve-syntax-parameters?)) (let ((x id)) (if (not (nonsymbol-id? x)) (syntax-violation 'syntax-local-binding "invalid argument" x))) @@ -2389,14 +2434,20 @@ (syntax-object-expression id) (strip-anti-mark (syntax-object-wrap id)) r - (syntax-object-module id))) + (syntax-object-module id) + resolve-syntax-parameters?)) (lambda (type value mod) (let ((key type)) (cond ((memv key '(lexical)) (values 'lexical value)) ((memv key '(macro)) (values 'macro value)) + ((memv key '(syntax-parameter)) + (values 'syntax-parameter (car value))) ((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) - ((memv key '(global)) (values 'global (cons value (cdr mod)))) + ((memv key '(global)) + (if (equal? mod '(primitive)) + (values 'primitive value) + (values 'global (cons value (cdr mod))))) ((memv key '(ellipsis)) (values 'ellipsis @@ -2610,7 +2661,16 @@ (apply (lambda (message arg) (string? (syntax->datum message))) tmp) #f) (apply (lambda (message arg) - (cons '#(syntax-object syntax-error ((top)) (hygiene guile)) + (cons '#(syntax-object + syntax-error + ((top) + #(ribcage + #(syntax-error) + #((top)) + #(((hygiene guile) + . + #(syntax-object syntax-error ((top)) (hygiene guile)))))) + (hygiene guile)) (cons '(#f) (cons message arg)))) tmp) (syntax-violation @@ -2671,7 +2731,19 @@ (list (vector '(#(syntax-object macro-type ((top)) (hygiene guile)) . - #(syntax-object syntax-rules ((top)) (hygiene guile))) + #(syntax-object + syntax-rules + ((top) + #(ribcage + #(syntax-rules) + #((top)) + #(((hygiene guile) + . + #(syntax-object + syntax-rules + ((top)) + (hygiene guile)))))) + (hygiene guile))) (cons '#(syntax-object patterns ((top)) (hygiene guile)) pattern)) (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) @@ -2844,11 +2916,32 @@ tmp-1) (let ((tmp-1 ($sc-dispatch tmp - '(#(free-id #(syntax-object quasiquote ((top)) (hygiene guile))) any)))) + '(#(free-id + #(syntax-object + quasiquote + ((top) + #(ribcage + #(quasiquote) + #((top)) + #(((hygiene guile) + . + #(syntax-object quasiquote ((top)) (hygiene guile)))))) + (hygiene guile))) + any)))) (if tmp-1 (apply (lambda (p) (quasicons - '("quote" #(syntax-object quasiquote ((top)) (hygiene guile))) + '("quote" + #(syntax-object + quasiquote + ((top) + #(ribcage + #(quasiquote) + #((top)) + #(((hygiene guile) + . + #(syntax-object quasiquote ((top)) (hygiene guile)))))) + (hygiene guile))) (quasi (list p) (+ lev 1)))) tmp-1) (let ((tmp-1 ($sc-dispatch tmp '(any . any)))) @@ -3241,7 +3334,16 @@ '(#(syntax-object x ((top)) (hygiene guile))) '#((#(syntax-object macro-type ((top)) (hygiene guile)) . - #(syntax-object identifier-syntax ((top)) (hygiene guile)))) + #(syntax-object + identifier-syntax + ((top) + #(ribcage + #(identifier-syntax) + #((top)) + #(((hygiene guile) + . + #(syntax-object identifier-syntax ((top)) (hygiene guile)))))) + (hygiene guile)))) (list '#(syntax-object syntax-case ((top)) (hygiene guile)) '#(syntax-object x ((top)) (hygiene guile)) '() |