diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 4476f5037..fe16ae464 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -124,15 +124,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)) @@ -177,6 +178,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) @@ -736,7 +739,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) @@ -748,7 +753,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)) @@ -838,7 +843,7 @@ ((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-call @@ -864,6 +869,16 @@ 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)) @@ -1959,7 +1974,7 @@ (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)) @@ -1982,7 +1997,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)) @@ -2002,7 +2017,7 @@ (global-extend 'module-ref '@@ - (lambda (e r w) + (lambda (e r w mod) (letrec* ((remodulate (lambda (x mod) @@ -2021,33 +2036,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 @@ -2359,7 +2387,8 @@ (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 #:key @@ -2392,7 +2421,10 @@ (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))))) (else (values 'other #f))))))))))) (syntax-locally-bound-identifiers (lambda (id) diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 0176adb08..515bef3bb 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -289,15 +289,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)))))))))) (define (decorate-source e s) @@ -352,6 +353,8 @@ (module-variable (resolve-module mod) var)) (modref-cont mod var #f) (bare-cont var))) + ((primitive) + (syntax-violation #f "primitive not in operator position" var)) (else (syntax-violation #f "bad module kind" var mod)))))) (define build-global-reference @@ -1222,6 +1225,7 @@ ;; displaced-lexical none displaced lexical identifier ;; lexical-call name call to lexical variable ;; global-call name call to global variable + ;; primitive-call name call to primitive ;; call none any other call ;; begin-form none begin expression ;; define-form id variable definition @@ -1268,16 +1272,19 @@ ((lexical) (values 'lexical-call fval e e w s mod)) ((global) - ;; If we got here via an (@@ ...) expansion, we need to - ;; make sure the fmod information is propagated back - ;; correctly -- hence this consing. - (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) + ;; If we got here via an (@@ ...) expansion, we + ;; need to make sure the fmod information is + ;; propagated back correctly -- hence this + ;; consing. + (values 'global-call (make-syntax-object fval w fmod) + e e w s mod))) ((macro) (syntax-type (expand-macro fval e r w s rib mod) r empty-wrap s rib mod for-car?)) ((module-ref) - (call-with-values (lambda () (fval e r w)) + (call-with-values (lambda () (fval e r w mod)) (lambda (e r w s mod) (syntax-type e r w s rib mod for-car?)))) ((core) @@ -1346,7 +1353,7 @@ ;; apply transformer (value e r w s mod)) ((module-ref) - (call-with-values (lambda () (value e r w)) + (call-with-values (lambda () (value e r w mod)) (lambda (e r w s mod) (expand e r w mod)))) ((lexical-call) @@ -1368,6 +1375,13 @@ (syntax-object-module value) mod)) e r w s mod)) + ((primitive-call) + (syntax-case e () + ((_ e ...) + (build-primcall s + value + (map (lambda (e) (expand e r w mod)) + #'(e ...)))))) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap))) ((global) (build-global-reference s value mod)) ((call) (expand-call (expand (car e) r w mod) e r w s mod)) @@ -2321,7 +2335,7 @@ (case type ((module-ref) (let ((val (expand #'val r w mod))) - (call-with-values (lambda () (value #'(head tail ...) r w)) + (call-with-values (lambda () (value #'(head tail ...) r w mod)) (lambda (e r w s* mod) (syntax-case e () (e (id? #'e) @@ -2335,7 +2349,7 @@ (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (global-extend 'module-ref '@ - (lambda (e r w) + (lambda (e r w mod) (syntax-case e () ((_ (mod ...) id) (and (and-map id? #'(mod ...)) (id? #'id)) @@ -2346,7 +2360,7 @@ #'(public mod ...))))))) (global-extend 'module-ref '@@ - (lambda (e r w) + (lambda (e r w mod) (define remodulate (lambda (x mod) (cond ((pair? x) @@ -2364,7 +2378,16 @@ ((fx= i n) v) (vector-set! v i (remodulate (vector-ref x i) mod))))) (else x)))) - (syntax-case e (@@) + (syntax-case e (@@ primitive) + ((_ primitive id) + (and (id? #'id) + (equal? (cdr (if (syntax-object? #'id) + (syntax-object-module #'id) + mod)) + '(guile))) + ;; Strip the wrap from the identifier and return top-wrap + ;; so that the identifier will not be captured by lexicals. + (values (syntax->datum #'id) r top-wrap #f '(primitive))) ((_ (mod ...) id) (and (and-map id? #'(mod ...)) (id? #'id)) ;; Strip the wrap from the identifier and return top-wrap @@ -2660,7 +2683,9 @@ (let () (define (syntax-module id) (arg-check nonsymbol-id? id 'syntax-module) - (cdr (syntax-object-module id))) + (let ((mod (syntax-object-module id))) + (and (not (equal? mod '(primitive))) + (cdr mod)))) (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t)) (arg-check nonsymbol-id? id 'syntax-local-binding) @@ -2687,7 +2712,10 @@ ((syntax-parameter) (values 'syntax-parameter (car value))) ((syntax) (values 'pattern-variable value)) ((displaced-lexical) (values 'displaced-lexical #f)) - ((global) (values 'global (cons value (cdr mod)))) + ((global) + (if (equal? mod '(primitive)) + (values 'primitive value) + (values 'global (cons value (cdr mod))))) (else (values 'other #f)))))))) (define (syntax-locally-bound-identifiers id) diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test index ee6446773..15c811cc9 100644 --- a/test-suite/tests/syncase.test +++ b/test-suite/tests/syncase.test @@ -22,6 +22,7 @@ (define-module (test-suite test-syncase) #:use-module (test-suite lib) #:use-module (system base compile) + #:use-module (ice-9 regex) #:use-module ((srfi srfi-1) :select (member))) (define-syntax plus @@ -274,3 +275,35 @@ (pass-if "syntax-parameters (unresolved)" (equal? (syntax-type foo #f) 'syntax-parameter))) + +;; (put 'pass-if-syntax-error 'scheme-indent-function 1) +(define-syntax pass-if-syntax-error + (syntax-rules () + ((_ name pat exp) + (pass-if name + (catch 'syntax-error + (lambda () exp (error "expected syntax-error exception")) + (lambda (k who what where form . maybe-subform) + (if (if (pair? pat) + (and (eq? who (car pat)) + (string-match (cdr pat) what)) + (string-match pat what)) + #t + (error "unexpected syntax-error exception" what pat)))))))) + +(with-test-prefix "primitives" + (pass-if-syntax-error "primref in default module" + "failed to match" + (macroexpand '(@@ primitive cons))) + + (pass-if-syntax-error "primcall in default module" + "failed to match" + (macroexpand '((@@ primitive cons) 1 2))) + + (pass-if-equal "primcall in (guile)" + '(1 . 2) + (@@ @@ (guile) ((@@ primitive cons) 1 2))) + + (pass-if-syntax-error "primref in (guile)" + "not in operator position" + (macroexpand '(@@ @@ (guile) (@@ primitive cons)))))