home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / cfn / pattern.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  21.2 KB  |  552 lines  |  [TEXT/CCL2]
  1. lures.
  2.  
  3. (define-walker-method cfn lambda (object)
  4.   (remember-context object
  5.     (do-cfn-lambda (lambda-pats object) (lambda-body object))))
  6.  
  7.  
  8. (define-walker-method cfn case (object)
  9.   (remember-context object
  10.     (do-cfn-case
  11.       (case-exp object)
  12.       (case-alts object))))
  13.  
  14.  
  15.  
  16.  
  17. ;;; Valdefs are always processed as a list.
  18.  
  19. (define (cfn-valdef-list list-of-valdefs)
  20.   (if (null? list-of-valdefs)
  21.       '()
  22.       (nconc (cfn-valdef (car list-of-valdefs))
  23.          (cfn-valdef-list (cdr list-of-valdefs)))))
  24.  
  25. (define (cfn-valdef object)
  26.   (remember-context object
  27.  
  28.     (if (null? (single-fun-def-args (car (valdef-definitions object))))
  29.     ;; This is a pattern binding.
  30.     (do-cfn-pattern-def-top object) ; %%% Bug: extra defs not added
  31.                                     ; %%% when add-dict-params not called!
  32.     ;; This is a function binding.
  33.     ;; Branch on single-headed/multi-headed definition.
  34.     (list (add-dict-params
  35.             object
  36.         (if (null? (cdr (valdef-definitions object)))
  37.             (do-cfn-function-def-simple object)
  38.             (do-cfn-function-def-general object))))
  39.       )))
  40.  
  41. ;;; This adds the dictionary parameters needed by the type system.  A valdef
  42. ;;; structure has a dictionary-args field which contains the variables to be
  43. ;;; bound to dicationary arguments.  Added aux definitions for dynamic
  44. ;;; typing - jcp.
  45.  
  46. (define (add-dict-params original-valdef generated-valdef)
  47.   (let* ((vars (valdef-dictionary-args original-valdef))
  48.      (defs (valdef-extra-decls original-valdef))
  49.      (sfd  (car (valdef-definitions generated-valdef)))
  50.      (rhs  (car (single-fun-def-rhs-list sfd)))
  51.      (exp  (guarded-rhs-rhs rhs))
  52.      (pats (map (function **var-pat/def) vars)))
  53.       (cond ((is-type? 'lambda exp)
  54.          (setf (lambda-pats exp)
  55.            (nconc pats (lambda-pats exp)))
  56.          (when defs
  57.            (setf (lambda-body exp)
  58.              (**let defs (lambda-body exp)))))
  59.         (else
  60.          (setf (guarded-rhs-rhs rhs)
  61.            (**lambda/pat
  62.             pats
  63.             (if defs (**let defs exp) exp))))))
  64.   generated-valdef)
  65.  
  66.  
  67. ;;;=====================================================================
  68. ;;; Lambda rewriting
  69. ;;;=====================================================================
  70.  
  71.  
  72. ;;; For lambda, make all the argument patterns into var pats.
  73. ;;; Rewrite the body as a CASE to do any more complicated pattern
  74. ;;; matching.
  75. ;;; The CFN output for lambda is a modified lambda expression with
  76. ;;; all var-pats as arguments.
  77.  
  78. (define (do-cfn-lambda pats body)
  79.   (let ((new-args  '())
  80.     (new-vars  '())
  81.     (new-pats  '()))
  82.     (dolist (p pats)
  83.       (typecase p
  84.     (wildcard-pat
  85.       (push (**var-pat/def (create-temp-var 'arg)) new-args))
  86.         (var-pat
  87.       (push p new-args))
  88.     (as-pat
  89.       (let ((var  (var-ref-var (as-pat-var p))))
  90.         (push (**var-pat/def var) new-args)
  91.         (push (**var/def var) new-vars)
  92.         (push (as-pat-pattern p) new-pats)))
  93.     (else
  94.       (let ((var  (create-temp-var 'arg)))
  95.         (push (**var-pat/def var) new-args)
  96.         (push (**var/def var) new-vars)
  97.         (push p new-pats)))))
  98.     (setf new-args (nreverse new-args))
  99.     (setf new-vars (nreverse new-vars))
  100.     (setf new-pats (nreverse new-pats))
  101.     (**lambda/pat
  102.       new-args
  103.       (cond ((null? new-vars)
  104.          ;; No fancy pattern matching necessary.
  105.          (cfn-ast-1 body))
  106.         ((null? (cdr new-vars))
  107.          ;; Exactly one argument to match on.
  108.          (do-cfn-case (car new-vars)
  109.               (list (**alt/simple (car new-pats) body))))
  110.         (else
  111.          ;; Multiple arguments to match on.
  112.          (do-cfn-case-tuple
  113.            new-vars
  114.            (list (**alt/simple (**tuple-pat new-pats) body))))
  115.         ))))
  116.  
  117.  
  118. ;;;=====================================================================
  119. ;;; Function definitions
  120. ;;;=====================================================================
  121.  
  122.  
  123. ;;; The output of the CFN for function definitions is a simple 
  124. ;;; valdef which binds a variable to a lambda expression.
  125.  
  126.  
  127. ;;; The simple case:  there is only one set of arguments.
  128.  
  129. (define (do-cfn-function-def-simple object)
  130.   (let* ((pat    (valdef-lhs object))
  131.      (sfd    (car (valdef-definitions object))))
  132.     (**valdef/pat
  133.       pat
  134.       (do-cfn-lambda
  135.         (single-fu subpatterns that need
  136. ;;; to be matched.
  137. ;;; If there are subpats and the exp is not a var-ref, make a let binding.
  138. ;;; If the con is a tuple type, there is no need to generate a test
  139. ;;; since the test would always succeed anyway.
  140. ;;; Do not generate let bindings here for subexpressions; do this lazily
  141. ;;; if and when necessary.
  142.  
  143. ;;; Made sure is-constructor tests are generated even for tuples - jcp
  144.  
  145. (define (match-pcon pat exp pats exps alt block-name)
  146.   (let* ((var?    (is-type? 'var-ref exp))
  147.      (var     (if var?
  148.               (var-ref-var exp)
  149.               (create-temp-var 'conexp)))
  150.      (con     (pcon-con pat))
  151.      (arity   (con-arity con))
  152.      (subpats (pcon-pats pat))
  153.      (subexps '()))
  154.     (dotimes (i arity)
  155.       (push (**sel con (**var/def var) i) subexps))
  156.     (setf exps (nconc (nreverse subexps) exps))
  157.     (setf pats (append subpats pats))
  158.     (let ((tail  (match-pattern exps pats alt block-name)))
  159.       (setf tail
  160.         (**and-exp (**is-constructor (**var/def var) con) tail))
  161.       (when (not var?)
  162.     (setf tail
  163.           (**let (list (**valdef/def var (cfn-ast-1 exp))) tail)))
  164.       tail)))
  165.  
  166.  
  167. ;;; For as-pat, add a variable binding.
  168. ;;; If the expression being matched is not already a variable reference,
  169. ;;; take this opportunity to make the let binding.  Otherwise push the
  170. ;;; let-binding onto the where-decls.
  171.  
  172. (define (match-as-pat pat exp pats exps alt block-name)
  173.   (let ((var    (var-ref-var (as-pat-var pat)))
  174.     (subpat (as-pat-pattern pat)))
  175.     (if (is-type? 'var-ref exp)
  176.     (begin
  177.       (push (**valdef/def var (**var/def (var-ref-var exp)))
  178.         (alt-where-decls alt))
  179.       (match-pattern
  180.         (cons exp exps)
  181.         (cons subpat pats)
  182.         alt
  183.         block-name))
  184.     (**let (list (**valdef/def var (cfn-ast-1 exp)))
  185.            (match-pattern
  186.          (cons (**var/def var) exps)
  187.          (cons subpat pats)
  188.          alt
  189.          block-name)))))
  190.  
  191.  
  192. ;;; An irrefutable pattern adds no test to the pattern matching,
  193. ;;; but adds a pattern binding to the where-decls.
  194.  
  195. (define (match-irr-pat pat exp pats exps alt block-name)
  196.   (let ((subpat  (irr-pat-pattern pat)))
  197.     (push (**valdef/pat subpat exp) (alt-where-decls alt))
  198.     (match-pattern exps pats alt block-name)))
  199.  
  200.  
  201. ;;; A const pat has a little piece of code inserted by the typechecker
  202. ;;; to do the test.
  203. ;;; For matches against string constants, generate an inline test to match 
  204. ;;; on each character of the string.
  205.  
  206. (define (match-const-pat pat exp pats exps alt block-name)
  207.   (let ((const  (const-pat-value pat)))
  208.     (**and-exp 
  209.       (if (is-type? 'string-const const)
  210.       (let ((string  (string-const-value const)))
  211.         (if (string=? string "")
  212.         (**is-constructor exp (core-symbol "Nil"))
  213.         (**app (**var/def (core-symbol "primStringEq")) const exp)))
  214.       (cfn-ast-1 (**app (const-pat-match-fn pat) exp)))
  215.       (match-pattern exps pats alt block-name))
  216.     ))
  217.  
  218.  
  219. ;;; Plus pats have both a magic test and a piece of code to
  220. ;;; make a binding in the where-decls.  Make a variable binding
  221. ;;; for the exp if it's not already a variable.
  222.  
  223. (define (match-plus-pat pat exp pats exps alt block-name)
  224.   (let* ((var?  (is-type? 'var-ref exp))
  225.      (var   (if var? (var-ref-var exp) (create-temp-var 'plusexp))))
  226.     (push (**valdef/pat (plus-pat-pattern pat)
  227.             (**app (plus-pat-bind-fn pat) (**var/def var)))
  228.       (alt-where-decls alt))
  229.     (let ((tail  (match-pattern exps pats alt block-name)))
  230.       (setf tail
  231.         (**and-exp
  232.           (cfn-ast-1 (**app (plus-pat-match-fn pat) (**var/def var)))
  233.           tail))
  234.       (if var?
  235.       tail
  236.       (**let (list (**valdef/def var exp)) tail)))))
  237.  
  238. ;;; Dynamic pats - I have no clue what I'm doing (jcp)
  239. ;;; 
  240.  
  241. (define (match-dynamic-pat pat exp pats exps alt block-name)
  242.   (let* ((var?  (var-ref? exp))
  243.      (var   (if var? (var-ref-var exp) (create-temp-var 'dynexp)))
  244.      (uvar  (create-temp-var 'unify))
  245.      (sig   (dynamic-pat-sig pat))
  246.      (gtype (ast->gtype (signature-context sig) (signature-type sig)))
  247.      (pvars (map (lambda (x) (algdata-runtime-var x))
  248.              (dynamic-pat-runtime-vars pat))))
  249.     ;;; uvar = coerceB dynamic type
  250.     (push (**valdef/pat (**pat `(list ,@pvars))
  251.             (**tuple-sel 2 1
  252.                 (**sel (core-symbol "DSucc")
  253.                    (**var/def uvar)
  254.                    0)))
  255.       (alt-where-decls alt))
  256.     ;;; This pulls the value out of the dynamic pattern
  257.     (push (**valdef/pat (dynamic-pat-pat pat)
  258.             (**tuple-sel 2 0
  259.                 (**sel (core-symbol "DSucc")
  260.                    (**var/def uvar)
  261.                    0)))
  262.       (alt-where-decls alt))
  263.     (**let `(,(**valdef/def uvar
  264.         (**app (**var/def (core-symbol "coerceB"))
  265.                (**var/def var)
  266.                (rconvert-gtype gtype)))
  267.          ,@(if var? '() (list (**valdef/def var exp))))
  268.     (**and-exp
  269.      (cfn-ast-1 (**is-constructor (**var/def uvar) (core-symbol "DSucc")))
  270.      (match-pattern exps pats alt block-name)))))
  271.  
  272. ;;; Rewrite list pats as pcons, then process recursively.
  273.  
  274. (define (match-list-pat pat exp pats exps alt block-name)
  275.   (let ((newpat  (rewrite-list-pat (list-pat-pats pat))))
  276.     (match-pattern
  277.       (cons exp exps)
  278.       (cons newpat pats)
  279.       alt
  280.       block-name)))
  281.  
  282. (define (rewrite-list-pat subpats)
  283.   (if (null? subpats)
  284.       (**pcon/def (core-symbol "Nil") '())
  285.       (**pcon/def (core-symbol ":")
  286.           (list (car subpats)
  287.             (rewrite-list-pat (cdr subpats))))))
  288.  
  289.  
  290.  
  291.  
  292. ;;;=====================================================================
  293. ;;; Pattern definitions
  294. ;;;=====================================================================
  295.  
  296.  
  297. (define (do-cfn-pattern-def-top object)
  298.   (typecase (valdef-lhs object)
  299.     (var-pat
  300.       ;; If the pattern definition is a simple variable assignment, it
  301.       ;; may have dictionary parameters that need to be messed with.
  302.       ;; Complicated pattern bindings can't be overloaded in this way.
  303.       (list (add-dict-params object (do-cfn-pattern-def-simple object))))
  304.     (irr-pat
  305.       ;; Irrefutable patterns are redundant here.
  306.       (setf (valdef-lhs object) (irr-pat-pattern (valdef-lhs object)))
  307.       (do-cfn-pattern-def-top object))
  308.     (wildcard-pat
  309.      ;; Wildcards are no-ops.
  310.      '())
  311.     (pcon
  312.      ;; Special-case because it's frequent and general case creates
  313.      ;; such lousy code
  314.      (do-cfn-pattern-def-pcon object))
  315.     (else
  316.       (do-cfn-pattern-def-general object))))
  317.  
  318.  
  319. ;;; Do a "simple" pattern definition, e.g. one that already has a
  320. ;;; var-pat on the lhs.
  321.  
  322. (define (do-cfn-pattern-def-simple object)
  323.   (let* ((pat  (valdef-lhs object))
  324.      (sfd  (car (valdef-definitions object)))
  325.      (exp  (rewrite-guards-and-where-decls
  326.          (single-fun-def-where-decls sfd)
  327.          (single-fun-def-rhs-list sfd)
  328.          '#f)))
  329.   (**valdef/pat pat (cfn-ast-1 exp))))
  330.  
  331.  
  332. ;;; Destructure a pcon.
  333. ;;; Note that the simplified expansion is only valid if none of
  334. ;;; the subpatterns introduce tests.  Otherwise we must defer to
  335. ;;; the general case.
  336.  
  337. (define (do-cfn-pattern-def-pcon object)
  338.   (let* ((pat     (valdef-lhs object))
  339.      (subpats (pcon-pats pat)))
  340.     (if (every (function irrefutable-pat?) subpats)
  341.     (let* ((con     (pcon-con pat))
  342.            (arity   (con-arity con))
  343.            (alg     (con-alg con))
  344.            (tuple?  (algdata-tuple? alg))
  345.            (temp    (create-temp-var 'pbind))
  346.            (result  '()))
  347.       (dotimes (i arity)
  348.         (setf result
  349.           (nconc result
  350.              (do-cfn-pattern-def-top 
  351.                (**valdef/pat (pop subpats)
  352.                      (**sel con (**var/def temp) i))))))
  353.       (if (null? result)
  354.           '()
  355.           (let* ((sfd   (car (valdef-definitions object)))
  356.              (exp   (cfn-ast-1
  357.                   (rewrite-guards-and-where-decls
  358.                     (single-fun-def-where-decls sfd)
  359.                 (single-fun-def-rhs-list sfd)
  360.                 '#f))))
  361.         (when (not tuple?)
  362.           (let ((temp1  (create-temp-var 'cfn)))
  363.             (setf exp
  364.               (**let (list (**valdef/def temp1 exp))
  365.                  (**if (**is-constructor (**var/def temp1) con)
  366.                        (**var/def temp1)
  367.                        (make-failure-exp))))))
  368.         (cons (**valdef/def temp exp) result))))
  369.     (do-cfn-pattern-def-general object))))
  370.  
  371.  
  372.  
  373. ;;; Turn a complicated pattern definition into a list of simple ones.
  374. ;;; The idea is to use case to match the pattern and build a tuple of
  375. ;;; all the values which are being destructured into the pattern
  376. ;;; variables.
  377.  
  378. (define (do-cfn-pattern-def-general object)
  379.   (multiple-value-bind (new-pat vars new-vars)
  380.       (copy-pattern-variables (valdef-lhs object))
  381.     (if (not (null? vars))
  382.     (let* ((sfd      (car (valdef-definitions object)))
  383.            (exp      (rewrite-guards-and-where-decls
  384.                (single-fun-def-where-decls sfd)
  385.                (single-fun-def-rhs-list sfd)
  386.                '#f))
  387.            (arity    (length vars)))
  388.       (if (eqv? arity 1)
  389.           (list (**valdef/def
  390.               (var-ref-var (car vars))
  391.               (do-cfn-case
  392.                 exp
  393.             (list (**alt/simple new-pat (car new-vars))))))
  394.           (let ((temp     (create-temp-var 'pbind))
  395.             (bindings '()))
  396.         (dotimes (i arity)
  397.           (push (**valdef/def (var-ref-var (pop vars))
  398.                       (**tuple-sel arity i (**var/def temp)))
  399.             bindings))
  400.         (cons (**valdef/def
  401.                 temp
  402.             (do-cfn-case
  403.               exp
  404.               (list (**alt/simple new-pat (**tuple/l new-vars)))))
  405.               bindings))))
  406.     '())))
  407.  
  408.  
  409.  
  410. ;;; Helper function for above.
  411. ;;; All the variables in the pattern must be replaced with temporary
  412. ;;; variables.  
  413.  
  414. (define (copy-pattern-variables pat)
  415.   (typecase pat
  416.     (wildcard-pat
  417.       (values pat '() '()))
  418.     (var-pat
  419.       (let ((new  (create-temp-var (var-ref-name (var-pat-var pat)))))
  420.     (values (**var-pat/def new)
  421.         (list (var-pat-var pat))
  422.         (list (**var/def new)))))
  423.     (pcon
  424.       (multiple-value-bind (new-pats vars new-vars)
  425.       (copy-pattern-variables-list (pcon-pats pat))
  426.     (values (**pcon/def (pcon-con pat) new-pats)
  427.         vars
  428.         new-vars)))
  429.     (as-pat
  430.       (let ((new  (create-temp-var (var-ref-name (as-pat-var pat)))))
  431.     (multiple-value-bind (new-pat vars new-vars)
  432.         (copy-pattern-variables (as-pat-pattern pat))
  433.       (values
  434.         (make as-pat
  435.           (var (**var/def new))
  436.           (pattern new-pat))
  437.         (cons (as-pat-var pat) vars)
  438.         (cons (**var/def new) new-vars)))))
  439.     (irr-pat
  440.       (multiple-value-bind (new-pat vars new-vars)
  441.       (copy-pattern-variables (irr-pat-pattern pat))
  442.     (values
  443.       (make irr-pat (pattern new-pat))
  444.       vars
  445.       new-vars)))
  446.     (const-pat
  447.       (values pat '() '()))
  448.     (plus-pat
  449.       (multiple-value-bind (new-pat vars new-vars)
  450.       (copy-pattern-variables (plus-pat-pattern pat))
  451.     (values
  452.       (make plus-pat
  453.         (pattern new-pat)
  454.         (k (plus-pat-k pat))
  455.         (match-fn (plus-pat-match-fn pat))
  456.         (bind-fn (plus-pat-bind-fn pat)))
  457.       vars
  458.       new-vars)))
  459.     (dynamic-pat
  460.       (multiple-value-bind (new-pat vars new-vars)
  461.          (copy-pattern-variables (dynamic-pat-pat pat))
  462.        (values
  463.          (make dynamic-pat
  464.            (pat new-pat)
  465.            (sig (dynamic-pat-sig pat))
  466.            (runtime-vars (dynamic-pat-runtime-vars pat)))
  467.      vars
  468.      new-vars)))
  469.     (list-pat
  470.       (multiple-value-bind (new-pats vars new-vars)
  471.       (copy-pattern-variables-list (list-pat-pats pat))
  472.     (values (make list-pat (pats new-pats))
  473.         vars
  474.         new-vars)))
  475.     (else
  476.       (error "Unrecognized pattern ~s." pat))))
  477.  
  478. (define (copy-pattern-variables-list pats)
  479.   (let ((new-pats  '())
  480.     (vars      '())
  481.     (new-vars  '()))
  482.     (dolist (p pats)
  483.       (multiple-value-bind (p v n) (copy-pattern-variables p)
  484.     (push p new-pats)
  485.     (setf vars (nconc vars v))
  486.     (setf new-vars (nconc new-vars n))))
  487.     (values (nreverse new-pats)
  488.         vars
  489.         new-vars)))
  490.  
  491.  
  492.  
  493. ;;;=====================================================================
  494. ;;; Helper functions for processing guards and where-decls
  495. ;;;=====================================================================
  496.  
  497. ;;; Process guards and where-decls into a single expression.
  498. ;;; If block-name is non-nil, wrap the exp with a return-from.
  499. ;;; If block-name is nil, add a failure exp if necessary.
  500. ;;; Note that this does NOT do the CFN traversal on the result or
  501. ;;; any part of it.
  502.  
  503. (define (rewrite-guards-and-where-decls where-decls rhs-list block-name)
  504.   (if (null? where-decls)
  505.       (rewrite-guards rhs-list block-name)
  506.       (**let where-decls
  507.          (rewrite-guards rhs-list block-name))))
  508.  
  509. (define (rewrite-guards rhs-list block-name)
  510.   (if (null? rhs-list)
  511.       (if block-name
  512.       (**con/def (core-symbol "False"))
  513.       (make-failure-exp))
  514.       (let* ((rhs     (car rhs-list))
  515.          (guard   (guarded-rhs-guard rhs))
  516.          (exp     (guarded-rhs-rhs rhs)))
  517.     (when block-name
  518.       (setf exp (**return-from block-name exp)))
  519.     (cond ((is-type? 'omitted-guard (guarded-rhs-guard (car rhs-list)))
  520.            exp)
  521.           ((and block-name (null? (cdr rhs-list)))
  522.            (**and-exp guard exp))
  523.           (else
  524.            (**if guard
  525.              exp
  526.              (rewrite-guards (cdr rhs-list) block-name)))
  527.           ))))
  528.  
  529.  
  530. (define (make-failure-exp)
  531.   (let ((c  (dynamic *context*)))
  532.     (**abort
  533.       (if (not c)
  534.       "Pattern match failed."
  535.       (let* ((stuff  (ast-node-line-number c))
  536.          (line   (source-pointer-line stuff))
  537.          (file   (source-pointer-file stuff)))
  538.         (if (and (is-type? 'valdef c)
  539.              (is-type? 'var-pat (valdef-lhs c)))
  540.         (format
  541.           '#f
  542.           "Pattern match failed in function ~a at line ~s in file ~a."
  543.           (valdef-lhs c) line file)
  544.         (format
  545.           '#f
  546.           "Pattern match failed at line ~s in file ~a."
  547.           line file)))))))
  548.  
  549.  
  550.  
  551.  
  552.