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
  cb4cca12e719edfef1740f238d9187c21c8e1e35. 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.

diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 27baa55..672fa21 100644 (file)
--- a/module/system/base/syntax.scm
+++ b/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))
-                                     (slot (if (pair? slot) (car slot) slot)))
+             (ls '() (append (let* ((sdef (car slots))
+                                     (sname (if (pair? sdef) (car sdef) sdef)))
                                 `((define ,(string->symbol
                                             (format #f "~A-~A" name n))
-                                    (lambda (x) (slot x ',slot)))
-                                  (define ,(symbol-append stem '- slot)
-                                    (lambda (x) (slot x ',slot)))))
+                                    (lambda (x) (slot x ',sname)))
+                                  (define ,(symbol-append stem '- sname)
+                                    ,(make-procedure-with-setter
+                                      (lambda (x) (get-slot x sname))
+                                      (lambda (x v) (set-slot! x sname v))))))
                               ls)))
             ((null? slots) (reverse! ls))))))
 

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 43b5d6c..3e134a0 100644 (file)
--- a/module/system/il/compile.scm
+++ b/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)
-     (record-case proc
-       ;; ((@lambda (VAR...) BODY...) ARG...) =>
-       ;;   (@let ((VAR ARG) ...) BODY...)
-       ((<ghil-lambda> lambda-env vars #f body)
-       (for-each (lambda (v)
-                   (if (eq? v.kind 'argument) (set! v.kind 'local))
-                   (set! v.env env)
-                   (ghil-env-add! env v))
-                 lambda-env.variables)
-       (optimize (make-ghil-bind env vars args body)))
-       (else
-       (make-ghil-call env (optimize proc) (map optimize args)))))
+    ((<ghil-call> env loc proc args)
+     (let ((parent-env env))
+       (record-case proc
+         ;; ((@lambda (VAR...) BODY...) ARG...) =>
+         ;;   (@let ((VAR ARG) ...) BODY...)
+         ((<ghil-lambda> env loc vars rest body)
+          (cond
+           ((not rest)
+            (for-each (lambda (v)
+                        (case (ghil-var-kind v)
+                          ((argument) (set! (ghil-var-kind v) 'local)))
+                        (set! (ghil-var-env v) parent-env)
+                        (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)))
 
 \f

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 5b42c63..408b917 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/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))
-  (set! env.variables (cons var env.variables)))
+  (apush! (ghil-var-name var) var (ghil-env-table env))
+  (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)))
 
 \f
 ;;;
 ;;; 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))
-       (cond ((<ghil-mod>? e)
-              (or (assq-ref e.table sym)
-                  (let ((var (make-ghil-var #f sym 'module)))
-                    (set! e.table (acons sym var e.table))
-                    var)))
-             ((ghil-env-ref e sym) =>
-              (lambda (var) (set! var.kind 'external) var))
-             (else (loop e.parent))))))
+      (let loop ((e (ghil-env-parent env)))
+        (record-case e
+          ((<ghil-mod> module table imports)
+           (or (assq-ref table sym)
+               (let ((var (make-ghil-var #f sym 'module)))
+                 (apush! sym var (ghil-mod-table e))
+                 var)))
+          ((<ghil-env> mod parent table variables)
+           (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))

diff --git a/module/system/il/glil.scm b/module/system/il/glil.scm
index 33c44b1..a83535b 100644 (file)
--- a/module/system/il/glil.scm
+++ b/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))

diff --git a/module/system/vm/debug.scm b/module/system/vm/debug.scm
index 686d897..cf72df3 100644 (file)
--- a/module/system/vm/debug.scm
+++ b/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))))))