diff options
Diffstat (limited to 'cfn')
| -rw-r--r-- | cfn/README | 35 | ||||
| -rw-r--r-- | cfn/cfn.scm | 21 | ||||
| -rw-r--r-- | cfn/main.scm | 83 | ||||
| -rw-r--r-- | cfn/misc.scm | 113 | ||||
| -rw-r--r-- | cfn/pattern.scm | 654 |
5 files changed, 906 insertions, 0 deletions
diff --git a/cfn/README b/cfn/README new file mode 100644 index 0000000..80a25c1 --- /dev/null +++ b/cfn/README @@ -0,0 +1,35 @@ +Whats what in the cfn. + +Language generated by cfn contains these ast node types: + lambda + let + if + case -- restriction: all patterns must be either literals or + a constructor with var and wildcard args + app + var-ref + con-ref + const + con-number + sel + is-constructor + +Transformations to do: + Convert lists to explicit calls to cons + Simplify patterns + Remove sequences + Remove list comprehensions + Remove sections + Reduce patterns on lhs of decls + Reduce patterns in function args + Convert where decls to let statements + Convert guarded-expressions to if - then - else form + +Done earlier: + signdecls are removed in scoping + exp-signs are removed in typechecker + prec parser removes `negate' & pp-* nodes + + + + diff --git a/cfn/cfn.scm b/cfn/cfn.scm new file mode 100644 index 0000000..bf43be0 --- /dev/null +++ b/cfn/cfn.scm @@ -0,0 +1,21 @@ +;;; cfn.scm -- module definition for CFN phase +;;; +;;; author : Sandra Loosemore +;;; date : 11 Mar 1992 +;;; + + +(define-compilation-unit cfn + (source-filename "$Y2/cfn/") + (require ast haskell-utils) + (unit main + (source-filename "main.scm")) + (unit misc + (source-filename "misc.scm") + (require main)) + (unit pattern + (source-filename "pattern.scm") + (require main))) + + + diff --git a/cfn/main.scm b/cfn/main.scm new file mode 100644 index 0000000..3853b03 --- /dev/null +++ b/cfn/main.scm @@ -0,0 +1,83 @@ +;;; main.scm -- main entry point for CFN pass +;;; +;;; author : Sandra Loosemore +;;; date : 27 Feb 1992 +;;; + + +;;;=================================================================== +;;; Basic support +;;;=================================================================== + + +;;; Define the basic walker and some helper functions. + +(define-walker cfn ast-td-cfn-walker) + +(define (cfn-ast-1 x) + (call-walker cfn x)) + +(define (cfn-ast/list l) + (map (lambda (x) (cfn-ast-1 x)) l)) + + +;;; This is the main entry point. It is called by the driver on +;;; each top-level decl in the module. + +(define (cfn-ast x) + (let ((result (cfn-ast-1 x))) +; (pprint result) ;*** debug + result)) + + + +;;;=================================================================== +;;; Default traversal methods +;;;=================================================================== + + +(define-local-syntax (make-cfn-code slot type) + (let ((stype (sd-type slot)) + (sname (sd-name slot))) + (cond ((and (symbol? stype) + (or (eq? stype 'exp) + (subtype? stype 'exp))) + `(setf (struct-slot ',type ',sname object) + (cfn-ast-1 (struct-slot ',type ',sname object)))) + ((and (pair? stype) + (eq? (car stype) 'list) + (symbol? (cadr stype)) + (or (eq? (cadr stype) 'exp) + (subtype? (cadr stype) 'exp))) + `(setf (struct-slot ',type ',sname object) + (cfn-ast/list (struct-slot ',type ',sname object)))) + ((and (pair? stype) + (eq? (car stype) 'list) + (eq? (cadr stype) 'decl)) + `(setf (struct-slot ',type ',sname object) + (cfn-valdef-list (struct-slot ',type ',sname object)))) + (else +; (format '#t "Cfn: skipping slot ~A in ~A~%" +; (sd-name slot) +; type) + '#f)))) + +(define-modify-walker-methods cfn + (let if + exp-sign + app + var-ref con-ref + integer-const float-const char-const string-const + con-number sel is-constructor + void + case-block return-from and-exp + ) + (object) + make-cfn-code) + + +;;; These have specialized walkers: +;;; lambda, case, valdef, list-comp (pattern.scm) +;;; list-exp, list-comp, section-l, section-r, dict-placeholder, +;;; recursive-placeholder, save-old-exp (misc.scm) + diff --git a/cfn/misc.scm b/cfn/misc.scm new file mode 100644 index 0000000..4bcba64 --- /dev/null +++ b/cfn/misc.scm @@ -0,0 +1,113 @@ +;;; misc.scm -- random other transformations done during CFN processing +;;; +;;; author : Sandra Loosemore +;;; date : 27 Feb 1992 +;;; +;;; This file contains specialized CFN walkers that implement rewrite rules +;;; for list-exp, sequence-xxx, list-comp, section-l, and section-r. + + +;;; Turn list-exps into cons chains. + +(define-walker-method cfn list-exp (object) + (do-cfn-list-exp (list-exp-exps object))) + +(define (do-cfn-list-exp exps) + (if (null? exps) + ;; Make a con-ref for [] + (**con/def (core-symbol "Nil")) + ;; Otherwise make an app of : + (let ((first (cfn-ast-1 (car exps))) + (rest (do-cfn-list-exp (cdr exps)))) + (**app (**con/def (core-symbol ":")) first rest)))) + + +;;; Sections get turned into lambda expressions. + +(define-walker-method cfn section-l (object) + (let ((def (create-temp-var 'section-arg))) + (**lambda/pat + (list (**var-pat/def def)) + (**app (cfn-ast-1 (section-l-op object)) + (**var/def def) + (cfn-ast-1 (section-l-exp object)))))) + +(define-walker-method cfn section-r (object) + (let ((def (create-temp-var 'section-arg))) + (**lambda/pat + (list (**var-pat/def def)) + (**app (cfn-ast-1 (section-r-op object)) + (cfn-ast-1 (section-r-exp object)) + (**var/def def))))) + + + +;;; Do list comprehensions. +;;; rewrite in terms of build and foldr so that we can apply +;;; deforestation techniques later. + +(define-walker-method cfn list-comp (object) + (let ((c (create-temp-var 'c)) + (n (create-temp-var 'n))) + (cfn-ast-1 + (**app (**var/def (core-symbol "build")) + (**lambda/pat + (list (**var-pat/def c) (**var-pat/def n)) + (do-cfn-list-comp + (list-comp-exp object) (list-comp-quals object) c n)))))) + +(define (do-cfn-list-comp exp quals c n) + (if (null? quals) + (**app (**var/def c) exp (**var/def n)) + (let ((qual (car quals))) + (if (is-type? 'qual-generator qual) + (do-cfn-list-comp-generator exp qual (cdr quals) c n) + (do-cfn-list-comp-filter exp qual (cdr quals) c n))))) + +(define (do-cfn-list-comp-filter exp qual quals c n) + (**if (qual-filter-exp qual) + (do-cfn-list-comp exp quals c n) + (**var/def n))) + +(define (do-cfn-list-comp-generator exp qual quals c n) + (let ((gen-pat (qual-generator-pat qual)) + (gen-exp (qual-generator-exp qual)) + (l (create-temp-var 'list)) + (b (create-temp-var 'rest))) + (**app (**var/def (core-symbol "foldr")) + (**lambda/pat + (list (**var-pat/def l) (**var-pat/def b)) + (**case (**var/def l) + (list (**alt/simple + gen-pat + (do-cfn-list-comp exp quals c b)) + (**alt/simple + (**wildcard-pat) + (**var/def b))))) + (**var/def n) + gen-exp))) + +;;; Placeholders just get eliminated + +(define-walker-method cfn dict-placeholder (object) + (if (eq? (dict-placeholder-exp object) '#f) + (error "Type checker screwed a dict placeholder object ~s." object) + (cfn-ast-1 (dict-placeholder-exp object)))) + +(define-walker-method cfn method-placeholder (object) + (if (eq? (method-placeholder-exp object) '#f) + (error "Type checker screwed a method placeholder object ~s." object) + (cfn-ast-1 (method-placeholder-exp object)))) + +(define-walker-method cfn recursive-placeholder (object) + (if (eq? (recursive-placeholder-exp object) '#f) + (error "Type checker screwed a recursive placeholder object ~s." object) + (cfn-ast-1 (recursive-placeholder-exp object)))) + +(define-walker-method cfn cast (object) + (cfn-ast-1 (cast-exp object))) + +;;; Eliminate saved old expressions + +(define-walker-method cfn save-old-exp (object) + (cfn-ast-1 (save-old-exp-new-exp object))) 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))))))) + + + + |