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

supporting mutually recursive data structures

Browse Source
This commit is contained in:
Jay McCarthy 2015-12-04 09:38:23 -05:00
parent cd1ed0d586
commit 66b8a427c6
3 changed files with 71 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
remix/data0.rkt
View File

@ -106,18 +106,19 @@
(syntax-parse stx (syntax-parse stx
[(_dot me:id x:interface-member) [(_dot me:id x:interface-member)
(get-rhs-id stx #'x)] (get-rhs-id stx #'x)]
[(_dot me:id x:interface-member . more:expr) [(_dot me:id . (~and x+more (x:interface-member . more)))
(quasisyntax/loc stx (quasisyntax/loc stx
(remix:block (remix:block
#,(get-rhs-def stx #'x) #,(get-rhs-def stx #'x)
(remix:#%dot x . more)))]))] #,(syntax/loc #'x+more
(remix:#%dot x . more))))]))]
#:methods remix:gen:app-dot-transformer #:methods remix:gen:app-dot-transformer
[(define (app-dot-transform _ stx) [(define (app-dot-transform _ stx)
(syntax-parse stx (syntax-parse stx
[(_app (_dot me:id x:interface-member) . body:expr) [(_app (_dot me:id x:interface-member) . body)
(quasisyntax/loc stx (quasisyntax/loc stx
(#,(get-rhs-id stx #'x) . body))] (#,(get-rhs-id stx #'x) . body))]
[(_app (_dot me:id x:interface-member . more:expr) . body:expr) [(_app (_dot me:id x:interface-member . more) . body)
(quasisyntax/loc stx (quasisyntax/loc stx
(remix:block (remix:block
#,(get-rhs-def stx #'x) #,(get-rhs-def stx #'x)
@ -126,7 +127,7 @@
[(define (def-transform _ stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
[(def (remix:#%brackets me:id i:id) . body:expr) [(def (remix:#%brackets me:id i:id) . body)
(with-syntax ([real-i (generate-temporary #'i)]) (with-syntax ([real-i (generate-temporary #'i)])
(syntax/loc stx (syntax/loc stx
(begin (begin
@ -137,7 +138,7 @@
[_:id [_:id
(syntax/loc stx (syntax/loc stx
(rhs real-i))] (rhs real-i))]
[(_ . blah:expr) [(_ . blah)
(syntax/loc stx (syntax/loc stx
(rhs real-i . blah))]))) (rhs real-i . blah))])))
... ...
@ -157,7 +158,7 @@
[_:id [_:id
(syntax/loc stx (syntax/loc stx
real-i)] real-i)]
[(_ . blah:expr) [(_ . blah)
(syntax/loc stx (syntax/loc stx
(real-i . blah))])))))))]))] (real-i . blah))])))))))]))]
extension ...))))]))) extension ...))))])))
@ -177,7 +178,7 @@
[(define (def-transform _ stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
[(def (remix:#%brackets me:id i:id) . body:expr) [(def (remix:#%brackets me:id i:id) . body)
(syntax/loc stx (syntax/loc stx
(remix:def (remix:#%brackets remix:stx i) (remix:def (remix:#%brackets remix:stx i)
(phase1:base . body)))]))]))))])) (phase1:base . body)))]))]))))]))
@ -204,8 +205,12 @@
#:literals (remix:#%brackets) #:literals (remix:#%brackets)
(pattern name:id (pattern name:id
#:attr dt #f) #:attr dt #f)
(pattern (remix:#%brackets dt name:id) (pattern (remix:#%brackets dt:id name:id)
#:declare dt (static remix:def-transformer? "def transformer")))) ;; XXX This can't be here because it disallows mutual
;; recursion... move the check somewhere else?
;; #:declare dt (static remix:def-transformer? "def transformer")
)))
(define-syntax layout-immutable (define-syntax layout-immutable
(singleton-struct (singleton-struct
@ -384,6 +389,7 @@
(rep-mutate base-id f-idx f-val-id) (rep-mutate base-id f-idx f-val-id)
(... ...) (... ...)
(void)))))])) (void)))))]))
;; xxx add per-field mutators with a set! macro
(begin-encourage-inline (begin-encourage-inline
(define (all-name-f v) (rep-accessor v all-f-idx)) (define (all-name-f v) (rep-accessor v all-f-idx))
...) ...)

