suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

rename metafunction -> template-metafunction

Browse Source
This commit is contained in:
AlexKnauth 2019-02-15 22:14:59 -05:00 committed by Suzanne Soy
parent 121a45f7ed
commit 057bcab015
3 changed files with 36 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

45
racket/collects/racket/private/prop-template-metafunction.rkt
View File

@ -1,17 +1,17 @@
(module prop-template-metafunction '#%kernel (module prop-template-metafunction '#%kernel
(#%provide (protect metafunction (#%provide (protect template-metafunction
prop:metafunction prop:template-metafunction
(rename prop:metafunction? metafunction?) (rename prop:template-metafunction? template-metafunction?)
metafunction-accessor)) template-metafunction-accessor))
;; The prop:metafunction structure type property can contain an ;; The prop:template-metafunction structure type property can contain an
;; identifier bound to the run-time metafunction procedure, or the index of a ;; identifier bound to the run-time metafunction procedure, or the index of a
;; field containing such an identifier. ;; field containing such an identifier.
;; At run-time, when processing the template, the syntax object whose first ;; At run-time, when processing the template, the syntax object whose first
;; element is a metafunction identifiers is passed to this metafunction ;; element is a metafunction identifiers is passed to this metafunction
;; procedure. ;; procedure.
(define-values (prop:metafunction-guard) (define-values (prop:template-metafunction-guard)
(lambda (val struct-type-info-list) (lambda (val struct-type-info-list)
(if (exact-nonnegative-integer? val) (if (exact-nonnegative-integer? val)
;; Field index, the field must contain an identifier bound to the run-time ;; Field index, the field must contain an identifier bound to the run-time
@ -27,7 +27,7 @@
#f) #f)
metafunction-internal-id metafunction-internal-id
(raise-argument-error (raise-argument-error
'prop:metafunction-guard 'prop:template-metafunction-guard
(format (string-append "the value of the ~a-th field should be" (format (string-append "the value of the ~a-th field should be"
" an identifier") " an identifier")
val) val)
@ -38,32 +38,37 @@
(λ (_instance) val) (λ (_instance) val)
;; Otherwise, raise an error. ;; Otherwise, raise an error.
(raise-argument-error (raise-argument-error
'prop:metafunction-guard 'prop:template-metafunction-guard
(string-append "an identifier, or an exact non-negative integer designating" (string-append "an identifier, or an exact non-negative integer designating"
" a field index within the structure that should contain an" " a field index within the structure that should contain an"
" identifier.") " identifier.")
val))))) val)))))
(define-values (prop:metafunction (define-values (prop:template-metafunction
prop:metafunction? prop:template-metafunction?
metafunction-raw-accessor) template-metafunction-raw-accessor)
(make-struct-type-property 'metafunction (make-struct-type-property 'template-metafunction
prop:metafunction-guard)) prop:template-metafunction-guard))
(define-values (metafunction-accessor) (define-values (template-metafunction-accessor)
(lambda (instance . more-args) (lambda (instance . more-args)
(let-values ([(raw) (if (null? more-args) ;; no failure-result given (let-values ([(raw) (if (null? more-args) ;; no failure-result given
(metafunction-raw-accessor instance) (template-metafunction-raw-accessor instance)
(if (null? (cdr more-args)) (if (null? (cdr more-args))
(let-values ([(failure-result) (car more-args)]) (let-values ([(failure-result) (car more-args)])
(metafunction-raw-accessor instance failure-result)) (template-metafunction-raw-accessor instance
failure-result))
(error "invalid number of arguments [TODO]")))]) (error "invalid number of arguments [TODO]")))])
(raw instance)))) (raw instance))))
;; A default struct type with prop:metafunction. ;; A default struct type with prop:template-metafunction.
;; (struct template-metafunction (proc-id) ;; (struct template-metafunction (proc-id)
;; #:property prop:template-metafunction (struct-field-index proc-id)) ;; #:property prop:template-metafunction (struct-field-index proc-id))
(define-values (struct:metafunction metafunction metafunction? metafunction-ref _mf-set!) (define-values (_struct:template-metafunction
(make-struct-type 'syntax-metafunction #f 1 0 #f template-metafunction
(list (cons prop:metafunction 0)) _template-metafunction?
_template-metafunction-ref
_mf-set!)
(make-struct-type 'template-metafunction #f 1 0 #f
(list (cons prop:template-metafunction 0))
(current-inspector)))) (current-inspector))))

