commit c8ff0afa0255c9fd620861a4aa66c0d0a43b36e5
parent 3a97efcb24aa3b89af45cd3941d22d2c351c925e
Author: AlexKnauth <alexander@knauth.org>
Date: Mon, 20 Jun 2016 15:14:20 -0400
implement stlc+box and stlc+effect with typed-lang-builder
Diffstat:
6 files changed, 174 insertions(+), 24 deletions(-)
diff --git a/tapl/stlc+effect.rkt b/tapl/stlc+effect.rkt
@@ -12,9 +12,9 @@
;; - ref deref :=
(begin-for-syntax
- (define (add-news e locs) (syntax-property e 'new locs))
- (define (add-assigns e locs) (syntax-property e 'assign locs))
- (define (add-derefs e locs) (syntax-property e 'deref locs))
+ (define (add-news e locs) (syntax-property e 'ν locs))
+ (define (add-assigns e locs) (syntax-property e ':= locs))
+ (define (add-derefs e locs) (syntax-property e '! locs))
(define (add-effects e new-locs assign-locs deref-locs)
(add-derefs
(add-assigns
@@ -27,16 +27,16 @@
(local-expand (if (null? vs) e #`(stlc+box:λ #,vs #,e)) 'expression null)
tag)
null))
- (define (get-new-effects e [vs '()]) (get-effects e 'new vs))
- (define (get-assign-effects e [vs '()]) (get-effects e 'assign vs))
- (define (get-deref-effects e [vs '()]) (get-effects e 'deref vs))
+ (define (get-new-effects e [vs '()]) (get-effects e 'ν vs))
+ (define (get-assign-effects e [vs '()]) (get-effects e ':= vs))
+ (define (get-deref-effects e [vs '()]) (get-effects e '! vs))
(define (print-effects e)
(printf "expr ~a\n" (syntax->datum e))
(define e+ (local-expand e 'expression null))
- (printf "new locs: ~a\n" (syntax-property e+ 'new))
- (printf "deref locs: ~a\n" (syntax-property e+ 'deref))
- (printf "assign locs: ~a\n" (syntax-property e+ 'assign)))
+ (printf "new locs: ~a\n" (syntax-property e+ 'ν))
+ (printf "deref locs: ~a\n" (syntax-property e+ '!))
+ (printf "assign locs: ~a\n" (syntax-property e+ ':=)))
(define (loc-union locs1 locs2)
(cond
@@ -128,11 +128,11 @@
(stx-append #'ds1 #'ds2))])
;(define-typed-syntax ref
; [(_ e)
-; (syntax-property #'(stlc+box:ref e) 'new (set (syntax-position stx)))])
+; (syntax-property #'(stlc+box:ref e) 'ν (set (syntax-position stx)))])
;(define-typed-syntax deref
; [(_ e)
-; (syntax-property #'(stlc+box:deref e) 'deref (set (syntax-position stx)))])
+; (syntax-property #'(stlc+box:deref e) '! (set (syntax-position stx)))])
;(define-typed-syntax :=
; [(_ e_ref e)
-; (syntax-property #'(stlc+box::= e_ref e) 'assign (set (syntax-position stx)))])
+; (syntax-property #'(stlc+box::= e_ref e) ':= (set (syntax-position stx)))])
diff --git a/tapl/tests/rackunit-typechecking.rkt b/tapl/tests/rackunit-typechecking.rkt
@@ -41,15 +41,15 @@
;; for checking properties other than types
(define-syntax (check-props stx)
(syntax-parse stx #:datum-literals (: ⇒ ->)
- [(_ prop e : v ... (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e])))
+ [(_ prop e : v (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e])))
#:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop))
#'())
- #:fail-unless (set=? (apply set (syntax->datum #'(v ...)))
- (apply set (syntax->datum #'props)))
+ #:fail-unless (equal? (syntax->datum #'v)
+ (syntax->datum #'props))
(format
"Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a"
(syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e)
- (syntax->datum #'(v ...)) (syntax->datum #'props))
+ (syntax->datum #'v) (syntax->datum #'props))
(syntax/loc stx (check-equal? e v2))]))
(define-syntax (check-not-type stx)
diff --git a/tapl/tests/stlc+box-tests.rkt b/tapl/tests/stlc+box-tests.rkt
@@ -1,4 +1,4 @@
-#lang s-exp "../stlc+box.rkt"
+#lang s-exp "../typed-lang-builder/stlc+box.rkt"
(require "rackunit-typechecking.rkt")
(define x (ref 10))
@@ -26,11 +26,11 @@
(typecheck-fail
(deref 1)
#:with-msg
- "Expected expression 1 to have Ref type, got: Int")
+ "Expected Ref type, got: Int")
(typecheck-fail
(:= 1 1)
#:with-msg
- "Expected expression 1 to have Ref type, got: Int")
+ "Expected Ref type, got: Int")
;; previous tests: ------------------------------------------------------------
(typecheck-fail (cons 1 2))
diff --git a/tapl/tests/stlc+effect-tests.rkt b/tapl/tests/stlc+effect-tests.rkt
@@ -1,10 +1,10 @@
-#lang s-exp "../stlc+effect.rkt"
+#lang s-exp "../typed-lang-builder/stlc+effect.rkt"
(require "rackunit-typechecking.rkt")
-(check-props new (ref 11) : 90)
-(check-props deref (deref (ref 11)) : 124)
-(check-props new (deref (ref 11)) : 172)
-(check-props new ((λ ([x : Int]) (ref x)) 21) : 222)
+(check-props ν (ref 11) : '(107))
+(check-props ! (deref (ref 11)) : '(141))
+(check-props ν (deref (ref 11)) : '(190))
+(check-props ν ((λ ([x : Int]) (ref x)) 21) : '(241))
(define x (ref 10))
(check-type x : (Ref Int))
diff --git a/tapl/typed-lang-builder/stlc+box.rkt b/tapl/typed-lang-builder/stlc+box.rkt
@@ -0,0 +1,32 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "stlc+cons.rkt")
+
+;; Simply-Typed Lambda Calculus, plus mutable references
+;; Types:
+;; - types from stlc+cons.rkt
+;; - Ref constructor
+;; Terms:
+;; - terms from stlc+cons.rkt
+;; - ref deref :=
+
+(define-type-constructor Ref)
+
+(define-typed-syntax ref
+ [(ref e) ▶
+ [⊢ [[e ≫ e-] ⇒ (: τ)]]
+ --------
+ [⊢ [[_ ≫ (box- e-)] ⇒ (: (Ref τ))]]])
+
+(define-typed-syntax deref
+ [(deref e) ▶
+ [⊢ [[e ≫ e-] ⇒ (: (~Ref τ))]]
+ --------
+ [⊢ [[_ ≫ (unbox- e-)] ⇒ (: τ)]]])
+
+(define-typed-syntax := #:literals (:=)
+ [(:= e_ref e) ▶
+ [⊢ [[e_ref ≫ e_ref-] ⇒ (: (~Ref τ))]]
+ [⊢ [[e ≫ e-] ⇐ (: τ)]]
+ --------
+ [⊢ [[_ ≫ (set-box!- e_ref- e-)] ⇒ (: Unit)]]])
+
diff --git a/tapl/typed-lang-builder/stlc+effect.rkt b/tapl/typed-lang-builder/stlc+effect.rkt
@@ -0,0 +1,118 @@
+#lang macrotypes/tapl/typed-lang-builder
+(extends "stlc+box.rkt" #:except ref deref := #%app λ)
+
+(provide (for-syntax get-new-effects))
+
+;; Simply-Typed Lambda Calculus, plus mutable references
+;; Types:
+;; - types from stlc+cons.rkt
+;; - Ref constructor
+;; Terms:
+;; - terms from stlc+cons.rkt
+;; - ref deref :=
+
+(define-syntax-rule (locs loc ...)
+ '(loc ...))
+(begin-for-syntax
+ (define-syntax ~locs
+ (pattern-expander
+ (syntax-parser
+ [(locs loc:id ...)
+ #:with tmp (generate-temporary 'locs)
+ #'(~and tmp
+ (~parse ((~literal quote) (loc ...))
+ (stx-or #'tmp #'(quote ()))))])))
+
+ (define (add-news e locs) (assign-type e #:tag 'ν locs))
+ (define (add-assigns e locs) (assign-type e #:tag ':= locs))
+ (define (add-derefs e locs) (assign-type e #:tag '! locs))
+ (define (add-effects e new-locs assign-locs deref-locs)
+ (add-derefs
+ (add-assigns
+ (add-news e new-locs)
+ assign-locs)
+ deref-locs))
+
+ (define (get-effects e tag)
+ (syntax-property e tag))
+ (define (get-new-effects e) (get-effects e 'ν))
+ (define (get-assign-effects e) (get-effects e ':=))
+ (define (get-deref-effects e) (get-effects e '!))
+
+ (define (print-effects e)
+ (printf "expr ~a\n" (syntax->datum e))
+ (define e+ (local-expand e 'expression null))
+ (printf "new locs: ~a\n" (syntax-property e+ 'ν))
+ (printf "deref locs: ~a\n" (syntax-property e+ '!))
+ (printf "assign locs: ~a\n" (syntax-property e+ ':=)))
+
+ (define (stx-cons a b)
+ (datum->syntax #f (cons a b)))
+ (define (stx-truth? a)
+ (and a (not (and (syntax? a) (false? (syntax-e a))))))
+ (define (stx-or a b)
+ (cond [(stx-truth? a) a]
+ [else b])))
+
+
+(define-typed-syntax effect:#%app #:export-as #%app
+ [(_ efn e ...) ▶
+ [⊢ [[efn ≫ e_fn-]
+ ⇒ (: ty_fn ν (~locs fns ...) := (~locs fas ...) ! (~locs fds ...))
+ ⇒ (ν (~locs tyns ...) := (~locs tyas ...) ! (~locs tyds ...))]]
+ [#:with (~→ τ_in ... τ_out) #'ty_fn]
+ [⊢ [[e ≫ e_arg-] ⇒ (: τ_arg ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))] ...]
+ [#:fail-unless (stx-length=? #'(τ_arg ...) #'(τ_in ...))
+ "wrong number of arguments"]
+ [τ_arg τ⊑ τ_in] ...
+ --------
+ [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)]
+ ⇒ (: τ_out
+ ν (locs fns ... tyns ... ns ... ...)
+ := (locs fas ... tyas ... as ... ...)
+ ! (locs fds ... tyds ... ds ... ...))]]])
+
+(define-typed-syntax λ
+ [(λ bvs:type-ctx e) ▶
+ [() ([bvs.x : bvs.type ≫ x-] ...) ⊢
+ [[e ≫ e-]
+ ⇒ (: τ_res ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+ --------
+ [⊢ [[_ ≫ (λ- (x- ...) e-)]
+ ⇒ (: #,(add-effects #'(→ bvs.type ... τ_res)
+ #'(locs ns ...)
+ #'(locs as ...)
+ #'(locs ds ...)))]]])
+
+(define-type-constructor Ref)
+
+(define-typed-syntax ref
+ [(ref e) ▶
+ [⊢ [[e ≫ e-] ⇒ (: τ ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+ --------
+ [⊢ [[_ ≫ (box- e-)]
+ ⇒ (: (Ref τ)
+ ν (locs #,(syntax-position stx) ns ...)
+ := (locs as ...)
+ ! (locs ds ...))]]])
+(define-typed-syntax deref
+ [(deref e) ▶
+ [⊢ [[e ≫ e-] ⇒ (: (~Ref ty) ν (~locs ns ...) := (~locs as ...) ! (~locs ds ...))]]
+ --------
+ [⊢ [[_ ≫ (unbox- e-)]
+ ⇒ (: ty
+ ν (locs ns ...)
+ := (locs as ...)
+ ! (locs #,(syntax-position stx) ds ...))]]])
+(define-typed-syntax := #:literals (:=)
+ [(:= e_ref e) ▶
+ [⊢ [[e_ref ≫ e_ref-] ⇒ (: (~Ref ty1) ν (~locs ns1 ...) := (~locs as1 ...) ! (~locs ds1 ...))]]
+ [⊢ [[e ≫ e-] ⇒ (: ty2 ν (~locs ns2 ...) := (~locs as2 ...) ! (~locs ds2 ...))]]
+ [ty1 τ⊑ ty2]
+ --------
+ [⊢ [[_ ≫ (set-box!- e_ref- e-)]
+ ⇒ (: Unit
+ ν (locs ns1 ... ns2 ...)
+ := (locs #,(syntax-position stx) as1 ... as2 ...)
+ ! (locs ds1 ... ds2 ...))]]])
+