66
remix/stx0.rkt
View File

@ -23,14 +23,14 @@
;; composable. ;; composable.
(def-transform (attribute dt.value) stx)] (def-transform (attribute dt.value) stx)]
;; xxx test this ;; xxx test this
[(_ dt . body:expr) [(_ dt . body)
#:declare dt (static def-transformer? "def transformer") #:declare dt (static def-transformer? "def transformer")
(syntax/loc stx (syntax/loc stx
(def (#%brackets dt) . body))] (def (#%brackets dt) . body))]
[(_ x:id . body:expr) [(_ x:id . body)
(syntax/loc stx (syntax/loc stx
(define x (remix-block . body)))] (define x (remix-block . body)))]
[(_ ((~and (~not #%brackets) x) . args:expr) . body:expr) [(_ ((~and (~not #%brackets) x) . args) . body)
(syntax/loc stx (syntax/loc stx
(def x (remix-λ args . body)))])) (def x (remix-λ args . body)))]))
@ -53,28 +53,28 @@
#:declare dt (static def*-transformer? "def* transformer") #:declare dt (static def*-transformer? "def* transformer")
(def*-transform (attribute dt.value) stx)] (def*-transform (attribute dt.value) stx)]
;; xxx test this ;; xxx test this
[(_ (dt . def-body:expr) bind-body:expr) [(_ (dt . def-body) bind-body)
#:declare dt (static def*-transformer? "def* transformer") #:declare dt (static def*-transformer? "def* transformer")
(syntax/loc stx (syntax/loc stx
(def*-internal ((#%brackets dt) . def-body) bind-body))] (def*-internal ((#%brackets dt) . def-body) bind-body))]
[(_ ((~and (~not #%brackets) x:id) . def-body:expr) bind-body:expr) [(_ ((~and (~not #%brackets) x:id) . def-body) bind-body)
(syntax/loc stx (syntax/loc stx
(let ([x (remix-block . def-body)]) (let ([x (remix-block . def-body)])
(remix-block . bind-body)))] (remix-block . bind-body)))]
[(_ (((~and (~not #%brackets) x) . args:expr) . def-body:expr) bind-body:expr) [(_ (((~and (~not #%brackets) x) . args) . def-body) bind-body)
(syntax/loc stx (syntax/loc stx
(def*-internal (x (remix-λ args . def-body)) bind-body))])) (def*-internal (x (remix-λ args . def-body)) bind-body))]))
(define-syntax (remix-block stx) (define-syntax (remix-block stx)
(syntax-parse stx (syntax-parse stx
#:literals (def*) #:literals (def*)
[(_ (~and (~not (def* . _)) before:expr) ... [(_ (~and (~not (def* . _)) before) ...
(def* . def*-body:expr) . after:expr) (def* . def*-body) . after)
(syntax/loc stx (syntax/loc stx
(let () (let ()
before ... before ...
(def*-internal def*-body after)))] (def*-internal def*-body after)))]
[(_ . body:expr) [(_ . body)
(syntax/loc stx (syntax/loc stx
(let () . body))])) (let () . body))]))
@ -118,11 +118,11 @@
[(cons token input) [(cons token input)
(syntax-parse token (syntax-parse token
#:literals (unquote) #:literals (unquote)
[(~or (unquote (~and op1:expr (~not _:operator-sym))) op1:operator-sym) [(~or (unquote (~and op1 (~not _:operator-sym))) op1:operator-sym)
(define-values (output-p operators-p) (define-values (output-p operators-p)
(shunting-yard:push-operator output operators #'op1)) (shunting-yard:push-operator output operators #'op1))
(shunting-yard:consume-input input output-p operators-p)] (shunting-yard:consume-input input output-p operators-p)]
[(~or (unquote arg:operator-sym) arg:expr) [(~or (unquote arg:operator-sym) arg)
(shunting-yard:consume-input input (cons #'arg output) operators)])])) (shunting-yard:consume-input input (cons #'arg output) operators)])]))
(define (shunting-yard:push-operator output operators op1) (define (shunting-yard:push-operator output operators op1)
(match operators (match operators
@ -150,14 +150,14 @@
operators)])) operators)]))
(define (shunting-yard:push-operator-to-output op output) (define (shunting-yard:push-operator-to-output op output)
(syntax-parse output (syntax-parse output
[(arg2:expr arg1:expr output:expr ...) [(arg2 arg1 output ...)
(cons (quasisyntax/loc op (cons (quasisyntax/loc op
(#,op arg1 arg2)) (#,op arg1 arg2))
(syntax->list (syntax->list
#'(output ...)))]))) #'(output ...)))])))
(define-syntax (#%braces stx) (define-syntax (#%braces stx)
(syntax-parse stx (syntax-parse stx
[(_ input-tokens:expr ...) [(_ input-tokens ...)
(shunting-yard:consume-input (shunting-yard:consume-input
(syntax->list #'(input-tokens ...)) (syntax->list #'(input-tokens ...))
empty empty
@ -169,11 +169,13 @@
(define-syntax (#%dot stx) (define-syntax (#%dot stx)
(syntax-parse stx (syntax-parse stx
#:literals (#%dot) #:literals (#%dot)
[(_ dt x:expr ... (#%dot y:expr ...)) [(_ dt . (~and x+y (x ... (#%dot . y))))
#:declare dt (static dot-transformer? "dot transformer") #:declare dt (static dot-transformer? "dot transformer")
(syntax/loc stx (quasisyntax/loc stx
(#%dot dt x ... y ...))] (#%dot dt
[(_ dt . _) #,@(syntax/loc #'x+y
(x ... . y))))]
[(_ dt . (~not (x ... (#%dot . _) . _)))
#:declare dt (static dot-transformer? "dot transformer") #:declare dt (static dot-transformer? "dot transformer")
(dot-transform (attribute dt.value) stx)])) (dot-transform (attribute dt.value) stx)]))
@ -183,13 +185,13 @@
(define-syntax (remix-#%app stx) (define-syntax (remix-#%app stx)
(syntax-parse stx (syntax-parse stx
#:literals (#%dot) #:literals (#%dot)
[(_ (~and dot-rator (#%dot x:expr ... (#%dot y:expr ...))) . body:expr) [(_ (#%dot x ... (#%dot y ...)) . body)
(syntax/loc stx (syntax/loc stx
(remix-#%app (#%dot x ... y ...) . body))] (remix-#%app (#%dot x ... y ...) . body))]
[(_ (~and dot-rator (#%dot adt . _)) . body:expr) [(_ (#%dot adt . (~not (x ... (#%dot . _) . _))) . body)
#:declare adt (static app-dot-transformer? "app-dot transformer") #:declare adt (static app-dot-transformer? "app-dot transformer")
(app-dot-transform (attribute adt.value) stx)] (app-dot-transform (attribute adt.value) stx)]
[(_ . body:expr) [(_ . body)
(syntax/loc stx (syntax/loc stx
(#%app . body))])) (#%app . body))]))
@ -264,16 +266,16 @@
#:property prop:procedure #:property prop:procedure
(λ (_ stx) (λ (_ stx)
(syntax-parse stx (syntax-parse stx
[(_ args:remix-λ-args . body:expr) [(_ args:remix-λ-args . body)
(syntax/loc stx (syntax/loc stx
(λ args.λ-args (remix-block args.λ-binds ... (remix-block . body))))])) (λ args.λ-args (remix-block args.λ-binds ... (remix-block . body))))]))
#:methods gen:dot-transformer #:methods gen:dot-transformer
[(define (dot-transform _ stx) [(define (dot-transform _ stx)
(syntax-parse stx (syntax-parse stx
[(_#%dot _λ body:expr) [(_#%dot _λ body)
(syntax/loc stx (syntax/loc stx
(remix-cut body))] (remix-cut body))]
[(_#%dot _λ bodies:expr ...) [(_#%dot _λ bodies ...)
(syntax/loc stx (syntax/loc stx
(remix-cut (#%dot bodies ...)))]))]) (remix-cut (#%dot bodies ...)))]))])
@ -282,7 +284,7 @@
(raise-syntax-error '$ "illegal outside cut" stx))) (raise-syntax-error '$ "illegal outside cut" stx)))
(define-syntax (remix-cut stx) (define-syntax (remix-cut stx)
(syntax-parse stx (syntax-parse stx
[(_ body:expr) [(_ body)
(syntax/loc stx (syntax/loc stx
(remix-λ (x) (remix-λ (x)
(syntax-parameterize ([remix-cut-$ (make-rename-transformer #'x)]) (syntax-parameterize ([remix-cut-$ (make-rename-transformer #'x)])
@ -310,13 +312,13 @@
#:else (impossible! 'cond #:else (impossible! 'cond
"non-existent default case reached" "non-existent default case reached"
#,stx))))] #,stx))))]
[(_ (~and before:expr (~not (#%brackets . any:expr))) ... [(_ (~and before (~not (#%brackets . _))) ...
(#%brackets #:else . answer-body:expr)) (#%brackets #:else . answer-body))
(syntax/loc stx (syntax/loc stx
(remix-block before ... . answer-body))] (remix-block before ... . answer-body))]
[(_ (~and before:expr (~not (#%brackets . any:expr))) ... [(_ (~and before (~not (#%brackets . _))) ...
(#%brackets question:expr . answer-body:expr) (#%brackets question . answer-body)
. more:expr) . more)
(quasisyntax/loc stx (quasisyntax/loc stx
(remix-block before ... (remix-block before ...
(if question (if question
@ -370,7 +372,7 @@
[(define (def-transform _ stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
#:literals (#%brackets) #:literals (#%brackets)
[(_def (#%brackets _stx x:id) . body:expr) [(_def (#%brackets _stx x:id) . body)
(syntax/loc stx (syntax/loc stx
(define x (remix-block . body)))]))])) (define x (remix-block . body)))]))]))
@ -383,7 +385,7 @@
[(define (def-transform _ stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
#:literals (#%brackets) #:literals (#%brackets)
[(_def (#%brackets _stx x:id) . body:expr) [(_def (#%brackets _stx x:id) . body)
(syntax/loc stx (syntax/loc stx
(define-syntax x (remix-block . body)))]))])) (define-syntax x (remix-block . body)))]))]))
@ -396,7 +398,7 @@
[(define (def-transform _ stx) [(define (def-transform _ stx)
(syntax-parse stx (syntax-parse stx
#:literals (#%brackets) #:literals (#%brackets)
[(_def (#%brackets _mac (x:id . pat:expr)) . body:expr) [(_def (#%brackets _mac (x:id . pat)) . body)
(syntax/loc stx (syntax/loc stx
(define-simple-macro (x . pat) . body))]))])) (define-simple-macro (x . pat) . body))]))]))

21
remix/tests/simple.rkt
View File

@ -437,3 +437,24 @@
(w1.#:! [c1 w1.c2] [c2 w1.c1]) (w1.#:! [c1 w1.c2] [c2 w1.c1])
{w1.c1.r ≡ 8} {w1.c1.r ≡ 8}
{w1.c2.r ≡ 3}) {w1.c2.r ≡ 3})
;; These support mutual recursion
(def [layout even]
#:rep layout-mutable
e [odd o])
(def [layout odd]
#:rep layout-mutable
[even e] o)
(module+ test
(def [even even1]
(even.#:alloc
[e 0]
[o (odd.#:alloc
[e #f]
[o 1])]))
(even1.o.#:set! [e even1])
{even1.e ≡ 0}
{even1.o.o ≡ 1}
{even1.o.e.e ≡ 0}
{even1.o.e.o.o ≡ 1}
{even1.o.e.o.e.e ≡ 0})