[honu] move honu-syntax to syntax.rkt. allow each pattern to specify a syntax result
This commit is contained in:
parent
ae15ef55b3
commit
dc1b34479c
|
@ -9,6 +9,7 @@
|
|||
"private/macro2.rkt"
|
||||
"private/class.rkt"
|
||||
"private/operator.rkt"
|
||||
"private/syntax.rkt"
|
||||
(prefix-in literal: "private/literals.rkt")
|
||||
(prefix-in syntax-parse: syntax/parse)
|
||||
(prefix-in racket: racket/base)
|
||||
|
|
|
@ -7,6 +7,7 @@
|
|||
racket/syntax
|
||||
"template.rkt"
|
||||
"literals.rkt"
|
||||
"syntax.rkt"
|
||||
(prefix-in phase1: "parse2.rkt")
|
||||
"debug.rkt"
|
||||
(prefix-in phase1: "compile.rkt")
|
||||
|
@ -333,43 +334,6 @@
|
|||
(syntax #'stuff*))])))
|
||||
|#
|
||||
|
||||
(provide honu-syntax)
|
||||
;; Do any honu-specific expansion here
|
||||
(define-honu-syntax honu-syntax
|
||||
(lambda (code)
|
||||
(syntax-parse code #:literal-sets (cruft)
|
||||
#;
|
||||
[(_ (#%parens single) . rest)
|
||||
(define context #'single)
|
||||
(define compressed (compress-dollars #'single))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context compressed context context)])
|
||||
(phase1:racket-syntax #'stuff*))
|
||||
#'rest
|
||||
#f)]
|
||||
[(_ (#%parens stuff ...) . rest)
|
||||
(define context (stx-car #'(stuff ...)))
|
||||
(define compressed (compress-dollars #'(stuff ...)))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context
|
||||
(syntax->list compressed)
|
||||
context context)])
|
||||
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
|
||||
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
|
||||
|
||||
;; stuff* will be expanded when this syntax is returned because
|
||||
;; the whole thing will be
|
||||
;; (remove-repeats #'((repeat$ 1) (repeat$ 2)))
|
||||
;; so remove-repeats will be executed later
|
||||
(phase1:racket-syntax
|
||||
(remove-repeats #'stuff*))
|
||||
|
||||
#;
|
||||
(with-syntax ([(out ...) #'stuff*])
|
||||
(phase1:racket-syntax #'stuff*)))
|
||||
#; #'(%racket-expression (parse-stuff stuff ...))
|
||||
#'rest
|
||||
#f)])))
|
||||
|
||||
;; combine syntax objects
|
||||
;; #'(a b) + #'(c d) = #'(a b c d)
|
||||
|
@ -406,7 +370,7 @@
|
|||
(begin-for-syntax
|
||||
(define-syntax (generate-pattern stx)
|
||||
(syntax-parse stx
|
||||
[(_ name literals original-pattern maybe-out)
|
||||
[(_ name literals (pattern-stx out-stx) ...)
|
||||
|
||||
(define (make-syntax-class-pattern honu-pattern maybe-out)
|
||||
(define variables (find-pattern-variables honu-pattern))
|
||||
|
@ -428,19 +392,23 @@
|
|||
[((withs ...) ...) (set->list withs)]
|
||||
[(result-with ...) (if (syntax-e maybe-out)
|
||||
(with-syntax ([(out ...) maybe-out])
|
||||
#'(#:with result (out ...)))
|
||||
#'(#:with result (parse-stuff honu-syntax (#%parens out ...))))
|
||||
#'(#:with result #'()))])
|
||||
#'[pattern (~seq new-pattern ...)
|
||||
withs ... ...
|
||||
result-with ...
|
||||
]))
|
||||
|
||||
(define pattern-stuff (make-syntax-class-pattern #'original-pattern #'maybe-out))
|
||||
(define pattern-stuff
|
||||
(for/list ([pattern (syntax->list #'(pattern-stx ...))]
|
||||
[out (syntax->list #'(out-stx ...))])
|
||||
(printf "Pattern ~a\n" pattern)
|
||||
(make-syntax-class-pattern pattern out)))
|
||||
|
||||
#;
|
||||
(debug "With bindings ~a\n" withs)
|
||||
(with-syntax ([(literal ...) #'literals]
|
||||
[(new-pattern ...) (list pattern-stuff)])
|
||||
[(new-pattern ...) pattern-stuff])
|
||||
#;
|
||||
(debug "Result with ~a\n" (syntax->datum #'(quote-syntax (result-with ...))))
|
||||
(define output
|
||||
|
@ -468,21 +436,23 @@
|
|||
(lambda (code)
|
||||
(syntax-parse code #:literal-sets (cruft)
|
||||
[(_ name (#%parens literal ...)
|
||||
(#%braces pattern ...)
|
||||
(~optional (#%braces out ...))
|
||||
(~seq (#%braces original-pattern ...)
|
||||
(~optional (~seq honu-comma maybe-out)
|
||||
#:defaults ([maybe-out #'#f])))
|
||||
...
|
||||
. rest)
|
||||
(values (with-syntax ([out* (attribute out)])
|
||||
(phase1:racket-syntax
|
||||
(splicing-let-syntax
|
||||
([make (lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ new-name)
|
||||
(syntax-local-introduce
|
||||
(generate-pattern name
|
||||
(literal ...)
|
||||
(pattern ...)
|
||||
out*))]))])
|
||||
(make name))))
|
||||
(values
|
||||
(phase1:racket-syntax
|
||||
(splicing-let-syntax
|
||||
([make (lambda (stx)
|
||||
(syntax-parse stx
|
||||
[(_ new-name)
|
||||
(syntax-local-introduce
|
||||
(generate-pattern name
|
||||
(literal ...)
|
||||
((original-pattern ...) maybe-out)
|
||||
...))]))])
|
||||
(make name)))
|
||||
#'rest
|
||||
#f)])))
|
||||
|
||||
|
|
|
@ -22,3 +22,47 @@
|
|||
[rhs rhs])
|
||||
(syntax/loc stx
|
||||
(define-syntax id (make-honu-transformer rhs))))))
|
||||
|
||||
;; Do any honu-specific expansion here
|
||||
(require (for-syntax
|
||||
"template.rkt" ;; for compress-dollars at phase 1
|
||||
"compile.rkt"
|
||||
"literals.rkt"
|
||||
syntax/stx
|
||||
syntax/parse)
|
||||
"template.rkt") ;; for remove-repeats at phase 0
|
||||
(define-honu-syntax honu-syntax
|
||||
(lambda (code)
|
||||
(syntax-parse code #:literal-sets (cruft)
|
||||
#;
|
||||
[(_ (#%parens single) . rest)
|
||||
(define context #'single)
|
||||
(define compressed (compress-dollars #'single))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context compressed context context)])
|
||||
(phase1:racket-syntax #'stuff*))
|
||||
#'rest
|
||||
#f)]
|
||||
[(_ (#%parens stuff ...) . rest)
|
||||
(define context (stx-car #'(stuff ...)))
|
||||
(define compressed (compress-dollars #'(stuff ...)))
|
||||
(values
|
||||
(with-syntax ([stuff* (datum->syntax context
|
||||
(syntax->list compressed)
|
||||
context context)])
|
||||
;; (debug "Stuff is ~a\n" (syntax->datum #'stuff*))
|
||||
;; (debug "Stuff syntaxed is ~a\n" (syntax->datum #'#'stuff*))
|
||||
|
||||
;; stuff* will be expanded when this syntax is returned because
|
||||
;; the whole thing will be
|
||||
;; (remove-repeats #'((repeat$ 1) (repeat$ 2)))
|
||||
;; so remove-repeats will be executed later
|
||||
(racket-syntax
|
||||
(remove-repeats #'stuff*))
|
||||
|
||||
#;
|
||||
(with-syntax ([(out ...) #'stuff*])
|
||||
(phase1:racket-syntax #'stuff*)))
|
||||
#; #'(%racket-expression (parse-stuff stuff ...))
|
||||
#'rest
|
||||
#f)])))
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
var => = 0
|
||||
|
||||
pattern match_pattern (){ [element:expression_list]} { [ $ element_each_result , $ ...]}
|
||||
pattern match_pattern (){ [element:expression_list]}, { [ $ element_each_result , $ ...]}
|
||||
|
||||
pattern match_clause (| =>){ | pattern:match_pattern => out:expression , }
|
||||
|
||||
|
|
Loading…
Reference in New Issue
Block a user