diff --git a/collects/honu/core/private/class.rkt b/collects/honu/core/private/class.rkt index 89eba7952b..b5bec6f767 100644 --- a/collects/honu/core/private/class.rkt +++ b/collects/honu/core/private/class.rkt @@ -6,6 +6,7 @@ (for-syntax racket/base "literals.rkt" "parse2.rkt" + "util.rkt" syntax/parse) racket/class) @@ -17,7 +18,7 @@ (define-splicing-syntax-class honu-class-thing #:literals (honu-equal) [pattern method:honu-function - #:with result (replace-with-public #'method.result)] + #:with result (replace-with-public (local-binding method.result))] [pattern var:honu-declaration #:with result #'(field [var.name var.expression] ...)])) @@ -25,14 +26,14 @@ (define-honu-syntax honu-class (lambda (code context) (syntax-parse code #:literal-sets (cruft) - [(_ name (#%parens (~var constructor-argument (separate-ids #'honu-comma #'dont-care))) + [(_ name (#%parens (~var constructor-argument (separate-ids (literal-syntax-class honu-comma) (literal-syntax-class honu-comma)))) (#%braces method:honu-class-thing ...) . rest) (define class #'(%racket (define name (class* object% () (super-new) (init-field constructor-argument.id ...) method.result ...)))) - (values class #'rest #t)]))) + (values class (local-binding rest) #t)]))) (provide honu-new) (define-honu-syntax honu-new @@ -42,5 +43,5 @@ (define new #'(%racket (make-object name arg.result ...))) (values new - #'rest + (local-binding rest) #f)]))) diff --git a/collects/honu/core/private/honu2.rkt b/collects/honu/core/private/honu2.rkt index 1d441e8bb7..294f1b6217 100644 --- a/collects/honu/core/private/honu2.rkt +++ b/collects/honu/core/private/honu2.rkt @@ -16,7 +16,9 @@ define-literal %racket) (for-syntax syntax/parse + syntax/parse/experimental/reflect racket/syntax + "util.rkt" "debug.rkt" "literals.rkt" "parse2.rkt" @@ -261,16 +263,16 @@ (begin-for-syntax (define-splicing-syntax-class (id-must-be what) - [pattern x:id #:when (free-identifier=? #'x what)]) - (define-splicing-syntax-class (id-except ignores) - [pattern x:id #:when (not (for/fold ([ok #f]) - ([ignore ignores]) - (or ok (free-identifier=? #'x ignore))))]) + [pattern (~reflect x (what))]) + (define-syntax-class (id-except ignore1 ignore2) + [pattern (~and x:id (~not (~or (~reflect x1 (ignore1)) + (~reflect x2 (ignore2)))))]) + (provide separate-ids) (define-splicing-syntax-class (separate-ids separator end) - [pattern (~seq (~var first (id-except (list separator end))) + [pattern (~seq (~var first (id-except separator end)) (~seq (~var between (id-must-be separator)) - (~var next (id-except (list separator end)))) ...) + (~var next (id-except separator end))) ...) #:with (id ...) #'(first.x next.x ...)])) (begin-for-syntax @@ -278,7 +280,8 @@ (define-literal-set declaration-literals (honu-comma honu-equal)) (define-splicing-syntax-class var-id - [pattern x:id #:when (not ((literal-set->predicate declaration-literals) #'x))]) + [pattern (~var x (id-except (literal-syntax-class honu-comma) + (literal-syntax-class honu-equal)))]) ;; parses a declaration ;; var x = 9 @@ -286,7 +289,8 @@ (define-splicing-syntax-class honu-declaration #:literal-sets (cruft) #:literals (honu-equal honu-var) - [pattern (~seq honu-var (~var variables (separate-ids #'honu-comma #'honu-equal)) + [pattern (~seq honu-var (~var variables (separate-ids (literal-syntax-class honu-comma) + (literal-syntax-class honu-equal))) honu-equal one:honu-expression) #:with (name ...) #'(variables.id ...) #:with expression #'one.result])) diff --git a/collects/honu/core/private/util.rkt b/collects/honu/core/private/util.rkt index c26b441106..b75c854638 100644 --- a/collects/honu/core/private/util.rkt +++ b/collects/honu/core/private/util.rkt @@ -3,7 +3,12 @@ (provide (except-out (all-defined-out) test-delimiter)) (require "debug.rkt" racket/match - (for-syntax racket/base) + syntax/parse + syntax/parse/experimental/reflect + (for-syntax racket/base + syntax/parse + "debug.rkt" + ) syntax/stx racket/list) @@ -94,3 +99,32 @@ [match-variable (extract-variable #'pattern)]) #'(match expression [match-pattern match-variable]))])) + +;; local-binding and module-binding check that the identifier is bound at the given phase +(define-syntax (local-binding stx) + (syntax-parse stx + [(_ name) + (define type (identifier-binding #'name)) + (when (not (eq? type 'lexical)) + (raise-syntax-error 'local-binding "not bound locally" #'name)) + #'#'name])) + +(define-syntax (module-binding stx) + (syntax-parse stx + [(_ name level) + (define type (identifier-binding #'name (syntax-e #'level))) + (when (not (and (list? type) + (= (length type) 7))) + (raise-syntax-error 'module-binding + (format "not bound by a module at phase ~a" (syntax-e #'level)) + #'name)) + #'#'name])) + +(define-syntax-rule (literal-syntax-class literal) + (let () + (define-literal-set set (literal)) + (define-syntax-class class + #:literal-sets (set) + ;; BUG! shouldn't need ~literal here since we are using literal sets + [pattern (~literal literal)]) + (reify-syntax-class class)))