diff options
Diffstat (limited to 'cfn/pattern.scm')
| -rw-r--r-- | cfn/pattern.scm | 654 |
1 files changed, 654 insertions, 0 deletions
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))))))) + + + + |