cond, match
This commit is contained in:
parent
af91b669b7
commit
35b3811462
|
@ -1,5 +1,11 @@
|
||||||
#lang typed/syndicate
|
#lang typed/syndicate
|
||||||
|
|
||||||
|
;; Expected Output
|
||||||
|
;; Completed Order:
|
||||||
|
;; Catch 22
|
||||||
|
;; 10001483
|
||||||
|
;; March 9th
|
||||||
|
|
||||||
(define-constructor (price v)
|
(define-constructor (price v)
|
||||||
#:type-constructor PriceT
|
#:type-constructor PriceT
|
||||||
#:with Price (PriceT Int))
|
#:with Price (PriceT Int))
|
||||||
|
@ -131,6 +137,7 @@
|
||||||
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
[(tuple (order-id (bind id Int)) (delivery-date (bind date String)))
|
||||||
;; complete!
|
;; complete!
|
||||||
(begin (displayln "Completed Order:")
|
(begin (displayln "Completed Order:")
|
||||||
|
(displayln title)
|
||||||
(displayln id)
|
(displayln id)
|
||||||
(displayln date)
|
(displayln date)
|
||||||
(stop purchase (begin)))]
|
(stop purchase (begin)))]
|
||||||
|
|
|
@ -27,7 +27,7 @@
|
||||||
;; DEBUG and utilities
|
;; DEBUG and utilities
|
||||||
print-type print-role
|
print-type print-role
|
||||||
;; Extensions
|
;; Extensions
|
||||||
;; match if cond
|
cond
|
||||||
)
|
)
|
||||||
|
|
||||||
(require (prefix-in syndicate: syndicate/actor-lang))
|
(require (prefix-in syndicate: syndicate/actor-lang))
|
||||||
|
@ -741,6 +741,11 @@
|
||||||
(lambda (id) #`($ #,id))
|
(lambda (id) #`($ #,id))
|
||||||
identity))
|
identity))
|
||||||
|
|
||||||
|
(define-for-syntax (compile-match-pattern pat)
|
||||||
|
(compile-pattern pat
|
||||||
|
identity
|
||||||
|
(lambda (exp) #`(== #,exp))))
|
||||||
|
|
||||||
(define-typed-syntax (spawn τ-c:type s) ≫
|
(define-typed-syntax (spawn τ-c:type s) ≫
|
||||||
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
#:fail-unless (flat-type? #'τ-c.norm) "Communication type must be first-order"
|
||||||
;; TODO: check that each τ-f is a Role
|
;; TODO: check that each τ-f is a Role
|
||||||
|
@ -881,8 +886,6 @@
|
||||||
;; Core-ish forms
|
;; Core-ish forms
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
;; (⇒ a as) (⇒ r rs) (⇒ f fs) (⇒ s ss)
|
|
||||||
|
|
||||||
;; copied from stlc
|
;; copied from stlc
|
||||||
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
(define-typed-syntax (ann e (~optional (~datum :)) τ:type) ≫
|
||||||
[⊢ e ≫ e- (⇐ : τ.norm)]
|
[⊢ e ≫ e- (⇐ : τ.norm)]
|
||||||
|
@ -1019,6 +1022,45 @@
|
||||||
--------
|
--------
|
||||||
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
[≻ (let ([x e]) (let* ([x_rst e_rst] ...) e_body ...))]])
|
||||||
|
|
||||||
|
(define-typed-syntax (cond [pred:expr s ...+] ...+) ≫
|
||||||
|
[⊢ pred ≫ pred- (⇐ : Bool)] ...
|
||||||
|
#:fail-unless (stx-andmap pure? #'(pred- ...)) "predicates must be pure"
|
||||||
|
[⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
||||||
|
(⇒ a (~effs as ...))
|
||||||
|
(⇒ r (~effs rs ...))
|
||||||
|
(⇒ f (~effs fs ...))
|
||||||
|
(⇒ s (~effs ss ...))] ...
|
||||||
|
------------------------------------------------
|
||||||
|
[⊢ (cond- [pred- s-] ...) (⇒ : (U τ-s ...))
|
||||||
|
(⇒ a (as ... ...))
|
||||||
|
(⇒ r (rs ... ...))
|
||||||
|
(⇒ f (fs ... ...))
|
||||||
|
(⇒ s (ss ... ...))])
|
||||||
|
|
||||||
|
(define-typed-syntax (match e [p s ...+] ...+) ≫
|
||||||
|
[⊢ e ≫ e- (⇒ : τ-e)]
|
||||||
|
#:fail-unless (pure? #'e-) "expression must be pure"
|
||||||
|
#:with (([x τ] ...) ...) (stx-map pat-bindings #'(p ...))
|
||||||
|
[[x ≫ x- : τ] ... ⊢ (begin s ...) ≫ s- (⇒ : τ-s)
|
||||||
|
(⇒ a (~effs as ...))
|
||||||
|
(⇒ r (~effs rs ...))
|
||||||
|
(⇒ f (~effs fs ...))
|
||||||
|
(⇒ s (~effs ss ...))] ...
|
||||||
|
;; REALLY not sure how to handle p/p-/p.match-pattern,
|
||||||
|
;; particularly w.r.t. typed terms that appear in p.match-pattern
|
||||||
|
[⊢ p ≫ p-- ⇒ τ-p] ...
|
||||||
|
#:fail-unless (project-safe? #'τ-e (type-eval #'(U τ-p ...))) "possibly unsafe pattern match"
|
||||||
|
#:fail-unless (stx-andmap pure? #'(p-- ...)) "patterns must be pure"
|
||||||
|
#:with (p- ...) (stx-map compile-match-pattern #'(p ...))
|
||||||
|
--------------------------------------------------------------
|
||||||
|
[⊢ (match- e- [p- (let- ([x- x] ...) s-)] ...
|
||||||
|
[_ (error "incomplete pattern match")])
|
||||||
|
(⇒ : (U τ-s ...))
|
||||||
|
(⇒ a (as ... ...))
|
||||||
|
(⇒ r (rs ... ...))
|
||||||
|
(⇒ f (fs ... ...))
|
||||||
|
(⇒ s (ss ... ...))])
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Primitives
|
;; Primitives
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
Loading…
Reference in New Issue