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.

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)))))
+             (apply ,(record-constructor type)
-       (define (,(symbol-append name '?) x)
+                    (,%compute-initargs args slots)))))
-	 (and (vector? x) (eq? (vector-ref x 0) ',name)))
+       (define ,(symbol-append name '?) ,(record-predicate type))
-       ,@(do ((n 1 (1+ n))
+       ,@(map (lambda (sname)
-	      (slots (cdr def) (cdr slots))
+                `(define ,(symbol-append stem '- sname)
-	      (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))
+                     (record-accessor type sname)
-                                      (lambda (x v) (set-slot! x sname v))))))
+                     (record-modifier type sname))))
-                              ls)))
+              slot-names))))
-	     ((null? slots) (reverse! ls))))))
 
-(define (%make-struct args slots)
+(define (%compute-initargs args slots)
-  (define (finish-bindings out)
+  (define (finish out)
     (map (lambda (slot)
            (let ((name (if (pair? slot) (car slot) slot)))
-             (or (assq name out)
+             (cond ((assq name out) => cdr)
-                 (if (pair? slot)
+                   ((pair? slot) (cdr slot))
-                     (cons name (cdr slot))
+                   (else (error "unbound slot" args slots name)))))
-                     (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!))
-
 
 ;;;
 ;;; Variants
@@ -142,33 +123,23 @@
 (define-macro (record-case record . clauses)
   (let ((r (gensym)))
     (define (process-clause clause)
+      (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)
-                       `(,slot ((record-accessor ,record-type ',slot) ,r)))
+                           (if (pair? slot)
+                               `(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
+                               `(,slot ((record-accessor ,record-type ',slot) ,r))))
                          slots)
-            ,@body))))
+                ,@body)))))
     `(let ((,r ,record))
-       (cond ,@(map process-clause clauses)
+       (cond ,@(let ((clauses (map process-clause clauses)))
-             (else (error "unhandled record" ,r))))))
+                 (if (assq 'else clauses)
-
+                     clauses
-;; These are short-lived, and headed to the chopping block.
+                     (append clauses `((else (error "unhandled record" ,r))))))))))
-(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?)
 
 
 ;;;

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)
+      ((<ghil-lambda> env loc vars rest body)
-       (let* ((vars (ghil-env-variables env))
+       (let* ((evars (ghil-env-variables env))
-	      (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) vars))
+	      (locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
-	      (exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) vars)))
+	      (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))))

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)))

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)
+	   ((<glil-const> obj)
-	    (push-object! x))
+	    (push-object! obj))
 
 	   ((<glil-argument> op index)
 	    (if (eq? op 'ref)