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

redex, macro-debugger: stxclass -> syntax/parse, syntax/private/util

Browse Source 
svn: r15986
This commit is contained in:
Ryan Culpepper 2009-09-11 23:16:22 +00:00
parent 30c0dcf045
commit 9ca3192a60
5 changed files with 41 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/macro-debugger/model/reductions-engine.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax stxclass)
(for-syntax syntax/parse)
scheme/list
scheme/contract
"deriv.ss"
@ -12,7 +12,10 @@
(provide (all-from-out "steps.ss")
(all-from-out "reductions-config.ss")
DEBUG
R)
R
!)
(define-syntax ! (syntax-rules ()))
(define-syntax-rule (with-syntax1 ([pattern rhs]) . body)
(syntax-case rhs ()
@ -22,9 +25,6 @@
'pattern)
#'x)]))
(begin-for-syntax
(expr/c-use-contracts? #f))
(define-syntax-rule (DEBUG form ...)
(when #f
form ... (void)))

13
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -19,12 +19,13 @@
(lambda (stx)
(syntax-case stx ()
[(_ name ...)
(apply append
(for/list ([name (syntax->list #'(name ...))])
(list ;; (join "init-" #'name)
(join "get-" name)
(join "set-" name)
(join "listen-" name))))])))
(datum->syntax #f
(apply append
(for/list ([name (syntax->list #'(name ...))])
(list ;; (join "init-" #'name)
(join "get-" name)
(join "set-" name)
(join "listen-" name)))))])))
;; Interfaces

34
collects/macro-debugger/util/class-ct.ss
View File

@ -1,7 +1,8 @@
#lang scheme/base
(require (for-template scheme/base
scheme/class)
stxclass)
syntax/parse
syntax/stx)
(provide static-interface?
make-static-interface
@ -77,27 +78,28 @@
(define-syntax-class static-interface
(pattern x
#:declare x (static-of 'static-interface static-interface?)
#:with value #'x.value))
#:declare x (static static-interface? 'static-interface)
#:attr value (attribute x.value)))
(define-syntax-class checked-binding
(pattern x
#:declare x (static-of 'checked-binding checked-binding?)
#:with value #'x.value))
#:declare x (static checked-binding? 'checked-binding)
#:attr value (attribute x.value)))
(define-syntax-class interface-expander
(pattern x
#:declare x (static-of 'interface-expander interface-expander?)
#:with value #'x.value))
#:declare x (static interface-expander? 'interface-expander)
#:attr value (attribute x.value)))
(define-syntax-class method-entry
(pattern method:id
#:with methods (list #'method))
(pattern m:id
#:with (method ...) #'(m))
(pattern (macro:interface-expander . args)
#:with methods
(apply append
(for/list ([m ((interface-expander-proc #'macro.value)
#'(macro . args))])
(syntax-parse m
[m:method-entry #'m.methods])))))
#:with (method ...)
(with-syntax ([((m ...) ...)
(for/list ([m (stx->list
((interface-expander-proc (attribute macro.value))
#'(macro . args)))])
(syntax-parse m
[m:method-entry #'(m.method ...)]))])
#'(m ... ...))))

22
collects/macro-debugger/util/class-iop.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scheme/class
(for-syntax scheme/base
stxclass
syntax/parse
"class-ct.ss"))
(provide define-interface
define-interface/dynamic
@ -29,12 +29,10 @@
(syntax-parse stx
[(_ name:id (super:static-interface ...) (m:method-entry ...))
(with-syntax ([((super-method ...) ...)
(map static-interface-members
(syntax->datum #'(super.value ...)))]
[((mname ...) ...) #'(m.methods ...)])
(map static-interface-members (attribute super.value))])
#'(define-interface/dynamic name
(let ([name (interface (super ...) mname ... ...)]) name)
(super-method ... ... mname ... ...)))]))
(let ([name (interface (super ...) m.method ... ...)]) name)
(super-method ... ... m.method ... ...)))]))
;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -75,7 +73,7 @@
(define-syntax (send: stx)
(syntax-parse stx
[(send: obj:expr iface:static-interface method:id . args)
(begin (check-method-in-interface 'send: #'method #'iface.value)
(begin (check-method-in-interface 'send: #'method (attribute iface.value))
(syntax/loc stx
(send (check-object<:interface send: obj iface)
method . args)))]))
@ -84,7 +82,7 @@
(syntax-parse stx
[(send*: obj:expr iface:static-interface (method:id . args) ...)
(begin (for ([method (syntax->list #'(method ...))])
(check-method-in-interface 'send*: method #'iface.value))
(check-method-in-interface 'send*: method (attribute iface.value)))
(syntax/loc stx
(send* (check-object<:interface send*: obj iface)
(method . args) ...)))]))
@ -92,7 +90,7 @@
(define-syntax (send/apply: stx)
(syntax-parse stx
[(send/apply: obj:expr iface:static-interface method:id . args)
(begin (check-method-in-interface 'send/apply: #'method #'iface.value)
(begin (check-method-in-interface 'send/apply: #'method (attribute iface.value))
(syntax/loc stx
(send/apply (check-object<:interface send/apply obj iface)
method . args)))]))
@ -103,7 +101,7 @@
(define-syntax (check-object<:interface stx)
(syntax-parse stx
[(_ for-whom obj:checked-binding iface:static-interface)
(if (eq? (checked-binding-iface #'obj.value) #'iface.value)
(if (eq? (checked-binding-iface (attribute obj.value)) (attribute iface.value))
#'obj
(syntax/loc stx
(check-object<:interface for-whom
@ -127,7 +125,7 @@
(define-syntax (define: stx)
(syntax-parse stx
[(_ name:id iface:static-interface expr)
(let ([si #'iface.value])
(let ([si (attribute iface.value)])
(with-syntax ([(name-internal) (generate-temporaries #'(name))]
[(method ...) (static-interface-members si)]
[(name.method ...)
@ -156,7 +154,7 @@
;; FIXME: rewrite as stxclass
(define (arg->define stx temp)
(syntax-case stx ()
[(arg : iface)
[(arg : iface)
(and (identifier? #'arg)
(eq? ': (syntax-e #':)))
#`(define: arg iface #,temp)]

2
collects/redex/private/term.ss
View File

@ -2,7 +2,7 @@
(require (for-syntax scheme/base
"term-fn.ss"
stxclass/util/misc)
syntax/private/util/misc)
"matcher.ss")
(provide term term-let term-let/error-name term-let-fn term-define-fn)