13
racket/collects/racket/private/template.rkt
View File

@ -13,9 +13,9 @@
datum datum
~? ~@ ~? ~@
~@! signal-absent-pvar ~@! signal-absent-pvar
(for-syntax prop:metafunction (for-syntax prop:template-metafunction
metafunction template-metafunction
metafunction?) template-metafunction?)
(protect (protect
(for-syntax attribute-mapping (for-syntax attribute-mapping
attribute-mapping? attribute-mapping?
@ -30,7 +30,8 @@
;; A Template (T) is one of: ;; A Template (T) is one of:
;; - pattern-variable ;; - pattern-variable
;; - constant (including () and non-pvar identifiers) ;; - constant (including () and non-pvar identifiers)
;; - (metafunction . T) ;; - (template-metafunction . T)
;; ; or any other structure that implements prop:template-metafunction
;; - (H . T) ;; - (H . T)
;; - (H ... . T), (H ... ... . T), etc ;; - (H ... . T), (H ... ... . T), etc
;; - (... T) -- escapes inner ..., ~?, ~@ ;; - (... T) -- escapes inner ..., ~?, ~@
@ -273,7 +274,7 @@
(unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported")) (unless stx? (wrong-syntax (stx-car t) "metafunctions are not supported"))
(disappeared! (stx-car t)) (disappeared! (stx-car t))
(define guide (parse-t (stx-cdr t) depth esc?)) (define guide (parse-t (stx-cdr t) depth esc?))
`(t-metafun ,(metafunction-accessor mf) ,guide `(t-metafun ,(template-metafunction-accessor mf) ,guide
(quote-syntax (quote-syntax
,(let ([tstx (and (syntax? t) t)]) ,(let ([tstx (and (syntax? t) t)])
(datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))] (datum->syntax tstx (cons (stx-car t) #f) tstx tstx)))))]
@ -495,7 +496,7 @@
;; lookup-metafun : Identifier -> Metafunction/#f ;; lookup-metafun : Identifier -> Metafunction/#f
(define (lookup-metafun id) (define (lookup-metafun id)
(define v (syntax-local-value id (lambda () #f))) (define v (syntax-local-value id (lambda () #f)))
(and (metafunction? v) v)) (and (template-metafunction? v) v))
(define (dotted-prefixes id) (define (dotted-prefixes id)
(let* ([id-string (symbol->string (syntax-e id))] (let* ([id-string (symbol->string (syntax-e id))]

5
racket/collects/syntax/parse/experimental/template.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) (require (for-syntax racket/base)
(only-in racket/private/template (only-in racket/private/template
metafunction)) template-metafunction))
(provide (rename-out [syntax template] (provide (rename-out [syntax template]
[syntax/loc template/loc] [syntax/loc template/loc]
[quasisyntax quasitemplate] [quasisyntax quasitemplate]
@ -21,7 +21,8 @@
(identifier? #'id) (identifier? #'id)
(with-syntax ([(internal-id) (generate-temporaries #'(id))]) (with-syntax ([(internal-id) (generate-temporaries #'(id))])
#'(begin (define internal-id (make-hygienic-metafunction expr)) #'(begin (define internal-id (make-hygienic-metafunction expr))
(define-syntax id (metafunction (quote-syntax internal-id)))))])) (define-syntax id
(template-metafunction (quote-syntax internal-id)))))]))
(define current-template-metafunction-introducer (define current-template-metafunction-introducer
(make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx))))