Convert assemble.scm to use record-case.

* module/system/base/syntax.scm (record?): Temporarily export this thing,
  so that code will remain correct when I change to srfi-9 records.

* module/system/vm/assemble.scm: Convert to use record-case.

module/system/base/syntax.scm

@@ -175,11 +175,21 @@
        (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)
-    `(($ ,@(car clause)) ,@(cdr clause)))
+    (if (eq? (car clause) 'else)
-  `(match ,record ,(map process-clause clauses)))
+        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/vm/assemble.scm

@@ -53,12 +53,12 @@
 ;;;
 
 (define (preprocess x e)
-  (match x
+  (record-case x
-    (($ <glil-asm> vars body)
+    ((<glil-asm> vars body)
      (let* ((venv (<venv> :parent e :nexts (slot vars 'nexts) :closure? #f))
 	    (body (map (lambda (x) (preprocess x venv)) body)))
        (<vm-asm> :venv venv :glil x :body body)))
-    (($ <glil-external> op depth index)
+    ((<glil-external> op depth index)
      (do ((d depth (- d 1))
  	  (e e (slot e 'parent)))
  	 ((= d 0))
@@ -72,8 +72,8 @@
 ;;;
 
 (define (codegen glil toplevel)
-  (match glil
+  (record-case glil
-    (($ <vm-asm> venv ($ <glil-asm> vars _) body)
+    ((<vm-asm> venv glil body) (record-case glil ((<glil-asm> vars)
      (let ((stack '())
 	   (binding-alist '())
 	   (source-alist '())
@@ -98,12 +98,12 @@
 		 (else 3)))
 	 (apply + (map byte-length stack)))
        (define (generate-code x)
-	 (match x
+	 (record-case x
-	   (($ <vm-asm> venv)
+	   ((<vm-asm> venv)
 	    (push-object! (codegen x #f))
 	    (if (slot venv 'closure?) (push-code! `(make-closure))))
 
-	   (($ <glil-bind> binds)
+	   ((<glil-bind> binds)
 	    (let ((bindings
 		   (map (lambda (v)
 			  (let ((name (car v)) (type (cadr v)) (i (caddr v)))
@@ -115,29 +115,29 @@
 	      (set! binding-alist
 		    (acons (current-address) bindings binding-alist))))
 
-	   (($ <glil-unbind>)
+	   ((<glil-unbind>)
 	    (set! binding-alist (acons (current-address) #f binding-alist)))
 
-	   (($ <glil-source> loc)
+	   ((<glil-source> loc)
 	    (set! source-alist (acons (current-address) loc source-alist)))
 
-	   (($ <glil-void>)
+	   ((<glil-void>)
 	    (push-code! '(void)))
 
-	   (($ <glil-const> x)
+	   ((<glil-const> x)
 	    (push-object! x))
 
-	   (($ <glil-argument> op index)
+	   ((<glil-argument> op index)
 	    (if (eq? op 'ref)
 		(push-code! `(local-ref ,index))
 		(push-code! `(local-set ,index))))
 
-	   (($ <glil-local> op index)
+	   ((<glil-local> op index)
 	    (if (eq? op 'ref)
 		(push-code! `(local-ref ,(+ vars.nargs index)))
 		(push-code! `(local-set ,(+ vars.nargs index)))))
 
-	   (($ <glil-external> op depth index)
+	   ((<glil-external> op depth index)
 	    (do ((e venv e.parent)
 		 (d depth (1- d))
 		 (n 0 (+ n e.nexts)))
@@ -146,19 +146,19 @@
 		     (push-code! `(external-ref ,(+ n index)))
 		     (push-code! `(external-set ,(+ n index)))))))
 
-	   (($ <glil-module> op module name)
+	   ((<glil-module> op module name)
 	    (push-object! (<vlink> :module #f :name name))
 	    (if (eq? op 'ref)
 		(push-code! '(variable-ref))
 		(push-code! '(variable-set))))
 
-	   (($ <glil-label> label)
+	   ((<glil-label> label)
 	    (set! label-alist (assq-set! label-alist label (current-address))))
 
-	   (($ <glil-branch> inst label)
+	   ((<glil-branch> inst label)
 	    (set! stack (cons (list inst label) stack)))
 
-	   (($ <glil-call> inst nargs)
+	   ((<glil-call> inst nargs)
 	    (if (instruction? inst)
 		(let ((pops (instruction-pops inst)))
 		  (cond ((< pops 0)
@@ -183,11 +183,11 @@
 				       (reverse! source-alist)))
 			 :objs (let ((objs (map car (reverse! object-alist))))
 				 (if (null? objs) #f (list->vector objs)))
-			 :closure? venv.closure?)))))))
+			 :closure? venv.closure?)))))))))
 
 (define (object-assoc x alist)
-  (match x
+  (record-case x
-    (($ <vlink>) (assoc x alist))
+    ((<vlink>) (assoc x alist))
     (else        (assq x alist))))
 
 (define (stack->bytes stack label-alist)
@@ -222,9 +222,9 @@
   (let dump! ((x x))
     (cond
      ((object->code x) => push-code!)
-     (else
+     ((record? x)
-      (match x
+      (record-case x
-	(($ <bytespec> vars bytes meta objs closure?)
+	((<bytespec> vars bytes meta objs closure?)
 	 ;; dump parameters
 	 (let ((nargs vars.nargs) (nrest vars.nrest)
 	       (nlocs vars.nlocs) (nexts vars.nexts))
@@ -250,39 +250,41 @@
 	 (if meta (dump! meta))
 	 ;; dump bytecode
 	 (push-code! `(load-program ,bytes)))
-	(($ <vlink> module name)
+	((<vlink> module name)
 	 ;; FIXME: dump module
 	 (push-code! `(link ,(symbol->string name))))
-	(($ <vmod> id)
+	((<vmod> id)
 	 (push-code! `(load-module ,id)))
-	((and ($ integer) ($ exact))
+        (else
-	 (let ((str (do ((n x (quotient n 256))
+         (error "assemble: unknown record type"))))
-			 (l '() (cons (modulo n 256) l)))
+     ((and (integer? x) (exact? x))
-			((= n 0)
+      (let ((str (do ((n x (quotient n 256))
-			 (apply u8vector l)))))
+                      (l '() (cons (modulo n 256) l)))
-	   (push-code! `(load-integer ,str))))
+                     ((= n 0)
-	(($ number)
+                      (apply u8vector l)))))
-	 (push-code! `(load-number ,(number->string x))))
+        (push-code! `(load-integer ,str))))
-	(($ string)
+     ((number? x)
-	 (push-code! `(load-string ,x)))
+      (push-code! `(load-number ,(number->string x))))
-	(($ symbol)
+     ((string? x)
-	 (push-code! `(load-symbol ,(symbol->string x))))
+      (push-code! `(load-string ,x)))
-	(($ keyword)
+     ((symbol? x)
-	 (push-code! `(load-keyword
+      (push-code! `(load-symbol ,(symbol->string x))))
-		       ,(symbol->string (keyword-dash-symbol x)))))
+     ((keyword? x)
-	(($ list)
+      (push-code! `(load-keyword
-	 (for-each dump! x)
+                    ,(symbol->string (keyword-dash-symbol x)))))
-	 (let ((len (length x)))
+     ((list? x)
-	   (if (>= len 65536) (too-long 'list))
+      (for-each dump! x)
-	   (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
+      (let ((len (length x)))
-	(($ pair)
+        (if (>= len 65536) (too-long 'list))
-	 (dump! (car x))
+        (push-code! `(list ,(quotient len 256) ,(modulo len 256)))))
-	 (dump! (cdr x))
+     ((pair? x)
-	 (push-code! `(cons)))
+      (dump! (car x))
-	(($ vector)
+      (dump! (cdr x))
-	 (for-each dump! (vector->list x))
+      (push-code! `(cons)))
-	 (let ((len (vector-length x)))
+     ((vector? x)
-	   (if (>= len 65536) (too-long 'vector))
+      (for-each dump! (vector->list x))
-	   (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
+      (let ((len (vector-length x)))
-	(else
+        (if (>= len 65536) (too-long 'vector))
-	 (error "assemble: unrecognized object" x)))))))
+        (push-code! `(vector ,(quotient len 256) ,(modulo len 256)))))
+     (else
+      (error "assemble: unrecognized object" x)))))