Improve 3.rkt a bit

Final/2.rkt

@@ -288,4 +288,14 @@
             {lam {fX}
                  {body-proc {lam {x} {{fX fX} x}}}}}}})
 
-  (test (run fact-prog) (numV 120)))
+  (test (run fact-prog) (numV 120)))
+
+; stupid tests for coverage
+(module+ test
+  (test/exn (parse-error 'invalid-syntax) "invalid-syntax")
+  (test (parse `(error "test error")) (errorE "test error"))
+  (test/exn (parse `(error 123)) "parse error")
+  (test/exn (parse `(unknown 1 2 3)) "parse error")
+  (test/exn (arith-op + (numV 1) (errorV "not a number")) "expects a number")
+  (test/exn (parse `#f) "parse error"))
+  

Final/3.rkt

@@ -98,55 +98,28 @@
 
 ;; malloc : size -> address
 (define (malloc n . other-roots)
-  (when (> (+ (ptr) n (length other-roots)) (space-size))
+  (when (> (+ (ptr) n) (space-size))
     (gc!))
-  (when (> (+ (ptr) n (length other-roots)) (space-size))
+  (when (> (+ (ptr) n) (space-size))
     (error 'malloc "out of memory!"))
-  (heap-set! LOC:PTR (+ (ptr) n (length other-roots)))
+  (heap-set! LOC:PTR (+ (ptr) n))
-  (+ (heap-ref LOC:OFFSET) (- (ptr) n (length other-roots))))
+  (+ (heap-ref LOC:OFFSET) (- (ptr) n)))
 
 (define (forward/root thing)
   (define addr (read-root thing))
+  (define fwrd (+ 1 addr))
   (cond
-    [(gc:flat? addr) (gc:alloc-flat (gc:deref addr))]
+    [(gc:flat? addr) (heap-set! fwrd (gc:alloc-flat (gc:deref addr)))]
-    [(gc:cons? addr) (gc:cons (gc:first thing) (gc:rest addr))]
+    ; maybe forward root on each cons cell? could fix what seems to be memory corruption
-    [(gc:closure? addr) (gc:closure (gc:closure-code-ptr addr) (empty))]))
+    [(gc:cons? addr) (heap-set! fwrd (gc:cons (simple-root (gc:first addr)) (simple-root (gc:rest addr))))]
-
+    [(gc:closure? addr)
-(define (forward/loc thing)
+     (let ([code-ptr (gc:closure-code-ptr addr)]
-  (define tag (heap-ref thing))
+           [n-vars (heap-ref (+ addr 2))])
-  (cond
+       (heap-set! fwrd
-    [(equal? tag 'forwarded)
+                  (gc:closure code-ptr
-     (void)]
+                              (for/list ([i (in-range n-vars)])
-    [(equal? tag 'flat)
+                                (forward/root (simple-root (gc:closure-env-ref addr i)))))))])
-     (heap-set! thing 'forwarded)
+  (heap-set! addr 'forwarded))
-     (heap-set! (+ thing 1) (gc:alloc-flat (heap-ref (+ thing 1))))]
-    [(equal? tag 'cons)
-     (heap-set! thing 'forwarded)
-     (heap-set! (+ thing 1) (gc:cons
-                             (simple-root (heap-ref (+ thing 1)))
-                             (simple-root (heap-ref (+ thing 2)))))]
-    [(equal? tag 'clos)
-     (let* ([code-ptr (heap-ref (+ thing 1))]
-            [n-vars (heap-ref (+ thing 2))]
-            [free-vars (for/list ([i (in-range n-vars)])
-                         (simple-root (heap-ref (+ thing 3 i))))])
-       (heap-set! thing 'forwarded)
-       (heap-set! (+ thing 1) (gc:closure code-ptr free-vars)))]
-    [else
-     (error 'forward/loc "unknown tag: ~a" tag)]))
-
-
-(define (object-size addr)
-  (define tag (heap-ref addr))
-  (cond
-    [(equal? tag 'flat) 2]
-    [(equal? tag 'cons) 3]
-    [(equal? tag 'clos)
-     (let ([n-vars (+ addr 2)])
-       (+ 3 n-vars))]
-    [(equal? tag 'forwarded) 2]
-    [else
-     (error 'object-size "unknown tag: ~a" tag)]))
 
 (define (gc! . other-roots)
   (swap-spaces!)
@@ -154,13 +127,7 @@
 
   ;; Forward all roots to the new semi-space
   (for-each forward/root (get-root-set))
-  (for-each forward/root other-roots)
+  (for-each forward/root other-roots))
-
-  ;; Forward all objects reachable from the roots
-  (let loop ([scan (off)])
-    (when (< scan (ptr))
-      (forward/loc scan)
-      (loop (+ scan (object-size scan))))))
 
 ;; gc:alloc-flat : flat-value -> address
 (define (gc:alloc-flat value)