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

[honu] use reified syntax classes to check for literals instead of direct comparisons with free-identifier=?

Browse Source
This commit is contained in:
Jon Rafkind 2011-11-15 17:16:59 -07:00
parent 3bffcae3c2
commit a38949d8ba
3 changed files with 53 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/honu/core/private/class.rkt
View File

@ -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)])))

22
collects/honu/core/private/honu2.rkt
View File

@ -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]))

36
collects/honu/core/private/util.rkt
View File

@ -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)))