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
[(_dot me:id x:interface-member)
(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
(remix:block
#,(get-rhs-def stx #'x)
(remix:#%dot x . more)))]))]
#,(syntax/loc #'x+more
(remix:#%dot x . more))))]))]
#:methods remix:gen:app-dot-transformer
[(define (app-dot-transform _ stx)
(syntax-parse stx
[(_app (_dot me:id x:interface-member) . body:expr)
[(_app (_dot me:id x:interface-member) . body)
(quasisyntax/loc stx
(#,(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
(remix:block
#,(get-rhs-def stx #'x)
@ -126,7 +127,7 @@
[(define (def-transform _ stx)
(syntax-parse stx
#: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)])
(syntax/loc stx
(begin
@ -137,7 +138,7 @@
[_:id
(syntax/loc stx
(rhs real-i))]
[(_ . blah:expr)
[(_ . blah)
(syntax/loc stx
(rhs real-i . blah))])))
...
@ -157,7 +158,7 @@
[_:id
(syntax/loc stx
real-i)]
[(_ . blah:expr)
[(_ . blah)
(syntax/loc stx
(real-i . blah))])))))))]))]
extension ...))))])))
@ -177,7 +178,7 @@
[(define (def-transform _ stx)
(syntax-parse stx
#:literals (remix:#%brackets)
[(def (remix:#%brackets me:id i:id) . body:expr)
[(def (remix:#%brackets me:id i:id) . body)
(syntax/loc stx
(remix:def (remix:#%brackets remix:stx i)
(phase1:base . body)))]))]))))]))
@ -204,8 +205,12 @@
#:literals (remix:#%brackets)
(pattern name:id
#:attr dt #f)
(pattern (remix:#%brackets dt name:id)
#:declare dt (static remix:def-transformer? "def transformer"))))
(pattern (remix:#%brackets dt:id name:id)
;; 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
(singleton-struct
@ -384,6 +389,7 @@
(rep-mutate base-id f-idx f-val-id)
(... ...)
(void)))))]))
;; xxx add per-field mutators with a set! macro
(begin-encourage-inline
(define (all-name-f v) (rep-accessor v all-f-idx))
...)

66
remix/stx0.rkt
View File

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