convert a couple more modules to record-case

* module/system/base/syntax.scm (record-case): Capture the match macro.

* module/system/il/glil.scm:
* module/system/il/compile.scm: Convert to record-case.

module/system/base/syntax.scm

@@ -183,7 +183,7 @@
     (if (eq? (car clause) 'else)
         clause
         `(($ ,@(car clause)) ,@(cdr clause))))
-  `(match ,record ,@(map process-clause clauses)))
+  `(,match ,record ,@(map process-clause clauses)))
 
 (define (record? x)
   (and (vector? x)

module/system/il/compile.scm

@@ -23,7 +23,6 @@
   :use-syntax (system base syntax)
   :use-module (system il glil)
   :use-module (system il ghil)
-  :use-module (ice-9 match)
   :use-module (ice-9 common-list)
   :export (compile))
 
@@ -37,31 +36,31 @@
 ;;;
 
 (define (optimize x)
-  (match x
+  (record-case x
-    (($ <ghil-set> env var val)
+    ((<ghil-set> env var val)
      (make-ghil-set env var (optimize val)))
 
-    (($ <ghil-if> test then else)
+    ((<ghil-if> test then else)
      (make-ghil-if (optimize test) (optimize then) (optimize else)))
 
-    (($ <ghil-begin> exps)
+    ((<ghil-begin> exps)
      (make-ghil-begin (map optimize exps)))
 
-    (($ <ghil-bind> env vars vals body)
+    ((<ghil-bind> env vars vals body)
      (make-ghil-bind env vars (map optimize vals) (optimize body)))
 
-    (($ <ghil-lambda> env vars rest body)
+    ((<ghil-lambda> env 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 proc args)
-     (match proc
+     (record-case proc
        ;; ((@lambda (VAR...) BODY...) ARG...) =>
        ;;   (@let ((VAR ARG) ...) BODY...)
-       (($ <ghil-lambda> lambda-env vars #f 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)
@@ -135,48 +134,50 @@
 	(return-code! (make-glil-const obj)))
       ;;
       ;; dispatch
-      (match tree
+      (record-case tree
-	(($ <ghil-void>)
+	((<ghil-void>)
 	 (return-void!))
 
-	(($ <ghil-quote> env loc obj)
+	((<ghil-quote> env loc obj)
 	 (return-object! obj))
 
-	(($ <ghil-quasiquote> env loc exp)
+	((<ghil-quasiquote> env loc exp)
 	 (let loop ((x exp))
-	   (match x
+           (cond
-	     ((? list? ls)
+            ((list? x)
-	      (push-call! #f 'mark '())
+             (push-call! #f 'mark '())
-	      (for-each loop ls)
+             (for-each loop x)
-	      (push-call! #f 'list-mark '()))
+             (push-call! #f 'list-mark '()))
-	     ((? pair? pp)
+            ((pair? x)
-	      (loop (car pp))
+             (loop (car x))
-	      (loop (cdr pp))
+             (loop (cdr x))
-	      (push-code! (make-glil-call 'cons 2)))
+             (push-code! (make-glil-call 'cons 2)))
-	     (($ <ghil-unquote> env loc exp)
+            ((record? x)
-	      (comp-push exp))
+             (record-case x
-	     (($ <ghil-unquote-splicing> env loc exp)
+              ((<ghil-unquote> env loc exp)
-	      (comp-push exp)
+               (comp-push exp))
-	      (push-call! #f 'list-break '()))
+              ((<ghil-unquote-splicing> env loc exp)
-	     (else
+               (comp-push exp)
-	      (push-code! (make-glil-const x)))))
+               (push-call! #f 'list-break '()))))
+            (else
+             (push-code! (make-glil-const x)))))
 	 (maybe-drop)
 	 (maybe-return))
 
-	(($ <ghil-ref> env loc var)
+	((<ghil-ref> env loc var)
 	 (return-code! (make-glil-var 'ref env var)))
 
-	(($ <ghil-set> env loc var val)
+	((<ghil-set> env loc var val)
 	 (comp-push val)
 	 (push-code! (make-glil-var 'set env var))
 	 (return-void!))
 
-	(($ <ghil-define> env loc var val)
+	((<ghil-define> env loc var val)
 	 (comp-push val)
 	 (push-code! (make-glil-var 'set env var))
 	 (return-void!))
 
-	(($ <ghil-if> env loc test then else)
+	((<ghil-if> env loc test then else)
 	 ;;     TEST
 	 ;;     (br-if-not L1)
 	 ;;     THEN
@@ -192,7 +193,7 @@
 	   (comp-tail else)
 	   (if (not tail) (push-label! L2))))
 
-	(($ <ghil-and> env loc exps)
+	((<ghil-and> env loc exps)
 	 ;;     EXP
 	 ;;     (br-if-not L1)
 	 ;;     ...
@@ -215,7 +216,7 @@
 		 (comp-push (car exps))
 		 (push-branch! 'br-if-not L1)))))
 
-	(($ <ghil-or> env loc exps)
+	((<ghil-or> env loc exps)
 	 ;;     EXP
 	 ;;     (dup)
 	 ;;     (br-if L1)
@@ -237,7 +238,7 @@
 		 (push-branch! 'br-if L1)
 		 (push-call! #f 'drop '())))))
 
-	(($ <ghil-begin> env loc exps)
+	((<ghil-begin> env loc exps)
 	 ;; EXPS...
 	 ;; TAIL
 	 (if (null? exps)
@@ -247,7 +248,7 @@
 		  (comp-tail (car exps)))
 	       (comp-drop (car exps)))))
 
-	(($ <ghil-bind> env loc vars vals body)
+	((<ghil-bind> env loc vars vals body)
 	 ;; VALS...
 	 ;; (set VARS)...
 	 ;; BODY
@@ -259,17 +260,17 @@
 	 (comp-tail body)
 	 (push-code! (make-glil-unbind)))
 
-	(($ <ghil-lambda> env loc vars rest body)
+	((<ghil-lambda> env loc vars rest body)
 	 (return-code! (codegen tree)))
 
-	(($ <ghil-inline> env loc inst args)
+	((<ghil-inline> env loc inst args)
 	 ;; ARGS...
 	 ;; (INST NARGS)
 	 (push-call! loc inst args)
 	 (maybe-drop)
 	 (maybe-return))
 
-	(($ <ghil-call> env loc proc args)
+	((<ghil-call> env loc proc args)
 	 ;; PROC
 	 ;; ARGS...
 	 ;; ([tail-]call NARGS)
@@ -278,8 +279,8 @@
 	 (maybe-drop))))
     ;;
     ;; main
-    (match ghil
+    (record-case ghil
-      (($ <ghil-lambda> env loc args rest body)
+      ((<ghil-lambda> env loc args rest body)
        (let* ((vars env.variables)
 	      (locs (pick (lambda (v) (eq? v.kind 'local)) vars))
 	      (exts (pick (lambda (v) (eq? v.kind 'external)) vars)))

module/system/il/glil.scm

@@ -21,7 +21,6 @@
 
 (define-module (system il glil)
   :use-syntax (system base syntax)
-  :use-module (ice-9 match)
   :export
   (pprint-glil
    <glil-vars> make-glil-vars
@@ -143,30 +142,30 @@
 ;;;
 
 (define (unparse glil)
-  (match glil
+  (record-case glil
     ;; meta
-    (($ <glil-asm> vars body)
+    ((<glil-asm> vars body)
      `(@asm (,vars.nargs ,vars.nrest ,vars.nlocs ,vars.nexts)
 	    ,@(map unparse body)))
