1 files changed, 161 insertions, 0 deletions
diff --git a/ps06_rule_systems/rule-compiler.scm b/ps06_rule_systems/rule-compiler.scm
new file mode 100644
index 0000000..f705308
--- /dev/null
+++ b/ps06_rule_systems/rule-compiler.scm
@@ -0,0 +1,161 @@
+(define-syntax rule
+  (sc-macro-transformer
+   (lambda (form env)
+     (if (syntax-match? '(DATUM EXPRESSION DATUM) (cdr form))
+	 (compile-rule (cadr form) (caddr form) (cadddr form) env)
+	 (ill-formed-syntax form)))))
+
+(define (compile-rule pattern restriction template env)
+  (let ((names (pattern-names pattern)))
+    `(rule:make ,(compile-pattern pattern env)
+		,(compile-restriction restriction env names)
+		,(compile-instantiator template env names))))
+
+;;; These could be generic, but I am lazy today... GJS
+
+(define (pattern-names pattern)
+  (let loop ((pattern pattern) (names '()))
+    (cond ((or (match:element? pattern)
+	       (match:segment? pattern))
+	   (let ((name (match:variable-name pattern)))
+	     (if (memq name names)
+		 names
+		 (cons name names))))
+	  ((list? pattern)
+	   (let elt-loop ((elts pattern) (names names))
+	     (if (pair? elts)
+		 (elt-loop (cdr elts) (loop (car elts) names))
+		 names)))
+	  (else names))))
+
+(define (compile-pattern pattern env)
+  (let loop ((pattern pattern))
+    (cond ((match:element? pattern)
+	   (if (match:restricted? pattern)
+	       `(match:element ',(match:variable-name pattern)
+			       ,(match:restriction pattern))
+	       `(match:element ',(match:variable-name pattern))))
+	  ((match:segment? pattern)
+	   `(match:segment ',(match:variable-name pattern)))
+	  ((null? pattern)
+	   `(match:eqv '()))
+	  ((list? pattern)
+	   `(match:list ,@(map loop pattern)))
+	  (else
+	   `(match:eqv ',pattern)))))
+
+
+;;; These are repeated from match.scm
+
+(define (match:element? pattern)
+  (and (pair? pattern)
+       (eq? (car pattern) '?)))
+
+(define (match:segment? pattern)
+  (and (pair? pattern)
+       (eq? (car pattern) '??)))
+
+(define (match:variable-name pattern)
+  (cadr pattern))
+
+
+(define (match:restricted? pattern)
+  (not (null? (cddr pattern))))
+
+(define (match:restriction pattern)
+  (caddr pattern))
+
+;;; The restriction is a predicate that must be true for the rule to
+;;; be applicable.  This is not the same as a variable element
+;;; restriction.
+
+(define (compile-restriction expr env names)
+  (if (eq? expr 'none)
+      `#f
+      (make-lambda names env
+	(lambda (env)
+	  (close-syntax expr env)))))
+
+
+(define (compile-instantiator skel env names)
+  (make-lambda names env
+    (lambda (env)
+      (list 'quasiquote
+	    (let ((wrap (lambda (expr) (close-syntax expr env))))
+	      (let loop ((skel skel))
+		(cond ((skel:element? skel)
+		       (list 'unquote
+			     (wrap (skel:element-expression skel))))
+		      ((skel:segment? skel)
+		       (list 'unquote-splicing
+			     (wrap (skel:segment-expression skel))))
+		      ((list? skel) (map loop skel))
+		      (else skel))))))))
+
+		       
+(define (skel:constant? skeleton)
+  (not (pair? skeleton)))
+
+
+(define (skel:element? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '?)))
+
+(define (skel:element-expression skeleton)
+  (cadr skeleton))
+
+
+(define (skel:segment? skeleton)
+  (and (pair? skeleton)
+       (eq? (car skeleton) '??)))
+
+(define (skel:segment-expression skeleton)
+  (cadr skeleton))
+
+;; Magic!
+(define (make-lambda bvl use-env generate-body)
+  (capture-syntactic-environment
+   (lambda (transform-env)
+     (close-syntax `(,(close-syntax 'lambda transform-env)
+		     ,bvl
+		     ,(capture-syntactic-environment
+		       (lambda (use-env*)
+			 (close-syntax (generate-body use-env*)
+				       transform-env))))
+		   use-env))))
+
+#|
+;;; For example
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+		   none
+		   (+ (+ (? a) (? b)) (? c)) )
+	    (the-environment)))
+(rule:make
+ (match:list
+  (match:eqv (quote +))
+  (match:element (quote a))
+  (match:list (match:eqv (quote +))
+              (match:element (quote b))
+              (match:element (quote c))))
+ #f
+ (lambda (c b a)
+   (list (quote +) (list (quote +) a b) c)))
+
+(pp (syntax '(rule (+ (? a) (+ (? b) (? c)))
+		   (> a 3)
+		   (+ (+ (? a) (? b)) (? c)) )
+	    (the-environment)))
+(rule:make
+ (match:list
+  (match:eqv (quote +))
+  (match:element (quote a))
+  (match:list (match:eqv (quote +))
+              (match:element (quote b))
+              (match:element (quote c))))
+ (lambda (c b a)
+   (> a 3))
+ (lambda (c b a)
+   (list (quote +) (list (quote +) a b) c)))
+
+|#
+\ No newline at end of file