procedures-with-setters, debitrot `optimize', dedottification

* module/system/base/syntax.scm (define-record): Define the accessors as
  procedures-with-setters, not just as getters.

* module/system/il/compile.scm (optimize): This function was bitrotten
  since the addition of source locations in
  cb4cca12e7. Untested attempts to
  de-bitrot it. Dedottify as well.

* module/system/il/ghil.scm:
* module/system/il/glil.scm (unparse):
* module/system/vm/debug.scm (debugger-repl): Ongoing dedottification.

module/system/base/syntax.scm

@@ -93,13 +93,15 @@
 	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
        ,@(do ((n 1 (1+ n))
 	      (slots (cdr def) (cdr slots))
-	      (ls '() (append (let* ((slot (car slots))
+	      (ls '() (append (let* ((sdef (car slots))
-                                     (slot (if (pair? slot) (car slot) slot)))
+                                     (sname (if (pair? sdef) (car sdef) sdef)))
                                 `((define ,(string->symbol
                                             (format #f "~A-~A" name n))
-                                    (lambda (x) (slot x ',slot)))
+                                    (lambda (x) (slot x ',sname)))
-                                  (define ,(symbol-append stem '- slot)
+                                  (define ,(symbol-append stem '- sname)
-                                    (lambda (x) (slot x ',slot)))))
+                                    ,(make-procedure-with-setter
+                                      (lambda (x) (get-slot x sname))
+                                      (lambda (x v) (set-slot! x sname v))))))
                               ls)))
 	     ((null? slots) (reverse! ls))))))
 

module/system/il/compile.scm

@@ -37,38 +37,44 @@
 
 (define (optimize x)
   (record-case x
-    ((<ghil-set> env var val)
+    ((<ghil-set> env loc var val)
      (make-ghil-set env var (optimize val)))
 
-    ((<ghil-if> test then else)
+    ((<ghil-if> env loc test then else)
      (make-ghil-if (optimize test) (optimize then) (optimize else)))
 
-    ((<ghil-begin> exps)
+    ((<ghil-begin> env loc exps)
      (make-ghil-begin (map optimize exps)))
 
-    ((<ghil-bind> env vars vals body)
+    ((<ghil-bind> env loc vars vals body)
      (make-ghil-bind env vars (map optimize vals) (optimize body)))
 
-    ((<ghil-lambda> env vars rest body)
+    ((<ghil-lambda> env loc vars rest body)
      (make-ghil-lambda env vars rest (optimize body)))
 
 ;; FIXME:  <ghil-inst> does not exist.  -- Ludo'.
 ;     (($ <ghil-inst> inst args)
 ;      (make-ghil-inst inst (map optimize args)))
 
-    ((<ghil-call> env proc args)
+    ((<ghil-call> env loc proc args)
-     (record-case proc
+     (let ((parent-env env))
-       ;; ((@lambda (VAR...) BODY...) ARG...) =>
+       (record-case proc
-       ;;   (@let ((VAR ARG) ...) BODY...)
+         ;; ((@lambda (VAR...) BODY...) ARG...) =>
-       ((<ghil-lambda> lambda-env vars #f body)
+         ;;   (@let ((VAR ARG) ...) BODY...)
-	(for-each (lambda (v)
+         ((<ghil-lambda> env loc vars rest body)
-		    (if (eq? v.kind 'argument) (set! v.kind 'local))
+          (cond
-		    (set! v.env env)
+           ((not rest)
-		    (ghil-env-add! env v))
+            (for-each (lambda (v)
-		  lambda-env.variables)
+                        (case (ghil-var-kind v)
-	(optimize (make-ghil-bind env vars args body)))
+                          ((argument) (set! (ghil-var-kind v) 'local)))
-       (else
+                        (set! (ghil-var-env v) parent-env)
-	(make-ghil-call env (optimize proc) (map optimize args)))))
+                        (ghil-env-add! parent-env v))
+                      (ghil-env-variables env)))
+           (else
+            (make-ghil-call parent-env (optimize proc) (map optimize args)))))
+         (else
+          (make-ghil-call parent-env (optimize proc) (map optimize args))))))
+
     (else x)))
 
 

module/system/il/ghil.scm

@@ -61,7 +61,6 @@
    ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
    <ghil-lambda> make-ghil-lambda <ghil-lambda>? <ghil-lambda>-1 <ghil-lambda>-2
    <ghil-lambda>-3 <ghil-lambda>-4 <ghil-lambda>-5
-   ghil-bind-env ghil-bind-loc ghil-bind-vars ghil-bind-vals ghil-bind-body
    ghil-lambda-env ghil-lambda-loc ghil-lambda-vars ghil-lambda-rest ghil-lambda-body
    <ghil-inline> make-ghil-inline <ghil-inline>?
    <ghil-inline>-1 <ghil-inline>-2 <ghil-inline>-3 <ghil-inline>-4
@@ -152,34 +151,45 @@
     ((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
 
 (define (ghil-env-toplevel? e)
-  (eq? e.mod e.parent))
+  (eq? (ghil-env-mod e) (gil-env-parent e)))
 
 (define (ghil-env-ref env sym)
-  (assq-ref env.table sym))
+  (assq-ref (ghil-env-table env) sym))
+
+(define-macro (push! item loc)
+  `(set! ,loc (cons ,item ,loc)))
+(define-macro (apush! k v loc)
+  `(set! ,loc (acons ,k ,v ,loc)))
+(define-macro (apopq! k loc)
+  `(set! ,loc (assq-remove! ,k ,loc)))
 
 (define-public (ghil-env-add! env var)
-  (set! env.table (acons var.name var env.table))
+  (apush! (ghil-var-name var) var (ghil-env-table env))
-  (set! env.variables (cons var env.variables)))
+  (push! var (ghil-env-variables env)))
 
 (define (ghil-env-remove! env var)
-  (set! env.table (assq-remove! env.table var.name)))
+  (apopq! (ghil-var-name var) (ghil-env-table env)))
 
 
 ;;;
 ;;; Public interface
 ;;;
 
+;; looking up a var has side effects?
 (define-public (ghil-lookup env sym)
   (or (ghil-env-ref env sym)
-      (let loop ((e env.parent))
+      (let loop ((e (ghil-env-parent env)))
-	(cond ((<ghil-mod>? e)
+        (record-case e
-	       (or (assq-ref e.table sym)
+          ((<ghil-mod> module table imports)
-		   (let ((var (make-ghil-var #f sym 'module)))
+           (or (assq-ref table sym)
-		     (set! e.table (acons sym var e.table))
+               (let ((var (make-ghil-var #f sym 'module)))
-		     var)))
+                 (apush! sym var (ghil-mod-table e))
-	      ((ghil-env-ref e sym) =>
+                 var)))
-	       (lambda (var) (set! var.kind 'external) var))
+          ((<ghil-env> mod parent table variables)
-	      (else (loop e.parent))))))
+           (let ((found (assq-ref table sym)))
+             (if found
+                 (begin (set! (ghil-var-kind found) 'external) found)
+                 (loop parent))))))))
 
 (define-public (call-with-ghil-environment e syms func)
   (let* ((e (make-ghil-env e))

module/system/il/glil.scm

@@ -157,7 +157,8 @@
   (record-case glil
     ;; meta
     ((<glil-asm> vars body)
-     `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
+     `(@asm (,(glil-vars-nargs vars) ,(glil-vars-nrest vars)
+             ,(glil-vars-nlocs vars) ,(glil-vars-nexts vars))
 	    ,@(map unparse body)))
     ((<glil-bind> vars) `(@bind ,@vars))
     ((<glil-unbind>) `(@unbind))

module/system/vm/debug.scm

@@ -46,9 +46,9 @@
     (display "debug> ")
     (let ((cmd (read)))
       (case cmd
-	((bt) (vm-backtrace db.vm))
+	((bt) (vm-backtrace (debugger-vm db)))
 	((stack)
-	 (write (vm-fetch-stack db.vm))
+	 (write (vm-fetch-stack (debugger-vm db)))
 	 (newline))
 	(else
 	 (format #t "Unknown command: ~A" cmd))))))