(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))
(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)
(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)
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))
((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
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))
(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))
(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))
(global-extend
'module-ref
'@@
- (lambda (e r w)
+ (lambda (e r w mod)
(letrec*
((remodulate
(lambda (x mod)
(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
(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
(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)
(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)
(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
;; 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
((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)
;; 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)
(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))
(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)
(_ (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))
#'(public mod ...)))))))
(global-extend 'module-ref '@@
- (lambda (e r w)
+ (lambda (e r w mod)
(define remodulate
(lambda (x mod)
(cond ((pair? x)
((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
(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)
((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)
(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
(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)))))
HCoop / bpt / guile.git / commitdiff