start using pmatch instead of match

* module/system/base/Makefile.am: Add pmatch.scm.

* module/system/base/pmatch.scm: New file, taken from Dan Friedman's
  alpha-kanren paper. Implements a less magical match syntax, pmatch.

* module/system/vm/assemble.scm: No more need for (ice-9 match).

* module/system/vm/conv.scm (code-pack, code->object): Change to use
  pmatch.

module/system/base/Makefile.am

@@ -1,4 +1,4 @@
-SOURCES = compile.scm language.scm
+SOURCES = compile.scm language.scm pmatch.scm
 ## syntax.scm
 GOBJECTS = $(SOURCES:%.scm=%.go)
 

module/system/base/pmatch.scm

@@ -0,0 +1,42 @@
+(define-module (system base pmatch)
+  #:use-syntax (ice-9 syncase)
+  #:export-syntax (pmatch ppat))
+;; FIXME: shouldn't have to export ppat...
+
+;; Originally written by Oleg Kiselyov. Taken from:
+;; αKanren: A Fresh Name in Nominal Logic Programming
+;; by William E. Byrd and Daniel P. Friedman
+;; Proceedings of the 2007 Workshop on Scheme and Functional Programming
+;; Université Laval Technical Report DIUL-RT-0701
+
+;; Licensing unclear. Probably need to ask Oleg for a disclaimer.
+
+(define-syntax pmatch
+  (syntax-rules (else guard)
+    ((_ (op arg ...) cs ...)
+     (let ((v (op arg ...)))
+       (pmatch v cs ...)))
+    ((_ v) (if #f #f))
+    ((_ v (else e0 e ...)) (begin e0 e ...))
+    ((_ v (pat (guard g ...) e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch v cs ...))))
+       (ppat v pat
+             (if (and g ...) (begin e0 e ...) (fk))
+             (fk))))
+    ((_ v (pat e0 e ...) cs ...)
+     (let ((fk (lambda () (pmatch v cs ...))))
+       (ppat v pat (begin e0 e ...) (fk))))))
+
+(define-syntax ppat
+  (syntax-rules (quote unquote)
+    ((_ v kt kf) kt)
+    ((_ v () kt kf) (if (null? v ) kt kf))
+    (( v (quote lit) kt kf)
+     (if (equal? v (quote lit)) kt kf))
+    ((_ v (unquote var) kt kf) (let ((var v )) kt))
+    ((_ v (x . y) kt kf)
+     (if (pair? v )
+         (let ((vx (car v)) (vy (cdr v)))
+           (ppat vx x (ppat vy y kt kf) kf))
+         kf))
+    ((_ v lit kt kf) (if (equal? v (quote lit)) kt kf))))

module/system/vm/assemble.scm

@@ -27,7 +27,6 @@
 		        make-binding
 			bytecode->objcode))
   :use-module (system vm conv)
-  :use-module (ice-9 match)
   :use-module (ice-9 regex)
   :use-module (ice-9 common-list)
   :use-module (srfi srfi-4)

module/system/vm/conv.scm

@@ -23,7 +23,7 @@
   :use-module ((system vm core)
 	       :select (instruction? instruction-length
 			instruction->opcode opcode->instruction))
-  :use-module (ice-9 match)
+  :use-module (system base pmatch)
   :use-module (ice-9 regex)
   :use-module (srfi srfi-4)
   :use-module (srfi srfi-1)
@@ -35,8 +35,8 @@
 ;;;
 
 (define (code-pack code)
-  (match code
-    ((inst (? integer? n))
+  (pmatch code
+    ((inst ,n) (guard (integer? n))
      (cond ((< n 10)
 	    (let ((abbrev (string->symbol (format #f "~A:~A" inst n))))
 	      (if (instruction? abbrev) (list abbrev) code)))
@@ -73,20 +73,20 @@
 	(else #f)))
 
 (define (code->object code)
-  (match code
-    (('make-true) #t)
-    (('make-false) #f) ;; FIXME: Same as the `else' case!
-    (('make-eol) '())
-    (('make-int8 n)
+  (pmatch code
+    ((make-true) #t)
+    ((make-false) #f) ;; FIXME: Same as the `else' case!
+    ((make-eol) '())
+    ((make-int8 ,n)
      (if (< n 128) n (- n 256)))
-    (('make-int16 n1 n2)
+    ((make-int16 ,n1 ,n2)
      (let ((n (+ (* n1 256) n2)))
        (if (< n 32768) n (- n 65536))))
-    (('make-char8 n)
+    ((make-char8 ,n)
      (integer->char n))
-    (('load-string s) s)
-    (('load-symbol s) (string->symbol s))
-    (('load-keyword s) (make-keyword-from-dash-symbol (string->symbol s)))
+    ((load-string ,s) s)
+    ((load-symbol ,s) (string->symbol s))
+    ((load-keyword ,s) (symbol->keyword (string->symbol s)))
     (else #f)))
 
 ; (let ((c->o code->object))