syndicate-lang
/
syndicate-rkt
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Various missing con/destructors

This commit is contained in:
Tony Garnock-Jones 2021-06-09 14:53:08 +02:00
parent eb3aa40541
commit d0fb1cfa99
2 changed files with 13 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
syndicate/distributed/tcp-server.rkt
View File

@ -67,7 +67,7 @@
(during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target) (during (Bind (SturdyRef-oid unvalidated-sturdyref) $key $target)
(define sturdyref (validate unvalidated-sturdyref key)) (define sturdyref (validate unvalidated-sturdyref key))
(define attenuation (define attenuation
(append-map values (reverse (SturdyRef-caveatChain sturdyref)))) (append-map Attenuation-value (reverse (SturdyRef-caveatChain sturdyref))))
(define attenuated-target (define attenuated-target
(apply attenuate-entity-ref target attenuation)) (apply attenuate-entity-ref target attenuation))
(at observer (assert (embedded attenuated-target)))))])))))))) (at observer (assert (embedded attenuated-target)))))]))))))))

18
syndicate/rewrite.rkt
View File

@ -33,19 +33,22 @@
(set! bindings saved) (set! bindings saved)
(not result)))] (not result)))]
[(Pattern-Lit (Lit expected)) (preserve=? expected v)] [(Pattern-Lit (Lit expected)) (preserve=? expected v)]
[(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity)) members)) [(Pattern-PCompound (PCompound (ConstructorSpec-CRec (CRec label arity))
(PCompoundMembers members)))
(match v (match v
[(record (== label preserve=?) fields) [(record (== label preserve=?) fields)
(and (= (length fields) arity) (and (= (length fields) arity)
(for/and [((key pp) (in-hash members))] (for/and [((key pp) (in-hash members))]
(and (exact-integer? key) (walk pp (list-ref fields key)))))] (and (exact-integer? key) (walk pp (list-ref fields key)))))]
[_ #f])] [_ #f])]
[(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity)) members)) [(Pattern-PCompound (PCompound (ConstructorSpec-CArr (CArr arity))
(PCompoundMembers members)))
(and (list? v) (and (list? v)
(= (length v) arity) (= (length v) arity)
(for/and [((key pp) (in-hash members))] (for/and [((key pp) (in-hash members))]
(and (exact-integer? key) (walk pp (list-ref v key)))))] (and (exact-integer? key) (walk pp (list-ref v key)))))]
[(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict)) members)) [(Pattern-PCompound (PCompound (ConstructorSpec-CDict (CDict))
(PCompoundMembers members)))
(and (dict? v) (and (dict? v)
(for/and [((key pp) (in-hash members))] (for/and [((key pp) (in-hash members))]
(define vv (hash-ref v key (void))) (define vv (hash-ref v key (void)))
@ -59,16 +62,19 @@
[(Template-TRef (TRef name)) [(Template-TRef (TRef name))
(hash-ref bindings name (lambda () (error 'instantiate-Template "Missing binding: ~v" name)))] (hash-ref bindings name (lambda () (error 'instantiate-Template "Missing binding: ~v" name)))]
[(Template-Lit (Lit v)) v] [(Template-Lit (Lit v)) v]
[(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity)) members)) [(Template-TCompound (TCompound (ConstructorSpec-CRec (CRec label arity))
(TCompoundMembers members)))
(record label (record label
(for/list [(i (in-range 0 arity))] (for/list [(i (in-range 0 arity))]
(walk (hash-ref members i (lambda () (error 'instantiate-Template (walk (hash-ref members i (lambda () (error 'instantiate-Template
"Missing record field key ~v" i))))))] "Missing record field key ~v" i))))))]
[(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity)) members)) [(Template-TCompound (TCompound (ConstructorSpec-CArr (CArr arity))
(TCompoundMembers members)))
(for/list [(i (in-range 0 arity))] (for/list [(i (in-range 0 arity))]
(walk (hash-ref members i (lambda () (error 'instantiate-Template (walk (hash-ref members i (lambda () (error 'instantiate-Template
"Missing array key ~v" i)))))] "Missing array key ~v" i)))))]
[(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict)) members)) [(Template-TCompound (TCompound (ConstructorSpec-CDict (CDict))
(TCompoundMembers members)))
(for/hash [((key tt) (in-hash members))] (for/hash [((key tt) (in-hash members))]
(values key (walk tt)))]))) (values key (walk tt)))])))