Added a MATCH macro. The generated code is not very good.

diff --git a/v8/src/compiler/midend/synutl.scm b/v8/src/compiler/midend/synutl.scm
index ab5ce608117d63fdbda12ca97feab2ccaba0b863..c2675e11d6860b3f39e8b8eadd376ed222d2c7fa 100644 (file)
--- a/v8/src/compiler/midend/synutl.scm
+++ b/v8/src/compiler/midend/synutl.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: synutl.scm,v 1.1 1994/11/19 02:04:29 adams Exp $
+$Id: synutl.scm,v 1.2 1995/04/07 04:55:36 adams Exp $
 
 Copyright (c) 1994 Massachusetts Institute of Technology
 
@@ -60,4 +60,137 @@ MIT in each case. |#
                 (loop (cdr ll)
                       (cons (car ll) names)
                       (cons `(car ,path) args)
-                      `(cdr ,path))))))))
\ No newline at end of file
+                      `(cdr ,path))))))))
+\f
+;; (match expr (pattern qualifier ... => action ...) ...)
+;; qualifier is a scheme expression
+;;
+;; Patterns
+;; (? name)                            matches anything & binds name
+;; (? name pred)                       if `true', binds to result of xform
+;; ,expr                               matches equal? to expression: ,'? ,'_
+;; _                                    wildcard like (? G1278)
+;; (pattern . pattern)                 a pair
+;; 
+;;
+;; (let (( (? framevar) (CALL ',%mmm _ '(? frame-vector)))) _)
+;;
+;; (CALL ',+ '#F '(? a) '(? b)) => ',(+ a b))
+;; (CALL ',+ '#F '?a '?b) => ',(+ ?a ?b))
+;; (CALL ',+ '#F '?a '?b) (number? a) => ',(+ a b))
+;; (CALL ',+ '#F ?a ?b)  => ',(+ ?a ?b))
+
+(define (%compile-match-expression expr all-clauses)
+  (define (compile-clauses subject clauses)
+    (cond ((null? clauses)
+          `(BEGIN (ERROR "Pattern match failed" ,subject)
+                  ,unspecific))
+         ((or (not (pair? clauses)) (not (pair? (car clauses))))
+          (error "Bad clause list" all-clauses))
+         (else
+          (parse-clause
+           (car clauses)
+           (lambda (pattern qualifiers actions)
+             (compile-match subject pattern qualifiers actions
+                            (compile-clauses subject (cdr clauses))))))))
+
+  (define (compile-match subject pattern qualifiers actions alternate)
+    (compile-pattern subject pattern '()
+                    (lambda (predicate selectors)
+                      (if (null? qualifiers)
+                          (ifify predicate
+                                 (letify (reverse selectors)
+                                         actions)
+                                 alternate)
+                          (let ((alt (generate-uninterned-symbol)))
+                            `(LET ((,alt (LAMBDA () ,alternate)))
+                               ,(ifify predicate
+                                       (letify (reverse selectors)
+                                               (list
+                                                (ifify (andify qualifiers)
+                                                       (beginify actions)
+                                                       `(,alt))))
+                                       `(,alt))))))))
+
+  (define (compile-pattern subject pattern selectors receiver)
+    (cond ((null? pattern) (receiver `(NULL? ,subject) selectors))
+         ((eq? pattern '_) (receiver `#T selectors))
+         ((symbol? pattern)
+          (let* ((name (symbol-name pattern))
+                 (slen (string-length name)))
+            (if (and (> slen 0)
+                     (char=? (string-ref name 0) #\?))
+                (compile-pattern subject
+                                 `(? ,(string->symbol (substring name 1 slen)))
+                                 selectors receiver)
+                (receiver `(EQ? ,subject ',pattern) selectors))))
+         ((number? pattern) (receiver `(EQV? ,subject ,pattern) selectors))
+         ((and (pair? pattern)
+               (eq? (car pattern) '?))
+          (cond ((assq (cadr pattern) selectors)
+                 => (lambda (place)
+                      (receiver `(EQ? ,subject ,(cadr place)) selectors)))
+                (else
+                 (receiver #T (cons `(,(cadr pattern) ,subject) selectors)))))
+         ((and (pair? pattern)
+               (eq? (car pattern) 'unquote))
+          (receiver `(EQ? ,subject ,(second pattern)) selectors))
+         ((pair? pattern)
+          (compile-pattern
+           `(CAR ,subject) (car pattern) selectors
+           (lambda (predicate selectors)
+             (compile-pattern
+              `(CDR ,subject) (cdr pattern) selectors
+              (lambda (predicate* selectors)
+                (receiver (andify (list `(PAIR? ,subject)
+                                        predicate
+                                        predicate*))
+                          selectors))))))
+         (else
+          (error "Illegal MATCH pattern syntax:" pattern))))
+         
+  (define (andify preds)
+    (define (and-flatten preds)
+      (cond ((null? preds) '())
+           ((eq? #T (car preds)) (and-flatten (cdr preds)))
+           ((and (pair? (car preds)) (eq? 'and (caar preds)))
+            (append (and-flatten (cdar preds)) (and-flatten (cdr preds))))
+           (else (cons (car preds) (and-flatten (cdr preds))))))
+    (let ((preds (and-flatten preds)))
+      (cond ((null? preds) #T)
+           ((null? (cdr preds)) (car preds))
+           (else `(AND ,@preds)))))
+
+  (define (ifify pred conseq alt)
+    (cond ((eq? pred #T)  conseq)
+         ((eq? pred #F)  alt)
+         (else `(IF ,pred ,conseq ,alt))))
+
+  (define (letify bindings body)
+    (if (null? bindings)
+       (beginify body)
+       `(LET ,bindings ,@body)))
+
+  (define (beginify actions)
+    (if (and (pair? actions) (null? (cdr actions)))
+       (car actions)
+       `(BEGIN ,@actions)))
+
+  (define (parse-clause clause receiver)
+    (let ((pat  (car clause)))
+      (let loop ((actions (cdr clause)) (quals '()))
+       (cond ((null? actions)
+              (error "Illegal clause" clause))
+             ((eq? (car actions) '=>)
+              (receiver pat (reverse! quals) (cdr actions)))
+             (else
+              (loop (cdr actions) (cons (car actions) quals)))))))
+
+  (if (symbol? expr)
+      (compile-clauses expr all-clauses)
+      (let ((subject  (generate-uninterned-symbol)))
+       `(LET ((,subject ,expr))
+          ,(compile-clauses subject all-clauses)))))
+
+(define-macro (match expr . clauses)
+  (%compile-match-expression expr clauses))
\ No newline at end of file