-    (($ <glil-bind> vars) `(@bind ,@vars))
+    ((<glil-bind> vars) `(@bind ,@vars))
-    (($ <glil-unbind>) `(@unbind))
+    ((<glil-unbind>) `(@unbind))
-    (($ <glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
+    ((<glil-source> loc) `(@source ,(car loc) ,(cdr loc)))
     ;; constants
-    (($ <glil-void>) `(void))
+    ((<glil-void>) `(void))
-    (($ <glil-const> obj) `(const ,obj))
+    ((<glil-const> obj) `(const ,obj))
     ;; variables
-    (($ <glil-argument> op index)
+    ((<glil-argument> op index)
      `(,(symbol-append 'argument- op) ,index))
-    (($ <glil-local> op index)
+    ((<glil-local> op index)
      `(,(symbol-append 'local- op) ,index))
-    (($ <glil-external> op depth index)
+    ((<glil-external> op depth index)
      `(,(symbol-append 'external- op) ,depth ,index))
-    (($ <glil-module> op module name)
+    ((<glil-module> op module name)
      `(,(symbol-append 'module- op) ,module ,name))
     ;; controls
-    (($ <glil-label> label) label)
+    ((<glil-label> label) label)
-    (($ <glil-branch> inst label) `(,inst ,label))
+    ((<glil-branch> inst label) `(,inst ,label))
-    (($ <glil-call> inst nargs) `(,inst ,nargs))))
+    ((<glil-call> inst nargs) `(,inst ,nargs))))
 
 
 ;;;