mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 22:10:21 +02:00
psyntax: ((@@ primitive NAME) ARG ...) in (guile) module is a primcall
* 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
parent
9b965638e9
commit
9833864171
3 changed files with 159 additions and 66 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue