| 4e987026 |
;;; 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)))))))
|