From 24ad16ac9cd1bd83ae9bb7151915c79245de4dcd Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Fri, 19 Aug 2011 19:17:33 -0400
Subject: [PATCH] adding static check to make sure I didn't screw up the type
 subset definition

---
 compiler/kernel-primitives.rkt     |  5 ++-
 lang/kernel.rkt                    | 11 ++++---
 simulator/simulator-primitives.rkt |  3 +-
 simulator/simulator.rkt            |  2 ++
 type-helpers.rkt                   | 49 ++++++++++++++++++++++++++++++
 5 files changed, 63 insertions(+), 7 deletions(-)
 create mode 100644 type-helpers.rkt

diff --git a/compiler/kernel-primitives.rkt b/compiler/kernel-primitives.rkt
index 32be395..812ee71 100644
--- a/compiler/kernel-primitives.rkt
+++ b/compiler/kernel-primitives.rkt
@@ -2,7 +2,8 @@
 
 (provide (all-defined-out))
 
-(require "arity-structs.rkt")
+(require "arity-structs.rkt"
+         "../type-helpers.rkt")
 (define-type OperandDomain (U 'number
                               'string
                               'box
@@ -95,6 +96,8 @@
                                            'not
                                            'eq?))
 
+(ensure-type-subsetof KernelPrimitiveName/Inline KernelPrimitiveName)
+
 
 (define-predicate KernelPrimitiveName/Inline? KernelPrimitiveName/Inline)
 
diff --git a/lang/kernel.rkt b/lang/kernel.rkt
index 46c04a6..aa09bed 100644
--- a/lang/kernel.rkt
+++ b/lang/kernel.rkt
@@ -138,10 +138,15 @@
          car
          cdr
          list
+         list?
+         pair?
          null?
          not
          eq?
-         values)
+         values
+
+         apply
+         call-with-values)
 
 
 (define (-identity x) x)
@@ -183,8 +188,6 @@
 ;;  arity-at-least?
 ;;  arity-at-least-value
 
- apply
- call-with-values
 
 ;;  compose
 ;;  current-inexact-milliseconds
@@ -259,8 +262,6 @@ raise-mismatch-error
   procedure-arity
   procedure-arity-includes?
   procedure-rename
-  pair?
-  list?
   ;;  (undefined? -undefined?)
 ;;  immutable?
 ;;  void?
diff --git a/simulator/simulator-primitives.rkt b/simulator/simulator-primitives.rkt
index 547485b..16bd544 100644
--- a/simulator/simulator-primitives.rkt
+++ b/simulator/simulator-primitives.rkt
@@ -237,7 +237,7 @@
                                                      symbol->string
                                                      string-append
                                                      string-length
-                                                     
+
                                                      (my-cons cons)
                                                      (my-list list)
                                                      (my-car car)
@@ -245,6 +245,7 @@
 						     (my-cadr cadr)
 						     (my-caddr caddr)
                                                      (my-pair? pair?)
+                                                     null?
                                                      (my-set-car! set-car!)
                                                      (my-set-cdr! set-cdr!)
                                                      (my-member member)
diff --git a/simulator/simulator.rkt b/simulator/simulator.rkt
index bd475c5..8ef658a 100644
--- a/simulator/simulator.rkt
+++ b/simulator/simulator.rkt
@@ -791,6 +791,8 @@
            (list->mutable-pair-list rand-vals)]
           [(null?)
            (null? (first rand-vals))]
+          [(pair?)
+           (MutablePair? (first rand-vals))]
           [(not)
            (not (first rand-vals))]
           [(eq?)
diff --git a/type-helpers.rkt b/type-helpers.rkt
new file mode 100644
index 0000000..71eaec3
--- /dev/null
+++ b/type-helpers.rkt
@@ -0,0 +1,49 @@
+#lang typed/racket/base
+(require (for-syntax racket/base
+                     syntax/parse))
+                     
+;; Provides helpers for use with Typed Racket programs.
+
+(provide ensure-type-subsetof)
+
+
+;; Usage: (ensure-type-subsetof subtype supertype)
+;;
+;; Statically errors out if subtype is not within supertype.
+;;
+(define-syntax (ensure-type-subsetof stx)
+  (syntax-parse stx
+    [(_ subtype:id supertype:id)
+     ;; begin-splicing
+     (with-syntax ([x (syntax/loc stx x)])
+       #`(void (lambda () (ann (values (ann #,(syntax/loc stx (error 'fail))
+                                            subtype)) supertype))))]))
+
+
+
+
+#|
+(define-type T0 (U 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k 'l 'm 'n 'o 'p
+                   'q 'r 's 't 'u 'v 'w 'x 'y 'z))
+(define-type T1 (U 'a
+                   'e
+                   'i
+                   'o
+                   'u))
+(ensure-type-subsetof T1 T0)
+
+
+
+(define-struct: Id ([name : Symbol]))
+(define-struct: Num ([datum : Number]))
+(define-struct: Add ([lhs : Expr]
+                     [rhs : Expr]));
+(define-type Expr 
+  (U Id 
+     ;; Num     ;; Uncomment to correct the type error
+     Add))
+(define-type ConstantExpr (U Id Num))
+
+;; And if we mess up at least it errors out at compile time
+(ensure-type-subsetof ConstantExpr Expr)
+|#
\ No newline at end of file