From 628f86e51a7500de4e174e73e33606b8aceca86b Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@vistahigherlearning.com>
Date: Thu, 6 Oct 2022 17:29:39 -0400
Subject: Step 12: Assignment

---
 compiler.scm | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 151 insertions(+), 2 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index 170bddd..3a147a2 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -77,6 +77,9 @@
 (define (quote? x)
   (op-eq? x 'quote))
 
+(define (set? x)
+  (op-eq? x 'set!))
+
 (define (primcall-op x)
   (first x))
 
@@ -812,6 +815,143 @@
    ((pair? x)
     `(funcall ,@(map annotate-free-variables x)))))
 
+;; Determine if var is mutated (via set!) within an expression.
+(define (mutable? var x)
+  (cond
+   ((immediate? x) #f)
+   ((quote? x) #f)
+   ((variable? x) #f)
+   ((if? x)
+    (or (mutable? var (test x))
+        (mutable? var (consequent x))
+        (mutable? var (alternate x))))
+   ((let? x)
+    ;; First, check if any of the expressions for the variable
+    ;; bindings mutate the variable.
+    (or (any (lambda (binding)
+               (mutable? var (rhs binding)))
+             (let-bindings x))
+        ;; Now check if the body mutates the variable, but not if the
+        ;; let shadows the variable with a new meaning.
+        (let ((shadowed? (any (lambda (binding)
+                                (eq? (lhs binding) var))
+                              (let-bindings x))))
+          (if shadowed?
+              #f
+              (any (lambda (y)
+                     (mutable? var y))
+                   (let-body x))))))
+   ((primcall? x)
+    (any (lambda (arg)
+           (mutable? var arg))
+         (cdr x)))
+   ((lambda? x)
+    (let ((shadowed? (any (lambda (arg)
+                            (eq? arg var))
+                          (lambda-args x))))
+      (if shadowed?
+          #f
+          (mutable? var (lambda-body x)))))
+   ((set? x)
+    (eq? (second x) var))
+   ((pair? x)
+    (any (lambda (y) (mutable? var y)) x))))
+
+(define* (box-mutable-variables x #:optional (mutable-vars '()))
+  (cond
+   ((immediate? x) x)
+   ((quote? x) x)
+   ((variable? x)
+    ;; Mutable variable references must be unboxed.
+    (if (memq x mutable-vars)
+        `(vector-ref ,x 0)
+        x))
+   ((if? x)
+    `(if ,(box-mutable-variables (test x) mutable-vars)
+         ,(box-mutable-variables (consequent x) mutable-vars)
+         ,(box-mutable-variables (alternate x) mutable-vars)))
+   ((let? x)
+    (let* ((bindings (let-bindings x))
+           (mutable-bindings
+            ;; Find all mutable bindings.
+            (filter (lambda (binding)
+                      (any (lambda (y)
+                             (mutable? (lhs binding) y))
+                           (let-body x)))
+                    bindings)))
+      `(let ,(map (lambda (binding)
+                    (let ((var (lhs binding)))
+                      (list var
+                            ;; Use a 1 element vector to box mutable
+                            ;; variables.
+                            (if (memq var mutable-bindings)
+                                `(vector ,(box-mutable-variables (rhs binding)
+                                                                 mutable-vars))
+                                (box-mutable-variables (rhs binding)
+                                                       mutable-vars)))))
+                  bindings)
+         ,@(let ((mutable-vars*
+                  (fold (lambda (var memo)
+                          ;; If the variable is mutable and not
+                          ;; already in the list of mutable vars
+                          ;; (meaning that this new mutable var is
+                          ;; shadowing another mutable var) then add
+                          ;; it to the list.  If the variable isn't
+                          ;; mutable, then remove it from the list of
+                          ;; mutable vars, if present.
+                          (if (memq var mutable-bindings)
+                              (if (not (memq var mutable-vars))
+                                  (cons var memo)
+                                  memo)
+                              (delq var memo)))
+                        mutable-vars
+                        bindings)))
+             (map (lambda (y)
+                    (box-mutable-variables y mutable-vars*))
+                  (let-body x))))))
+   ((lambda? x)
+    (let* ((args (lambda-args x))
+           ;; Mutable arguments get new names.
+           (args* (filter-map (lambda (arg)
+                                (if (mutable? arg (third x))
+                                    (cons arg (unique-variable))
+                                    (cons arg arg)))
+                              args))
+           ;; Remove shadowed bindings.  If a mutable var is shadowed
+           ;; by another mutable var, it will be added back to the
+           ;; list later.
+           (mutable-vars* (fold (lambda (arg memo)
+                                  (delq arg memo))
+                                mutable-vars
+                                args)))
+      `(lambda ,(map cdr args*)
+         ;; Similar to let, box the values of the renamed args into 1
+         ;; element vectors bound to the original names.
+         (let ,(filter-map (lambda (arg)
+                             (and (not (eq? (car arg) (cdr arg)))
+                                  (list (car arg) `(vector ,(cdr arg)))))
+                           args*)
+           ,(box-mutable-variables (lambda-body x)
+                                   (fold (lambda (arg memo)
+                                           (if (eq? (car arg) (cdr arg))
+                                               memo
+                                               (cons (car arg) memo)))
+                                         mutable-vars*
+                                         args*))))))
+   ((primcall? x)
+    (cons (primcall-op x)
+          (map (lambda (arg)
+                 (box-mutable-variables arg mutable-vars))
+               (primcall-operands x))))
+   ((set? x)
+    ;; Calls to set! are simply transformed to calls to vector-set! to
+    ;; modify the item inside the box.
+    `(vector-set! ,(second x) 0 ,(third x)))
+   ((pair? x)
+    (map (lambda (y)
+           (box-mutable-variables y mutable-vars))
+         x))))
+
 ;; Transforms a quote form into code.
 (define (expand-quote x)
   (cond
@@ -956,7 +1096,8 @@
   (parameterize ((unique-counter 0))
     (mark-tail-calls
      (convert-closures-and-constants
-      (annotate-free-variables x)))))
+      (annotate-free-variables
+       (box-mutable-variables x))))))
 
 
 ;;;
@@ -1080,4 +1221,12 @@
   ;; complex constants
   (test-case '(let ((f (lambda () (quote (1 . "H")))))
               (eq? (f) (f)))
-           "#t"))
+           "#t")
+  ;; mutable variables
+  (test-case '(let ((f (lambda (c)
+                         (cons (lambda (v) (set! c v))
+                               (lambda () c)))))
+                (let ((p (f 0)))
+                  ((car p) 12)
+                  ((cdr p))))
+             "12"))
-- 
cgit v1.2.3