From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 cfn/pattern.scm | 654 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 654 insertions(+)
 create mode 100644 cfn/pattern.scm

(limited to 'cfn/pattern.scm')

diff --git a/cfn/pattern.scm b/cfn/pattern.scm
new file mode 100644
index 0000000..64badbf
--- /dev/null
+++ b/cfn/pattern.scm
@@ -0,0 +1,654 @@
+;;; pattern.scm -- cfn processing of pattern-related AST structures
+;;;
+;;; author :  Sandra Loosemore
+;;; date   :  27 Feb 1992
+;;;
+;;; This file contains specialized CFN walkers for lambda, case, and valdef
+;;; structures.
+
+
+
+;;;=====================================================================
+;;; Top-level walkers
+;;;=====================================================================
+
+
+;;; The calls to remember-context are so an appropriate error message
+;;; can be produced for pattern-matching failures.
+
+(define-walker-method cfn lambda (object)
+  (remember-context object
+    (do-cfn-lambda (lambda-pats object) (lambda-body object))))
+
+
+(define-walker-method cfn case (object)
+  (remember-context object
+    (do-cfn-case
+      (case-exp object)
+      (case-alts object))))
+
+
+
+
+;;; Valdefs are always processed as a list.
+
+(define (cfn-valdef-list list-of-valdefs)
+  (if (null? list-of-valdefs)
+      '()
+      (nconc (cfn-valdef (car list-of-valdefs))
+	     (cfn-valdef-list (cdr list-of-valdefs)))))
+
+(define (cfn-valdef object)
+  (remember-context object
+    (if (null? (single-fun-def-args (car (valdef-definitions object))))
+	;; This is a pattern binding.
+	(do-cfn-pattern-def-top object)
+	;; This is a function binding.
+	;; Branch on single-headed/multi-headed definition.
+	(list (add-dict-params
+	        object
+		(if (null? (cdr (valdef-definitions object)))
+		    (do-cfn-function-def-simple object)
+		    (do-cfn-function-def-general object))))
+      )))
+
+
+;;; This adds the dictionary parameters needed by the type system.  A valdef
+;;; structure has a dictionary-args field which contains the variables to be
+;;; bound to dicationary arguments.
+
+(define (add-dict-params original-valdef generated-valdef)
+  (let ((vars (valdef-dictionary-args original-valdef)))
+    (when (not (null? vars))
+      (let* ((sfd  (car (valdef-definitions generated-valdef)))
+	     (rhs  (car (single-fun-def-rhs-list sfd)))
+	     (exp  (guarded-rhs-rhs rhs))
+	     (pats (map (function **var-pat/def) vars)))
+	(if (is-type? 'lambda exp)
+	    (setf (lambda-pats exp)
+		  (nconc pats (lambda-pats exp)))
+	    (setf (guarded-rhs-rhs rhs)
+		  (**lambda/pat pats exp))))))
+  generated-valdef)
+
+
+;;;=====================================================================
+;;; Lambda rewriting
+;;;=====================================================================
+
+
+;;; For lambda, make all the argument patterns into var pats.
+;;; Rewrite the body as a CASE to do any more complicated pattern
+;;; matching.
+;;; The CFN output for lambda is a modified lambda expression with
+;;; all var-pats as arguments.
+
+(define (do-cfn-lambda pats body)
+  (let ((new-args  '())
+	(new-vars  '())
+	(new-pats  '()))
+    (dolist (p pats)
+      (typecase p
+	(wildcard-pat
+	  (push (**var-pat/def (create-temp-var 'arg)) new-args))
+        (var-pat
+	  (push p new-args))
+	(as-pat
+	  (let ((var  (var-ref-var (as-pat-var p))))
+	    (push (**var-pat/def var) new-args)
+	    (push (**var/def var) new-vars)
+	    (push (as-pat-pattern p) new-pats)))
+	(else
+	  (let ((var  (create-temp-var 'arg)))
+	    (push (**var-pat/def var) new-args)
+	    (push (**var/def var) new-vars)
+	    (push p new-pats)))))
+    (setf new-args (nreverse new-args))
+    (setf new-vars (nreverse new-vars))
+    (setf new-pats (nreverse new-pats))
+    (**lambda/pat
+      new-args
+      (cond ((null? new-vars)
+	     ;; No fancy pattern matching necessary.
+	     (cfn-ast-1 body))
+	    ((null? (cdr new-vars))
+	     ;; Exactly one argument to match on.
+	     (do-cfn-case (car new-vars)
+			  (list (**alt/simple (car new-pats) body))))
+	    (else
+	     ;; Multiple arguments to match on.
+	     (do-cfn-case-tuple
+	       new-vars
+	       (list (**alt/simple (**tuple-pat new-pats) body))))
+	    ))))
+
+
+;;;=====================================================================
+;;; Function definitions
+;;;=====================================================================
+
+
+;;; The output of the CFN for function definitions is a simple 
+;;; valdef which binds a variable to a lambda expression.
+
+
+;;; The simple case:  there is only one set of arguments.
+
+(define (do-cfn-function-def-simple object)
+  (let* ((pat    (valdef-lhs object))
+	 (sfd    (car (valdef-definitions object))))
+    (**valdef/pat
+      pat
+      (do-cfn-lambda
+        (single-fun-def-args sfd)
+	(rewrite-guards-and-where-decls
+	  (single-fun-def-where-decls sfd)
+	  (single-fun-def-rhs-list sfd)
+	  '#f)))))
+
+
+;;; The general case:  generate new variables as the formal parameters 
+;;; to the resulting lambda, then use case to do the pattern matching.
+
+(define (do-cfn-function-def-general object)
+  (let ((pat   (valdef-lhs object))
+	(vars  (map (lambda (p)
+		      (declare (ignore p))
+		      (create-temp-var 'arg))
+		    (single-fun-def-args (car (valdef-definitions object)))))
+	(alts  (map (lambda (sfd)
+		      (**alt (**tuple-pat (single-fun-def-args sfd))
+			     (single-fun-def-rhs-list sfd)
+			     (single-fun-def-where-decls sfd)))
+		    (valdef-definitions object))))
+    (**valdef/pat
+      pat
+      (**lambda/pat
+        (map (function **var-pat/def) vars)
+	(if (null? (cdr vars))
+	    ;; one-argument case
+	    (do-cfn-case (**var/def (car vars)) alts)
+	    ;; multi-argument case
+	    (do-cfn-case-tuple (map (function **var/def) vars) alts))))
+    ))
+
+
+;;;=====================================================================
+;;; Case
+;;;=====================================================================
+
+
+;;; For case, add failure alt, then call helper function to generate
+;;; pattern matching tests.
+;;; The CFN output for case is a case-block construct.
+
+(define (do-cfn-case exp alts)
+  (setf alts
+	(append alts
+		(list (**alt/simple (**wildcard-pat) (make-failure-exp)))))
+  (let ((list-of-pats  	(map (lambda (a) (list (alt-pat a))) alts)))
+    (if (is-type? 'var-ref exp)
+	(match-pattern-list (list exp) list-of-pats alts)
+	(let ((temp  (create-temp-var 'cfn)))
+	  (**let (list (**valdef/def temp (cfn-ast-1 exp)))
+		 (match-pattern-list
+		   (list (**var/def temp))
+		   list-of-pats
+		   alts)))
+      )))
+
+
+
+;;; Here's a special case, for when the exp being matched is a tuple
+;;; of var-refs and all the alts also have tuple pats.
+
+(define (do-cfn-case-tuple exps alts)
+  (setf alts
+	(append alts
+		(list
+		  (**alt/simple
+		    (**tuple-pat
+		      (map (lambda (e) (declare (ignore e)) (**wildcard-pat))
+			   exps))
+		    (make-failure-exp)))))
+  (match-pattern-list
+    exps
+    (map (lambda (a) (pcon-pats (alt-pat a))) alts)
+    alts))
+
+
+(define (match-pattern-list exps list-of-pats alts)
+  (let ((block-name  (gensym "PMATCH")))
+    (**case-block
+      block-name
+      (map (lambda (a p) (match-pattern exps p a block-name))
+	   alts
+	   list-of-pats))))
+
+
+;;; Produce an exp that matches the given alt against the exps.
+;;; If the match succeeds, it will return-from the given block-name.
+
+(define (match-pattern exps pats alt block-name)
+  (if (null pats)
+      ;; No more patterns to match.
+      ;; Return an exp that handles the guards and where-decls.
+      (cfn-ast-1
+        (rewrite-guards-and-where-decls
+	  (alt-where-decls alt) (alt-rhs-list alt) block-name))
+      ;; Otherwise dispatch on type of first pattern.
+      (let ((pat  (pop pats))
+	    (exp  (pop exps)))
+	(funcall
+	  (typecase pat
+	    (wildcard-pat (function match-wildcard-pat))
+	    (var-pat      (function match-var-pat))
+	    (pcon         (function match-pcon))
+	    (as-pat       (function match-as-pat))
+	    (irr-pat      (function match-irr-pat))
+	    (const-pat    (function match-const-pat))
+	    (plus-pat     (function match-plus-pat))
+	    (list-pat     (function match-list-pat))
+	    (else         (error "Unrecognized pattern ~s." pat)))
+	  pat
+	  exp
+	  pats
+	  exps
+	  alt
+	  block-name))))
+
+
+
+
+;;; Wildcard patterns add no pattern matching test.
+;;; Just recurse on the next pattern to be matched.
+
+(define (match-wildcard-pat pat exp pats exps alt block-name)
+  (declare (ignore pat exp))
+  (match-pattern exps pats alt block-name))
+
+
+;;; A variable pattern likewise does not add any test.  However,
+;;; a binding of the variable to the corresponding exp must be added.
+
+(define (match-var-pat pat exp pats exps alt block-name)
+  (push (**valdef/pat pat exp)
+	(alt-where-decls alt))
+  (match-pattern exps pats alt block-name))
+
+
+;;; Pcons are the hairy case because they may have subpatterns that need
+;;; to be matched.
+;;; If there are subpats and the exp is not a var-ref, make a let binding.
+;;; If the con is a tuple type, there is no need to generate a test
+;;; since the test would always succeed anyway.
+;;; Do not generate let bindings here for subexpressions; do this lazily
+;;; if and when necessary.
+
+(define (match-pcon pat exp pats exps alt block-name)
+  (let* ((var?    (is-type? 'var-ref exp))
+	 (var     (if var?
+		      (var-ref-var exp)
+		      (create-temp-var 'conexp)))
+	 (con     (pcon-con pat))
+	 (arity   (con-arity con))
+	 (alg     (con-alg con))
+	 (tuple?  (algdata-tuple? alg))
+	 (subpats (pcon-pats pat))
+	 (subexps '()))
+    (dotimes (i arity)
+      (push (**sel con (**var/def var) i) subexps))
+    (setf exps (nconc (nreverse subexps) exps))
+    (setf pats (append subpats pats))
+    (let ((tail  (match-pattern exps pats alt block-name)))
+      (when (not tuple?)
+	(setf tail
+	      (**and-exp (**is-constructor (**var/def var) con) tail)))
+      (when (not var?)
+	(setf tail
+	      (**let (list (**valdef/def var (cfn-ast-1 exp))) tail)))
+      tail)))
+
+
+;;; For as-pat, add a variable binding.
+;;; If the expression being matched is not already a variable reference,
+;;; take this opportunity to make the let binding.  Otherwise push the
+;;; let-binding onto the where-decls.
+
+(define (match-as-pat pat exp pats exps alt block-name)
+  (let ((var    (var-ref-var (as-pat-var pat)))
+	(subpat (as-pat-pattern pat)))
+    (if (is-type? 'var-ref exp)
+	(begin
+	  (push (**valdef/def var (**var/def (var-ref-var exp)))
+		(alt-where-decls alt))
+	  (match-pattern
+	    (cons exp exps)
+	    (cons subpat pats)
+	    alt
+	    block-name))
+	(**let (list (**valdef/def var (cfn-ast-1 exp)))
+	       (match-pattern
+		 (cons (**var/def var) exps)
+		 (cons subpat pats)
+		 alt
+		 block-name)))))
+
+
+;;; An irrefutable pattern adds no test to the pattern matching,
+;;; but adds a pattern binding to the where-decls.
+
+(define (match-irr-pat pat exp pats exps alt block-name)
+  (let ((subpat  (irr-pat-pattern pat)))
+    (push (**valdef/pat subpat exp) (alt-where-decls alt))
+    (match-pattern exps pats alt block-name)))
+
+
+;;; A const pat has a little piece of code inserted by the typechecker
+;;; to do the test.
+;;; For matches against string constants, generate an inline test to match 
+;;; on each character of the string.
+
+(define (match-const-pat pat exp pats exps alt block-name)
+  (let ((const  (const-pat-value pat)))
+    (**and-exp 
+      (if (is-type? 'string-const const)
+	  (let ((string  (string-const-value const)))
+	    (if (string=? string "")
+		(**is-constructor exp (core-symbol "Nil"))
+		(**app (**var/def (core-symbol "primStringEq")) const exp)))
+	  (cfn-ast-1 (**app (const-pat-match-fn pat) exp)))
+      (match-pattern exps pats alt block-name))
+    ))
+
+
+;;; Plus pats have both a magic test and a piece of code to
+;;; make a binding in the where-decls.  Make a variable binding
+;;; for the exp if it's not already a variable.
+
+(define (match-plus-pat pat exp pats exps alt block-name)
+  (let* ((var?  (is-type? 'var-ref exp))
+	 (var   (if var? (var-ref-var exp) (create-temp-var 'plusexp))))
+    (push (**valdef/pat (plus-pat-pattern pat)
+			(**app (plus-pat-bind-fn pat) (**var/def var)))
+	  (alt-where-decls alt))
+    (let ((tail  (match-pattern exps pats alt block-name)))
+      (setf tail
+	    (**and-exp
+	      (cfn-ast-1 (**app (plus-pat-match-fn pat) (**var/def var)))
+	      tail))
+      (if var?
+	  tail
+	  (**let (list (**valdef/def var exp)) tail)))))
+
+
+;;; Rewrite list pats as pcons, then process recursively.
+
+(define (match-list-pat pat exp pats exps alt block-name)
+  (let ((newpat  (rewrite-list-pat (list-pat-pats pat))))
+    (match-pattern
+      (cons exp exps)
+      (cons newpat pats)
+      alt
+      block-name)))
+
+(define (rewrite-list-pat subpats)
+  (if (null? subpats)
+      (**pcon/def (core-symbol "Nil") '())
+      (**pcon/def (core-symbol ":")
+		  (list (car subpats)
+			(rewrite-list-pat (cdr subpats))))))
+
+
+
+
+;;;=====================================================================
+;;; Pattern definitions
+;;;=====================================================================
+
+
+(define (do-cfn-pattern-def-top object)
+  (typecase (valdef-lhs object)
+    (var-pat
+      ;; If the pattern definition is a simple variable assignment, it
+      ;; may have dictionary parameters that need to be messed with.
+      ;; Complicated pattern bindings can't be overloaded in this way.
+      (list (add-dict-params object (do-cfn-pattern-def-simple object))))
+    (irr-pat
+      ;; Irrefutable patterns are redundant here.
+      (setf (valdef-lhs object) (irr-pat-pattern (valdef-lhs object)))
+      (do-cfn-pattern-def-top object))
+    (wildcard-pat
+     ;; Wildcards are no-ops.
+     '())
+    (pcon
+     ;; Special-case because it's frequent and general case creates
+     ;; such lousy code
+     (do-cfn-pattern-def-pcon object))
+    (else
+      (do-cfn-pattern-def-general object))))
+
+
+;;; Do a "simple" pattern definition, e.g. one that already has a
+;;; var-pat on the lhs.
+
+(define (do-cfn-pattern-def-simple object)
+  (let* ((pat  (valdef-lhs object))
+	 (sfd  (car (valdef-definitions object)))
+	 (exp  (rewrite-guards-and-where-decls
+		 (single-fun-def-where-decls sfd)
+		 (single-fun-def-rhs-list sfd)
+		 '#f)))
+  (**valdef/pat pat (cfn-ast-1 exp))))
+
+
+;;; Destructure a pcon.
+;;; Note that the simplified expansion is only valid if none of
+;;; the subpatterns introduce tests.  Otherwise we must defer to
+;;; the general case.
+
+(define (do-cfn-pattern-def-pcon object)
+  (let* ((pat     (valdef-lhs object))
+	 (subpats (pcon-pats pat)))
+    (if (every (function irrefutable-pat?) subpats)
+	(let* ((con     (pcon-con pat))
+	       (arity   (con-arity con))
+	       (alg     (con-alg con))
+	       (tuple?  (algdata-tuple? alg))
+	       (temp    (create-temp-var 'pbind))
+	       (result  '()))
+	  (dotimes (i arity)
+	    (setf result
+		  (nconc result
+			 (do-cfn-pattern-def-top 
+			   (**valdef/pat (pop subpats)
+					 (**sel con (**var/def temp) i))))))
+	  (if (null? result)
+	      '()
+	      (let* ((sfd   (car (valdef-definitions object)))
+		     (exp   (cfn-ast-1
+			      (rewrite-guards-and-where-decls
+			        (single-fun-def-where-decls sfd)
+				(single-fun-def-rhs-list sfd)
+				'#f))))
+		(when (not tuple?)
+		  (let ((temp1  (create-temp-var 'cfn)))
+		    (setf exp
+			  (**let (list (**valdef/def temp1 exp))
+				 (**if (**is-constructor (**var/def temp1) con)
+				       (**var/def temp1)
+				       (make-failure-exp))))))
+		(cons (**valdef/def temp exp) result))))
+	(do-cfn-pattern-def-general object))))
+
+
+
+;;; Turn a complicated pattern definition into a list of simple ones.
+;;; The idea is to use case to match the pattern and build a tuple of
+;;; all the values which are being destructured into the pattern
+;;; variables.
+
+(define (do-cfn-pattern-def-general object)
+  (multiple-value-bind (new-pat vars new-vars)
+      (copy-pattern-variables (valdef-lhs object))
+    (if (not (null? vars))
+	(let* ((sfd      (car (valdef-definitions object)))
+	       (exp      (rewrite-guards-and-where-decls
+			   (single-fun-def-where-decls sfd)
+			   (single-fun-def-rhs-list sfd)
+			   '#f))
+	       (arity    (length vars)))
+	  (if (eqv? arity 1)
+	      (list (**valdef/def
+		      (var-ref-var (car vars))
+		      (do-cfn-case
+		        exp
+			(list (**alt/simple new-pat (car new-vars))))))
+	      (let ((temp     (create-temp-var 'pbind))
+		    (bindings '()))
+		(dotimes (i arity)
+		  (push (**valdef/def (var-ref-var (pop vars))
+				      (**tuple-sel arity i (**var/def temp)))
+			bindings))
+		(cons (**valdef/def
+		        temp
+			(do-cfn-case
+			  exp
+			  (list (**alt/simple new-pat (**tuple/l new-vars)))))
+		      bindings))))
+	'())))
+
+
+
+;;; Helper function for above.
+;;; All the variables in the pattern must be replaced with temporary
+;;; variables.  
+
+(define (copy-pattern-variables pat)
+  (typecase pat
+    (wildcard-pat
+      (values pat '() '()))
+    (var-pat
+      (let ((new  (create-temp-var (var-ref-name (var-pat-var pat)))))
+	(values (**var-pat/def new)
+		(list (var-pat-var pat))
+		(list (**var/def new)))))
+    (pcon
+      (multiple-value-bind (new-pats vars new-vars)
+	  (copy-pattern-variables-list (pcon-pats pat))
+	(values (**pcon/def (pcon-con pat) new-pats)
+		vars
+		new-vars)))
+    (as-pat
+      (let ((new  (create-temp-var (var-ref-name (as-pat-var pat)))))
+	(multiple-value-bind (new-pat vars new-vars)
+	    (copy-pattern-variables (as-pat-pattern pat))
+	  (values
+	    (make as-pat
+		  (var (**var/def new))
+		  (pattern new-pat))
+	    (cons (as-pat-var pat) vars)
+	    (cons (**var/def new) new-vars)))))
+    (irr-pat
+      (multiple-value-bind (new-pat vars new-vars)
+	  (copy-pattern-variables (irr-pat-pattern pat))
+	(values
+	  (make irr-pat (pattern new-pat))
+	  vars
+	  new-vars)))
+    (const-pat
+      (values pat '() '()))
+    (plus-pat
+      (multiple-value-bind (new-pat vars new-vars)
+	  (copy-pattern-variables (plus-pat-pattern pat))
+	(values
+	  (make plus-pat
+		(pattern new-pat)
+		(k (plus-pat-k pat))
+		(match-fn (plus-pat-match-fn pat))
+		(bind-fn (plus-pat-bind-fn pat)))
+	  vars
+	  new-vars)))
+    (list-pat
+      (multiple-value-bind (new-pats vars new-vars)
+	  (copy-pattern-variables-list (list-pat-pats pat))
+	(values (make list-pat (pats new-pats))
+		vars
+		new-vars)))
+    (else
+      (error "Unrecognized pattern ~s." pat))))
+
+(define (copy-pattern-variables-list pats)
+  (let ((new-pats  '())
+	(vars      '())
+	(new-vars  '()))
+    (dolist (p pats)
+      (multiple-value-bind (p v n) (copy-pattern-variables p)
+	(push p new-pats)
+	(setf vars (nconc vars v))
+	(setf new-vars (nconc new-vars n))))
+    (values (nreverse new-pats)
+	    vars
+	    new-vars)))
+
+
+
+;;;=====================================================================
+;;; Helper functions for processing guards and where-decls
+;;;=====================================================================
+
+;;; Process guards and where-decls into a single expression.
+;;; If block-name is non-nil, wrap the exp with a return-from.
+;;; If block-name is nil, add a failure exp if necessary.
+;;; Note that this does NOT do the CFN traversal on the result or
+;;; any part of it.
+
+(define (rewrite-guards-and-where-decls where-decls rhs-list block-name)
+  (if (null? where-decls)
+      (rewrite-guards rhs-list block-name)
+      (**let where-decls
+	     (rewrite-guards rhs-list block-name))))
+
+(define (rewrite-guards rhs-list block-name)
+  (if (null? rhs-list)
+      (if block-name
+	  (**con/def (core-symbol "False"))
+	  (make-failure-exp))
+      (let* ((rhs     (car rhs-list))
+	     (guard   (guarded-rhs-guard rhs))
+	     (exp     (guarded-rhs-rhs rhs)))
+	(when block-name
+	  (setf exp (**return-from block-name exp)))
+	(cond ((is-type? 'omitted-guard (guarded-rhs-guard (car rhs-list)))
+	       exp)
+	      ((and block-name (null? (cdr rhs-list)))
+	       (**and-exp guard exp))
+	      (else
+	       (**if guard
+		     exp
+		     (rewrite-guards (cdr rhs-list) block-name)))
+	      ))))
+
+
+(define (make-failure-exp)
+  (let ((c  (dynamic *context*)))
+    (**abort
+      (if (not c)
+	  "Pattern match failed."
+	  (let* ((stuff  (ast-node-line-number c))
+		 (line   (source-pointer-line stuff))
+		 (file   (source-pointer-file stuff)))
+	    (if (and (is-type? 'valdef c)
+		     (is-type? 'var-pat (valdef-lhs c)))
+		(format
+		  '#f
+		  "Pattern match failed in function ~a at line ~s in file ~a."
+		  (valdef-lhs c) line file)
+		(format
+		  '#f
+		  "Pattern match failed at line ~s in file ~a."
+		  line file)))))))
+
+
+
+
-- 
cgit v1.2.3