From e862a43ae508b2935c7db9ddd4d15e01043f56d2 Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Sat, 26 Mar 2011 20:12:16 -0400
Subject: [PATCH] more open coding

---
 assemble.rkt          | 36 +++++++++++++++++++++++++++++-------
 il-structs.rkt        |  9 ++++++++-
 simulator-helpers.rkt | 12 ++++++++++++
 simulator.rkt         | 22 ++++++++++++++++++++--
 test-conform.rkt      |  2 +-
 5 files changed, 70 insertions(+), 11 deletions(-)

diff --git a/assemble.rkt b/assemble.rkt
index 1d8b5c1..575bb8b 100644
--- a/assemble.rkt
+++ b/assemble.rkt
@@ -417,28 +417,50 @@ EOF
 (define (open-code-kernel-primitive-procedure op)
   (let: ([operator : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
          [rand-vals : (Listof String) (map assemble-input (CallKernelPrimitiveProcedure-operands op))])
-        (cond
-          [(eq? operator '+)
+        (case operator
+          [(+)
            (cond [(empty? rand-vals)
                   "0"]
                  [else
                   (string-append "(" (string-join rand-vals " + ") ")")])]
-          [(eq? operator 'add1)
+          [(add1)
            (unless (= 1 (length rand-vals))
              (error 'add1 "Expected one argument"))
            (format "(~a + 1)" (first rand-vals))]
-          [(eq? operator 'sub1)
+          [(sub1)
            (unless (= 1 (length rand-vals))
              (error 'sub1 "Expected one argument"))
            (format "(~a - 1)" (first rand-vals))]
-          [(eq? operator '<)
+          [(<)
            (unless (> (length rand-vals) 0)
              (error '< "Expected at least one argument"))
            (assemble-chain "<" rand-vals)]
-          [(eq? operator '<=)
+          [(<=)
            (unless (> (length rand-vals) 0)
              (error '<= "Expected at least one argument"))
-           (assemble-chain "<=" rand-vals)])))
+           (assemble-chain "<=" rand-vals)]
+          [(=)
+           (unless (> (length rand-vals) 0)
+             (error '= "Expected at least one argument"))
+           (assemble-chain "==" rand-vals)]
+          [(cons)
+           (unless (= (length rand-vals) 2)
+             (error 'cons "Expected two arguments"))
+           (format "[~a, ~a]" (first rand-vals) (second rand-vals))]
+          [(car)
+           (unless (= (length rand-vals) 1)
+             (error 'car "Expected one argument"))
+           (format "(~a)[0]" (first rand-vals))]
+          [(cdr)
+           (unless (= (length rand-vals) 1)
+             (error 'cdr "Expected one argument"))
+           (format "(~a)[1]" (first rand-vals))]
+          [(null?)
+           (unless (= (length rand-vals) 1)
+             (error 'null? "Expected one argument"))
+           (format "(~a === Primitives.null)"
+                   (first rand-vals))])))
+
 
 (: assemble-chain (String (Listof String) -> String))
 (define (assemble-chain rator rands)
diff --git a/il-structs.rkt b/il-structs.rkt
index 38dc76e..a5016fc 100644
--- a/il-structs.rkt
+++ b/il-structs.rkt
@@ -153,7 +153,14 @@
                                     'add1
                                     'sub1
                                     '<
-                                    '<=))
+                                    '<=
+                                    '=
+                                    
+                                    'cons
+                                    'car
+                                    'cdr
+                                    'null?
+                                    ))
 (define-predicate KernelPrimitiveName? KernelPrimitiveName)
 
 
diff --git a/simulator-helpers.rkt b/simulator-helpers.rkt
index ff04cda..01122be 100644
--- a/simulator-helpers.rkt
+++ b/simulator-helpers.rkt
@@ -3,6 +3,7 @@
 (require "simulator-structs.rkt")
 (provide ensure-primitive-value-box
          ensure-primitive-value
+         ensure-list
          PrimitiveValue->racket
          racket->PrimitiveValue)
 (define (ensure-primitive-value-box x)
@@ -43,6 +44,17 @@
        (error 'ensure-primitive-value "~s" v)])))
 
 
+(define (ensure-list v)
+  (cond
+    [(null? v)
+     v]
+    [(and (MutablePair? v)
+          (PrimitiveValue? (MutablePair-h v))
+          (PrimitiveValue? (MutablePair-t v)))
+     v]
+    [else
+     (error 'ensure-list)]))
+
 
 (define (PrimitiveValue->racket v)
   (cond
diff --git a/simulator.rkt b/simulator.rkt
index d161385..6f17fe4 100644
--- a/simulator.rkt
+++ b/simulator.rkt
@@ -20,6 +20,7 @@
 (require/typed "simulator-helpers.rkt"
                [ensure-primitive-value-box (SlotValue -> (Boxof PrimitiveValue))]
                [ensure-primitive-value (SlotValue -> PrimitiveValue)]
+               [ensure-list (Any -> PrimitiveValue)]
                [racket->PrimitiveValue (Any -> PrimitiveValue)])
              
 
@@ -336,9 +337,9 @@
 (: evaluate-kernel-primitive-procedure-call (machine CallKernelPrimitiveProcedure -> PrimitiveValue))
 (define (evaluate-kernel-primitive-procedure-call m op)
   (let: ([op : KernelPrimitiveName (CallKernelPrimitiveProcedure-operator op)]
-         [rand-vals : (Listof SlotValue)
+         [rand-vals : (Listof PrimitiveValue)
                     (map (lambda: ([a : OpArg])
-                                  (evaluate-oparg m a))
+                                  (ensure-primitive-value (evaluate-oparg m a)))
                          (CallKernelPrimitiveProcedure-operands op))])
         (case op
           [(+)
@@ -351,6 +352,16 @@
            (chain-compare < (map ensure-real-number rand-vals))]
           [(<=)   
            (chain-compare <= (map ensure-real-number rand-vals))]
+          [(=)
+           (chain-compare = (map ensure-real-number rand-vals))]
+          [(cons)
+           (make-MutablePair (first rand-vals) (ensure-list (second rand-vals)))]
+          [(car)
+           (MutablePair-h (ensure-mutable-pair (first rand-vals)))]
+          [(cdr)
+           (MutablePair-t (ensure-mutable-pair (first rand-vals)))]
+          [(null?)
+           (null? (first rand-vals))]
           [else
            (error 'evaluate-kernel-primitive-procedure-call "missing operator: ~s\n" op)])))
 
@@ -474,6 +485,13 @@
       (error 'ensure-number "Not a number: ~s" x)))
 
 
+(: ensure-mutable-pair (Any -> MutablePair))
+(define (ensure-mutable-pair x)
+  (if (MutablePair? x)
+      x
+      (error 'ensure-mutable-pair "not a mutable pair: ~s" x)))
+
+
 
 (: ensure-CapturedControl (Any -> CapturedControl))
 (define (ensure-CapturedControl x)
diff --git a/test-conform.rkt b/test-conform.rkt
index 0ba218d..d27ea60 100644
--- a/test-conform.rkt
+++ b/test-conform.rkt
@@ -67,4 +67,4 @@
 
 (test (read (open-input-file "tests/conform/program0.sch"))
       (port->string (open-input-file "tests/conform/expected0.txt"))
-      #:debug? #f)
+      #:debug? #t)