Replace ice-9 match's structures with guile's records

* module/system/base/syntax.scm (define-record): Rebase to implement on
  top of Guile's records, which are the substrate of srfi-9's records.
  (%compute-initargs): Rename from %make-struct, just return the list of
  values.
  (get-slot, set-slot!, slot): Removed, no longer used.
  (record-case): Allow slots of the form (MYNAME SLOTNAME), which binds
  SLOTNAME to MYNAME (instead of SLOTNAME to SLOTNAME).
  (record-case, record?): No more ice-9 match!

* module/system/il/compile.scm (codegen): Tweaks so that the new record
  code works.

* module/system/il/ghil.scm: Fix some slot references.

* module/system/vm/assemble.scm (preprocess, codegen): Remove calls to
  `slot'.
  (codegen): Fix some slot references.

diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index 6b9f9ea..0c259e0 100644 (file)
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -53,8 +53,12 @@
 
 (define-macro (define-record def)
   (let* ((name (car def)) (slots (cdr def))
-         (stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
+         (slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
+                          slots))
+         (stem (symbol-trim-both name (list->char-set '(#\< #\>))))
+         (type (make-record-type (symbol->string name) slot-names)))
     `(begin
+       (define ,name ,type)
        (define ,(symbol-append 'make- stem)
          (let ((slots (list ,@(map (lambda (slot)
                                      (if (pair? slot)
@@ -62,36 +66,28 @@
                                          `',slot))
                                    slots))))
            (lambda args
-             (vector ',name (%make-struct args slots)))))
-       (define (,(symbol-append name '?) x)
-        (and (vector? x) (eq? (vector-ref x 0) ',name)))
-       ,@(do ((n 1 (1+ n))
-             (slots (cdr def) (cdr slots))
-             (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 ',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))))))
-
-(define (%make-struct args slots)
-  (define (finish-bindings out)
+             (apply ,(record-constructor type)
+                    (,%compute-initargs args slots)))))
+       (define ,(symbol-append name '?) ,(record-predicate type))
+       ,@(map (lambda (sname)
+                `(define ,(symbol-append stem '- sname)
+                   ,(make-procedure-with-setter
+                     (record-accessor type sname)
+                     (record-modifier type sname))))
+              slot-names))))
+
+(define (%compute-initargs args slots)
+  (define (finish out)
     (map (lambda (slot)
            (let ((name (if (pair? slot) (car slot) slot)))
-             (or (assq name out)
-                 (if (pair? slot)
-                     (cons name (cdr slot))
-                     (error "unbound slot" args slots name)))))
+             (cond ((assq name out) => cdr)
+                   ((pair? slot) (cdr slot))
+                   (else (error "unbound slot" args slots name)))))
          slots))
   (let lp ((in args) (positional slots) (out '()))
     (cond
      ((null? in)
-      (finish-bindings out))
+      (finish out))
      ((keyword? (car in))
       (let ((sym (keyword->symbol (car in))))
         (cond
@@ -106,21 +102,6 @@
       (lp (cdr in) (cdr positional)
           (acons (car positional) (car in) out))))))
 
-(define (get-slot struct name . names)
-  (let ((data (assq name (vector-ref struct 1))))
-    (cond ((not data) (error "unknown slot" name))
-          ((null? names) (cdr data))
-          (else (apply get-slot (cdr data) names)))))
-
-(define (set-slot! struct name . rest)
-  (let ((data (assq name (vector-ref struct 1))))
-    (cond ((not data) (error "unknown slot" name))
-          ((null? (cdr rest)) (set-cdr! data (car rest)))
-          (else (apply set-slot! (cdr data) rest)))))
-
-(define slot
-  (make-procedure-with-setter get-slot set-slot!))
-
 \f
 ;;;
 ;;; Variants
@@ -142,33 +123,23 @@
 (define-macro (record-case record . clauses)
   (let ((r (gensym)))
     (define (process-clause clause)
-      (let ((record-type (caar clause))
-            (slots (cdar clause))
-            (body (cdr clause)))
-        `(((record-predicate ,record-type) ,r)
-          (let ,(map (lambda (slot)
-                       `(,slot ((record-accessor ,record-type ',slot) ,r)))
-                     slots)
-            ,@body))))
+      (if (eq? (car clause) 'else)
+          clause
+          (let ((record-type (caar clause))
+                (slots (cdar clause))
+                (body (cdr clause)))
+            `(((record-predicate ,record-type) ,r)
+              (let ,(map (lambda (slot)
+                           (if (pair? slot)
+                               `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+                               `(,slot ((record-accessor ,record-type ',slot) ,r))))
+                         slots)
+                ,@body)))))
     `(let ((,r ,record))
-       (cond ,@(map process-clause clauses)
-             (else (error "unhandled record" ,r))))))
-
-;; These are short-lived, and headed to the chopping block.
-(use-modules (ice-9 match))
-(define-macro (record-case record . clauses)
-  (define (process-clause clause)
-    (if (eq? (car clause) 'else)
-        clause
-        `(($ ,@(car clause)) ,@(cdr clause))))
-  `(,match ,record ,@(map process-clause clauses)))
-
-(define (record? x)
-  (and (vector? x)
-       (not (zero? (vector-length x)))
-       (symbol? (vector-ref x 0))
-       (eqv? (string-ref (symbol->string (vector-ref x 0)) 0) #\<)))
-(export record?)
+       (cond ,@(let ((clauses (map process-clause clauses)))
+                 (if (assq 'else clauses)
+                     clauses
+                     (append clauses `((else (error "unhandled record" ,r))))))))))
 
 \f
 ;;;

diff --git a/module/system/il/compile.scm b/module/system/il/compile.scm
index 04b0671..5056ab7 100644 (file)
--- a/module/system/il/compile.scm
+++ b/module/system/il/compile.scm
@@ -276,10 +276,10 @@
        ((<ghil-lambda> env loc vars rest body)
         (return-code! (codegen tree)))
 
-       ((<ghil-inline> env loc inst args)
+       ((<ghil-inline> env loc inline args)
         ;; ARGS...
         ;; (INST NARGS)
-        (push-call! loc inst args)
+        (push-call! loc inline args)
         (maybe-drop)
         (maybe-return))
 
@@ -293,19 +293,19 @@
     ;;
     ;; main
     (record-case ghil
-      ((<ghil-lambda> env loc args rest body)
-       (let* ((vars (ghil-env-variables env))
-             (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) vars))
-             (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) vars)))
+      ((<ghil-lambda> env loc vars rest body)
+       (let* ((evars (ghil-env-variables env))
+             (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
+             (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
         ;; initialize variable indexes
-        (finalize-index! args)
+        (finalize-index! vars)
         (finalize-index! locs)
         (finalize-index! exts)
         ;; meta bindings
-         (push-bindings! args)
+         (push-bindings! vars)
         ;; export arguments
         (do ((n 0 (1+ n))
-             (l args (cdr l)))
+             (l vars (cdr l)))
             ((null? l))
           (let ((v (car l)))
             (case (ghil-var-kind v)
@@ -315,7 +315,7 @@
         ;; compile body
         (comp body #t #f)
         ;; create GLIL
-        (let ((vars (make-glil-vars :nargs (length args)
+        (let ((vars (make-glil-vars :nargs (length vars)
                                      :nrest (if rest 1 0)
                                      :nlocs (length locs)
                                      :nexts (length exts))))

diff --git a/module/system/il/ghil.scm b/module/system/il/ghil.scm
index 26eaad0..e825469 100644 (file)
--- a/module/system/il/ghil.scm
+++ b/module/system/il/ghil.scm
@@ -155,7 +155,7 @@
 (define-public (make-ghil-env e)
   (record-case e
     ((<ghil-mod>) (%make-ghil-env :mod e :parent e))
-    ((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
+    ((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
 
 (define (ghil-env-toplevel? e)
   (eq? (ghil-env-mod e) (gil-env-parent e)))

diff --git a/module/system/vm/assemble.scm b/module/system/vm/assemble.scm
index 77e695d..9d9a0e8 100644 (file)
--- a/module/system/vm/assemble.scm
+++ b/module/system/vm/assemble.scm
@@ -54,14 +54,14 @@
 (define (preprocess x e)
   (record-case x
     ((<glil-asm> vars body)
-     (let* ((venv (make-venv :parent e :nexts (slot vars 'nexts) :closure? #f))
+     (let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
            (body (map (lambda (x) (preprocess x venv)) body)))
        (make-vm-asm :venv venv :glil x :body body)))
     ((<glil-external> op depth index)
      (do ((d depth (- d 1))
-         (e e (slot e 'parent)))
+         (e e (venv-parent e)))
         ((= d 0))
-       (set! (slot e 'closure?) #t))
+       (set! (venv-closure? e) #t))
      x)
     (else x)))
 
@@ -100,9 +100,9 @@
         (record-case x
           ((<vm-asm> venv)
            (push-object! (codegen x #f))
-           (if (slot venv 'closure?) (push-code! `(make-closure))))
+           (if (venv-closure? venv) (push-code! `(make-closure))))
 
-          ((<glil-bind> binds)
+          ((<glil-bind> (binds vars))
            (let ((bindings
                   (map (lambda (v)
                          (let ((name (car v)) (type (cadr v)) (i (caddr v)))
@@ -123,8 +123,8 @@
           ((<glil-void>)
            (push-code! '(void)))
 
-          ((<glil-const> x)
-           (push-object! x))
+          ((<glil-const> obj)
+           (push-object! obj))
 
           ((<glil-argument> op index)
            (if (eq? op 'ref)