mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 06:41:13 +02:00
Code Activity

psyntax: ((@@ primitive NAME) ARG ...) in (guile) module is a primcall

Browse source 
* ice-9/psyntax.scm (@@): Recognize new form, (@@ primitive NAME), which
  in operator position expands to a primcall.  This expansion is only
  available for forms in the (guile) module.  Added an argument to @@
  and @ procedures, the module, for use by expanded syntax objects;
  adapted callers.
  (analyze-variable): Error when accessing a primitive for value.
  (get-global-definition-hook): Primitives are not macros.
  (syntax-type): A form with a primitive in the car is a
  primitive-call.
  (expand-expr): Residualize primitive calls as primcalls.
  (syntax-local-binding): Return 'primitive as the type for primitives.
This commit is contained in:
Andy Wingo 2013-06-23 21:36:08 +02:00
parent 9b965638e9
commit 9833864171
3 changed files with 159 additions and 66 deletions
Download patch file Download diff file Expand all files Collapse all files

120
module/ice-9/psyntax-pp.scm
View file

@ -124,15 +124,16 @@
(lambda (symbol module) (lambda (symbol module)
(if (and (not module) (current-module)) (if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol)) (warn "module system is booted, we should have a module" symbol))
(let ((v (module-variable (and (not (equal? module '(primitive)))
(if module (resolve-module (cdr module)) (current-module)) (let ((v (module-variable
symbol))) (if module (resolve-module (cdr module)) (current-module))
(and v symbol)))
(variable-bound? v) (and v
(let ((val (variable-ref v))) (variable-bound? v)
(and (macro? val) (let ((val (variable-ref v)))
(macro-type val) (and (macro? val)
(cons (macro-type val) (macro-binding val)))))))) (macro-type val)
(cons (macro-type val) (macro-binding val)))))))))
(decorate-source (decorate-source
(lambda (e s) (lambda (e s)
(if (and s (supports-source-properties? e)) (if (and s (supports-source-properties? e))
@ -177,6 +178,8 @@
(module-variable (resolve-module mod) var)) (module-variable (resolve-module mod) var))
(modref-cont mod var #f) (modref-cont mod var #f)
(bare-cont var))) (bare-cont var)))
((memv key '(primitive))
(syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod)))))))) (else (syntax-violation #f "bad module kind" var mod))))))))
(build-global-reference (build-global-reference
(lambda (source var mod) (lambda (source var mod)
@ -736,7 +739,9 @@
(let ((key ftype)) (let ((key ftype))
(cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod)) (cond ((memv key '(lexical)) (values 'lexical-call fval e e w s mod))
((memv key '(global)) ((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)) ((memv key '(macro))
(syntax-type (syntax-type
(expand-macro fval e r w s rib mod) (expand-macro fval e r w s rib mod)
@ -748,7 +753,7 @@
for-car?)) for-car?))
((memv key '(module-ref)) ((memv key '(module-ref))
(call-with-values (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?)))) (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 '(core)) (values 'core-form fval e e w s mod))
((memv key '(local-syntax)) ((memv key '(local-syntax))
@ -838,7 +843,7 @@
((memv key '(core core-form)) (value e r w s mod)) ((memv key '(core core-form)) (value e r w s mod))
((memv key '(module-ref)) ((memv key '(module-ref))
(call-with-values (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)))) (lambda (e r w s mod) (expand e r w mod))))
((memv key '(lexical-call)) ((memv key '(lexical-call))
(expand-call (expand-call
@ -864,6 +869,16 @@
w w
s s
mod)) 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)) ((memv key '(constant))
(build-data s (strip (source-wrap e w s mod) '(())))) (build-data s (strip (source-wrap e w s mod) '(()))))
((memv key '(global)) (build-global-reference s value mod)) ((memv key '(global)) (build-global-reference s value mod))
@ -1959,7 +1974,7 @@
(if (memv key '(module-ref)) (if (memv key '(module-ref))
(let ((val (expand val r w mod))) (let ((val (expand val r w mod)))
(call-with-values (call-with-values
(lambda () (value (cons head tail) r w)) (lambda () (value (cons head tail) r w mod))
(lambda (e r w s* mod) (lambda (e r w s* mod)
(let* ((tmp-1 e) (tmp (list tmp-1))) (let* ((tmp-1 e) (tmp (list tmp-1)))
(if (and tmp (apply (lambda (e) (id? e)) tmp)) (if (and tmp (apply (lambda (e) (id? e)) tmp))
@ -1982,7 +1997,7 @@
(global-extend (global-extend
'module-ref 'module-ref
'@ '@
(lambda (e r w) (lambda (e r w mod)
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) (let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any))))
(if (and tmp (if (and tmp
(apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp))
@ -2002,7 +2017,7 @@
(global-extend (global-extend
'module-ref 'module-ref
'@@ '@@
(lambda (e r w) (lambda (e r w mod)
(letrec* (letrec*
((remodulate ((remodulate
(lambda (x mod) (lambda (x mod)
@ -2021,33 +2036,46 @@
(vector-set! v i (remodulate (vector-ref x i) mod)) (vector-set! v i (remodulate (vector-ref x i) mod))
(loop (+ i 1))))))) (loop (+ i 1)))))))
(else x))))) (else x)))))
(let* ((tmp-1 e) (tmp ($sc-dispatch tmp-1 '(_ each-any any)))) (let* ((tmp e)
(if (and tmp (tmp-1 ($sc-dispatch
(apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp)) tmp
(apply (lambda (mod id) '(_ #(free-id #(syntax-object primitive ((top)) (hygiene guile))) any))))
(values (if (and tmp-1
(syntax->datum id) (apply (lambda (id)
r (and (id? id)
'((top)) (equal?
#f (cdr (if (syntax-object? id) (syntax-object-module id) mod))
(syntax->datum '(guile))))
(cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) tmp-1))
tmp) (apply (lambda (id) (values (syntax->datum id) r '((top)) #f '(primitive)))
(let ((tmp ($sc-dispatch tmp-1)
tmp-1 (let ((tmp-1 ($sc-dispatch tmp '(_ each-any any))))
'(_ #(free-id #(syntax-object @@ ((top)) (hygiene guile))) (if (and tmp-1
each-any (apply (lambda (mod id) (and (and-map id? mod) (id? id))) tmp-1))
any)))) (apply (lambda (mod id)
(if (and tmp (apply (lambda (mod exp) (and-map id? mod)) tmp)) (values
(apply (lambda (mod exp) (syntax->datum id)
(let ((mod (syntax->datum r
(cons '#(syntax-object private ((top)) (hygiene guile)) mod)))) '((top))
(values (remodulate exp mod) r w (source-annotation exp) mod))) #f
tmp) (syntax->datum
(syntax-violation (cons '#(syntax-object private ((top)) (hygiene guile)) mod))))
#f tmp-1)
"source expression failed to match any pattern" (let ((tmp-1 ($sc-dispatch
tmp-1)))))))) 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 (global-extend
'core 'core
'if 'if
@ -2359,7 +2387,8 @@
(let ((x id)) (let ((x id))
(if (not (nonsymbol-id? x)) (if (not (nonsymbol-id? x))
(syntax-violation 'syntax-module "invalid argument" 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 (syntax-local-binding
(lambda* (id (lambda* (id
#:key #:key
@ -2392,7 +2421,10 @@
(values 'syntax-parameter (car value))) (values 'syntax-parameter (car value)))
((memv key '(syntax)) (values 'pattern-variable value)) ((memv key '(syntax)) (values 'pattern-variable value))
((memv key '(displaced-lexical)) (values 'displaced-lexical #f)) ((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))))))))))) (else (values 'other #f)))))))))))
(syntax-locally-bound-identifiers (syntax-locally-bound-identifiers
(lambda (id) (lambda (id)

72
module/ice-9/psyntax.scm
View file

@ -289,15 +289,16 @@
(lambda (symbol module) (lambda (symbol module)
(if (and (not module) (current-module)) (if (and (not module) (current-module))
(warn "module system is booted, we should have a module" symbol)) (warn "module system is booted, we should have a module" symbol))
(let ((v (module-variable (if module (and (not (equal? module '(primitive)))
(resolve-module (cdr module)) (let ((v (module-variable (if module
(current-module)) (resolve-module (cdr module))
symbol))) (current-module))
(and v (variable-bound? v) symbol)))
(let ((val (variable-ref v))) (and v (variable-bound? v)
(and (macro? val) (macro-type val) (let ((val (variable-ref v)))
(cons (macro-type val) (and (macro? val) (macro-type val)
(macro-binding val))))))))) (cons (macro-type val)
(macro-binding val))))))))))
(define (decorate-source e s) (define (decorate-source e s)
@ -352,6 +353,8 @@
(module-variable (resolve-module mod) var)) (module-variable (resolve-module mod) var))
(modref-cont mod var #f) (modref-cont mod var #f)
(bare-cont var))) (bare-cont var)))
((primitive)
(syntax-violation #f "primitive not in operator position" var))
(else (syntax-violation #f "bad module kind" var mod)))))) (else (syntax-violation #f "bad module kind" var mod))))))
(define build-global-reference (define build-global-reference
@ -1222,6 +1225,7 @@
;; displaced-lexical none displaced lexical identifier ;; displaced-lexical none displaced lexical identifier
;; lexical-call name call to lexical variable ;; lexical-call name call to lexical variable
;; global-call name call to global variable ;; global-call name call to global variable
;; primitive-call name call to primitive
;; call none any other call ;; call none any other call
;; begin-form none begin expression ;; begin-form none begin expression
;; define-form id variable definition ;; define-form id variable definition
@ -1268,16 +1272,19 @@
((lexical) ((lexical)
(values 'lexical-call fval e e w s mod)) (values 'lexical-call fval e e w s mod))
((global) ((global)
;; If we got here via an (@@ ...) expansion, we need to (if (equal? fmod '(primitive))
;; make sure the fmod information is propagated back (values 'primitive-call fval e e w s mod)
;; correctly -- hence this consing. ;; If we got here via an (@@ ...) expansion, we
(values 'global-call (make-syntax-object fval w fmod) ;; need to make sure the fmod information is
e e w s mod)) ;; propagated back correctly -- hence this
;; consing.
(values 'global-call (make-syntax-object fval w fmod)
e e w s mod)))
((macro) ((macro)
(syntax-type (expand-macro fval e r w s rib mod) (syntax-type (expand-macro fval e r w s rib mod)
r empty-wrap s rib mod for-car?)) r empty-wrap s rib mod for-car?))
((module-ref) ((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) (lambda (e r w s mod)
(syntax-type e r w s rib mod for-car?)))) (syntax-type e r w s rib mod for-car?))))
((core) ((core)
@ -1346,7 +1353,7 @@
;; apply transformer ;; apply transformer
(value e r w s mod)) (value e r w s mod))
((module-ref) ((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) (lambda (e r w s mod)
(expand e r w mod)))) (expand e r w mod))))
((lexical-call) ((lexical-call)
@ -1368,6 +1375,13 @@
(syntax-object-module value) (syntax-object-module value)
mod)) mod))
e r w s 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))) ((constant) (build-data s (strip (source-wrap e w s mod) empty-wrap)))
((global) (build-global-reference s value mod)) ((global) (build-global-reference s value mod))
((call) (expand-call (expand (car e) r w mod) e r w s mod)) ((call) (expand-call (expand (car e) r w mod) e r w s mod))
@ -2321,7 +2335,7 @@
(case type (case type
((module-ref) ((module-ref)
(let ((val (expand #'val r w mod))) (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) (lambda (e r w s* mod)
(syntax-case e () (syntax-case e ()
(e (id? #'e) (e (id? #'e)
@ -2335,7 +2349,7 @@
(_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod)))))) (_ (syntax-violation 'set! "bad set!" (source-wrap e w s mod))))))
(global-extend 'module-ref '@ (global-extend 'module-ref '@
(lambda (e r w) (lambda (e r w mod)
(syntax-case e () (syntax-case e ()
((_ (mod ...) id) ((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id)) (and (and-map id? #'(mod ...)) (id? #'id))
@ -2346,7 +2360,7 @@
#'(public mod ...))))))) #'(public mod ...)))))))
(global-extend 'module-ref '@@ (global-extend 'module-ref '@@
(lambda (e r w) (lambda (e r w mod)
(define remodulate (define remodulate
(lambda (x mod) (lambda (x mod)
(cond ((pair? x) (cond ((pair? x)
@ -2364,7 +2378,16 @@
((fx= i n) v) ((fx= i n) v)
(vector-set! v i (remodulate (vector-ref x i) mod))))) (vector-set! v i (remodulate (vector-ref x i) mod)))))
(else x)))) (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) ((_ (mod ...) id)
(and (and-map id? #'(mod ...)) (id? #'id)) (and (and-map id? #'(mod ...)) (id? #'id))
;; Strip the wrap from the identifier and return top-wrap ;; Strip the wrap from the identifier and return top-wrap
@ -2660,7 +2683,9 @@
(let () (let ()
(define (syntax-module id) (define (syntax-module id)
(arg-check nonsymbol-id? id 'syntax-module) (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)) (define* (syntax-local-binding id #:key (resolve-syntax-parameters? #t))
(arg-check nonsymbol-id? id 'syntax-local-binding) (arg-check nonsymbol-id? id 'syntax-local-binding)
@ -2687,7 +2712,10 @@
((syntax-parameter) (values 'syntax-parameter (car value))) ((syntax-parameter) (values 'syntax-parameter (car value)))
((syntax) (values 'pattern-variable value)) ((syntax) (values 'pattern-variable value))
((displaced-lexical) (values 'displaced-lexical #f)) ((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)))))))) (else (values 'other #f))))))))
(define (syntax-locally-bound-identifiers id) (define (syntax-locally-bound-identifiers id)

33
test-suite/tests/syncase.test
View file

@ -22,6 +22,7 @@
(define-module (test-suite test-syncase) (define-module (test-suite test-syncase)
#:use-module (test-suite lib) #:use-module (test-suite lib)
#:use-module (system base compile) #:use-module (system base compile)
#:use-module (ice-9 regex)
#:use-module ((srfi srfi-1) :select (member))) #:use-module ((srfi srfi-1) :select (member)))
(define-syntax plus (define-syntax plus
@ -274,3 +275,35 @@
(pass-if "syntax-parameters (unresolved)" (pass-if "syntax-parameters (unresolved)"
(equal? (syntax-type foo #f) 'syntax-parameter))) (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)))))