From fdab507586f9865fb4be5fcbb282630c841899ab Mon Sep 17 00:00:00 2001
From: Danny Yoo <dyoo@cs.wpi.edu>
Date: Tue, 22 Feb 2011 03:21:18 -0500
Subject: [PATCH] trying to identify bindings that need boxing for set-bang

---
 compile.rkt             |  4 ++-
 find-boxed-bindings.rkt | 68 +++++++++++++++++++++++++++++++++++++++++
 typed-structs.rkt       |  3 +-
 3 files changed, 73 insertions(+), 2 deletions(-)
 create mode 100644 find-boxed-bindings.rkt

diff --git a/compile.rkt b/compile.rkt
index fa36976..b7adc7d 100644
--- a/compile.rkt
+++ b/compile.rkt
@@ -161,7 +161,6 @@
                        ,(make-AssignImmediateStatement target (make-Const 'ok))))))])))
 
 
-;; FIXME: exercise 5.43
 (: compile-definition (Def CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-definition exp cenv target linkage)
   (let* ([var (Def-variable exp)]
@@ -272,6 +271,9 @@
 
 (: compile-application (App CompileTimeEnvironment Target Linkage -> InstructionSequence))
 (define (compile-application exp cenv target linkage) 
+  ;; FIXME: I need to implement important special cases.
+  ;; 1. We may be able to open-code if the operator is primitive
+  ;; 2. We may have a static location to jump to if the operator is lexically scoped.
   (let ([proc-code (compile (App-operator exp) cenv 'proc 'next)]
         [operand-codes (map (lambda: ([operand : Expression])
                               (compile operand cenv 'val 'next))
diff --git a/find-boxed-bindings.rkt b/find-boxed-bindings.rkt
new file mode 100644
index 0000000..0f9bd91
--- /dev/null
+++ b/find-boxed-bindings.rkt
@@ -0,0 +1,68 @@
+#lang typed/racket/base
+(require "typed-structs.rkt"
+         "lexical-env.rkt"
+         "find-toplevel-variables.rkt")
+
+
+(: find-boxed-bindings (Expression -> (HashTable Expression Boolean)))
+;; Collects the list of toplevel variables we need.
+(define (find-boxed-bindings exp)
+  
+  (: ht (HashTable Expression Boolean))
+  (define ht (make-hasheq))
+  
+  (: loop (Expression CompileTimeEnvironment -> 'ok))
+  (define (loop exp cenv)
+    (cond
+      [(Constant? exp)
+       'ok]
+      
+      [(Quote? exp)
+       'ok]
+      
+      [(Var? exp)
+       'ok]
+      
+      [(Assign? exp)
+       (let ([lexical-address
+              (find-variable (Assign-variable exp) cenv)])
+         (cond
+           [(LocalAddress? lexical-address)
+            (hash-set! ht exp #t)
+            'ok]
+           [(PrefixAddress? lexical-address)
+            'ok]))
+       (loop (Assign-value exp) cenv)]
+      
+      [(Def? exp)
+       (loop (Def-value exp) cenv)]
+      
+      [(Branch? exp)
+       (loop (Branch-predicate exp) cenv)
+       (loop (Branch-consequent exp) cenv)
+       (loop (Branch-alternative exp) cenv)
+       'ok]
+      
+      [(Lam? exp)
+       (let ([extended-cenv
+              (extend-lexical-environment cenv (Lam-parameters exp))])
+
+         (for-each (lambda: ([e : Expression]) (loop e extended-cenv))
+                   (Lam-body exp))
+         'ok)]
+
+      
+      [(Seq? exp)
+       (for-each (lambda: ([e : Expression]) (loop e cenv)) (Seq-actions exp))
+       'ok]
+      
+      [(App? exp)
+       (loop (App-operator exp) cenv)
+       (for-each (lambda: ([e : Expression]) (loop e cenv)) (App-operands exp))
+       'ok]))
+  
+  (let*: ([names : (Listof Symbol) (find-toplevel-variables exp)]
+          [cenv : CompileTimeEnvironment (list (make-Prefix names))])
+  
+         (loop exp cenv))
+  ht)
\ No newline at end of file
diff --git a/typed-structs.rkt b/typed-structs.rkt
index 1766012..29ddf40 100644
--- a/typed-structs.rkt
+++ b/typed-structs.rkt
@@ -4,7 +4,8 @@
 
 ;; Expressions
 
-(define-type Expression (U Constant Quote Var Assign Branch Def Lam Seq App))
+(define-type ExpressionCore (U Constant Quote Var Branch Def Lam Seq App))
+(define-type Expression (U ExpressionCore Assign))
 (define-struct: Constant ([v : Any]) #:transparent)
 (define-struct: Quote ([text : Any]) #:transparent)
 (define-struct: Var ([id : Symbol]) #:transparent)