home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / type / type-decl.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  13.4 KB  |  362 lines  |  [TEXT/CCL2]
  1. ;;; This deals with declarations (let & letrec).  The input is a list of
  2. ;;; declarations (valdefs) which may contain recursive-decl-groups, as
  3. ;;; introduced in dependency analysis.  This function alters the list
  4. ;;; of non-generic type variables.  Expressions containing declarations
  5. ;;; need to rebind the non-generic list around the decls and all expressions
  6. ;;; within their scope.
  7.  
  8. ;;; This returns an updated decl list with recursive decl groups removed.
  9.  
  10. (define (type-decls decls)
  11.   (cond ((null? decls)
  12.      '())
  13.     ((is-type? 'recursive-decl-group (car decls))
  14.      (let ((d (recursive-decl-group-decls (car decls))))
  15.         (type-recursive d)
  16.        (append d (type-decls (cdr decls)))))
  17.     (else
  18.      (type-non-recursive (car decls))
  19.      (cons (car decls)
  20.            (type-decls (cdr decls))))))
  21.  
  22. ;;; This typechecks a mutually recursive group of declarations (valdefs).
  23. ;;; Generate a monomorphic variable for each declaration and unify it with
  24. ;;; the lhs of the decl.  The variable all-vars collects all variables defined
  25. ;;; by the declaration group.  Save the values of placeholders and ng-list
  26. ;;; before recursing.
  27.  
  28. ;;; The type of each variable is marked as recursive.
  29.  
  30. (define (type-recursive decls)
  31.   (let ((old-ng (dynamic *non-generic-tyvars*))
  32.     (old-placeholders (dynamic *placeholders*))
  33.     (all-vars '())
  34.     (new-tyvars '())
  35.     (decls+tyvars '()))
  36.     ;; on a type error set all types to `a' and give up.
  37.     (setf (dynamic *placeholders*) '())
  38.     (recover-type-error 
  39.        (lambda (r)
  40.      (make-dummy-sigs decls)
  41.      (setf (dynamic *placeholders*) old-placeholders)
  42.      (funcall r))
  43.        ;; Type the lhs of each decl and then mark each variable bound
  44.        ;; in the decl as recursive.
  45.        (dolist (d decls)
  46.     (add-error-handlers d)
  47.         (fresh-type lhs-type
  48.       (push lhs-type (dynamic *non-generic-tyvars*))
  49.       (push lhs-type new-tyvars)
  50.       (type-decl-lhs d lhs-type)
  51.       (push (tuple d lhs-type) decls+tyvars))
  52.     (dolist (var-ref (collect-pattern-vars (valdef-lhs d)))
  53.       (let ((var (var-ref-var var-ref)))
  54.         (push var all-vars)
  55.         (setf (var-type var)
  56.           (make recursive-type (type (var-type var))
  57.                            (placeholders '())
  58.                        (rsig (var-signature var)))))))
  59.  
  60. ;;; This types the decl right hand sides.  Each rhs type is unified with the
  61. ;;; tyvar corresponding to the lhs.  Before checking the signatures, the
  62. ;;; ng-list is restored.  
  63.  
  64.        (dolist (d decls+tyvars)
  65.      (let ((rhs-type (type-decl-rhs (tuple-2-1 d)))
  66.            (lhs-type (tuple-2-2 d)))
  67.        (type-unify lhs-type rhs-type
  68.          (type-mismatch (tuple-2-1 d)
  69.               "Decl type mismatch" lhs-type rhs-type))))
  70.        (setf (dynamic *non-generic-tyvars*) old-ng)
  71.        (let ((sig-contexts (check-user-signatures all-vars)))
  72.  
  73. ;;; This generalizes the signatures of recursive decls.  First, the
  74. ;;; context of the declaration group is computed.  Any tyvar in the
  75. ;;; bodies with a non-empty context must appear in all signatures that
  76. ;;; are non-ambiguous.
  77.       
  78.      (let* ((all-tyvars (collect-tyvars/l new-tyvars))
  79.         (overloaded-tyvars '()))
  80.        (dolist (tyvar all-tyvars)
  81.           (unless (non-generic? tyvar)
  82.          (when (ntyvar-context tyvar)
  83.            (push tyvar overloaded-tyvars))))
  84.        (reconcile-sig-contexts overloaded-tyvars sig-contexts)
  85.      ;; We should probably also emit a warning about inherently
  86.      ;; ambiguous decls.
  87.        (when (and overloaded-tyvars
  88.               (apply-pattern-binding-rule? decls))
  89.          (setf (dynamic *non-generic-tyvars*)
  90.                (do-pattern-binding-rule
  91.             decls overloaded-tyvars old-ng))
  92.          (setf overloaded-tyvars '()))
  93.        ;;; Hack Hack Kludge!!
  94.        (let ((v '()))
  95.          (dolist (tyvar overloaded-tyvars)
  96.              (setf (ntyvar-context tyvar)
  97.                (remove-dynamic-type-context (ntyvar-context tyvar)))
  98.          (when (ntyvar-context tyvar)
  99.              (push tyvar v)))
  100.          (setf overloaded-tyvars v))
  101.      ;; The next step is to compute the signatures of the defined
  102.      ;; variables and to define all recursive placeholders.  When
  103.      ;; there is no context the placeholders become simple var refs.
  104.      ;; and the types are simply converted.
  105.        (cond ((null? overloaded-tyvars)
  106.           (dolist (var all-vars)
  107.             (let ((r (var-type var)))
  108.               (setf (var-type var) (recursive-type-type (var-type var)))
  109.               (dolist (p (recursive-type-placeholders r))
  110.                 (setf (recursive-placeholder-exp p)
  111.                   (**var/def var)))
  112.               (generalize-type var))))
  113.      ;; When the declaration has a context things get very hairy.
  114.      ;; First, grap the recursive placeholders before generalizing the
  115.      ;; types.
  116.          (else
  117.           ;; Mark the overloaded tyvars as read-only.  This prevents
  118.           ;; signature unification from changing the set of tyvars
  119.           ;; defined in the mapping.
  120.           (dolist (tyvar overloaded-tyvars)
  121. ;                   (when (memq (core-symbol "DynamicType")
  122. ;                      (ntyvar-context tyvar))
  123. ;                (phase-error 'lazy-implementor
  124. ;  "A dynamic type has leaked into a recursive declaration: ~A" decls))
  125.              (setf (ntyvar-read-only? tyvar) '#t))
  126.           (let ((r-placeholders '()))
  127.             (dolist (var all-vars)
  128.              (let ((rt (var-type var)))
  129.               (dolist (p (recursive-type-placeholders rt))
  130.             (push p r-placeholders))
  131.               (setf (var-type var) (recursive-type-type rt))))
  132.      ;; Now compute a signature for each definition and do dictionary
  133.      ;; conversion.  The var-map defines the actual parameter associated
  134.      ;; with each of the overloaded tyvars.
  135.             (let ((var-map (map (lambda (decl)
  136.                      (tuple (decl-var decl)
  137.                       (generalize-overloaded-type
  138.                        decl overloaded-tyvars)))
  139.                     decls)))
  140.      ;; Finally discharge each recursive placeholder.
  141.               (dolist (p r-placeholders)
  142.             (let ((ref-to (recursive-placeholder-var p))
  143.                   (decl-from
  144.                    (search-enclosing-decls
  145.                  (recursive-placeholder-enclosing-decls p)
  146.                  decls)))
  147.               (setf (recursive-placeholder-exp p)
  148.                 (recursive-call-code decl-from ref-to var-map)))
  149.             )))))
  150.        (setf (dynamic *placeholders*)
  151.          (process-placeholders
  152.           (dynamic *placeholders*) old-placeholders decls)))))))
  153.  
  154. ;;; Non-recursive decls are easier.  Save the placeholders, use a fresh type
  155. ;;; for the left hand side, check signatures, and generalize.
  156.  
  157. (define (type-non-recursive decl)
  158.  (remember-context decl
  159.   (add-error-handlers decl)
  160.   (fresh-type lhs-type
  161.     (let ((old-placeholders (dynamic *placeholders*))
  162.       (all-vars (map (lambda (x) (var-ref-var x))
  163.                 (collect-pattern-vars (valdef-lhs decl)))))
  164.      (setf (dynamic *placeholders*) '())
  165.      (recover-type-error
  166.       (lambda (r)
  167.         (make-dummy-sigs (list decl))
  168.     (setf (dynamic *placeholders*) old-placeholders)
  169.         (funcall r))
  170.       (type-decl-lhs decl lhs-type)
  171.       (let ((rhs-type (type-decl-rhs decl)))
  172.     (type-unify lhs-type rhs-type
  173.            (type-mismatch decl
  174.            "Decl type mismatch" lhs-type rhs-type)))
  175.       (check-user-signatures all-vars)
  176.       (let ((all-tyvars (collect-tyvars lhs-type))
  177.         (overloaded-tyvars '()))
  178.     (dolist (tyvar all-tyvars)
  179.       (when (ntyvar-context tyvar)
  180.          (push tyvar overloaded-tyvars)))
  181.     (when (and overloaded-tyvars
  182.            (apply-pattern-binding-rule? (list decl)))
  183.      (setf (dynamic *non-generic-tyvars*)
  184.        (do-pattern-binding-rule
  185.         (list decl) overloaded-tyvars (dynamic *non-generic-tyvars*)))
  186.      (setf overloaded-tyvars '()))
  187.     (if (null? overloaded-tyvars)
  188.         (dolist (var all-vars)
  189.           (generalize-type var))
  190.         (generalize-overloaded-type decl '()))
  191.     (setf (dynamic *placeholders*)
  192.           (process-placeholders
  193.            (dynamic *placeholders*) old-placeholders (list decl)))))))))
  194.  
  195. ;;; These functions type check definition components.
  196.  
  197. ;;; This unifies the type of the lhs pattern with a type variable.
  198.  
  199. (define (type-decl-lhs object type)
  200.  (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*))))
  201.   (remember-context object
  202.    (type-check valdef lhs pat-type
  203.     (type-unify type pat-type #f)))))
  204.  
  205.  
  206. ;;; This types the right hand side.  The *enclosing-decls* variable is
  207. ;;; used to keep track of which decl the type checker is inside.  This
  208. ;;; is needed for both defaulting (to find which module defaults apply)
  209. ;;; and recursive types to keep track of the dictionary parameter variables
  210. ;;; for recursive references.
  211.  
  212. (define *remember-valdef* '())
  213.  
  214. (define (type-decl-rhs object)
  215.  (dynamic-let ((*enclosing-decls* (cons object (dynamic *enclosing-decls*))))
  216.   (remember-context object
  217.    (setf *remember-valdef* object) ; sleazy way to get a better error msg
  218.    (type-check/unify-list valdef definitions res-type
  219.        (type-mismatch/list object
  220.        "Definitions have different types")
  221.        res-type))))
  222.  
  223. ;;; This is similar to typing lambda.
  224.  
  225. (define-type-checker single-fun-def
  226.   (fresh-monomorphic-types (length (single-fun-def-args object)) tyvars
  227.     (type-check/list single-fun-def args arg-types
  228.       (unify-list tyvars arg-types)
  229.       (type-check/decls single-fun-def where-decls
  230.         (type-check/unify-list single-fun-def rhs-list rhs-type
  231.            (type-mismatch/list
  232.               (make valdef (lhs (valdef-lhs *remember-valdef*))
  233.                    (definitions (list object)))
  234.             "Guarded expressions have incompatible types")
  235.       (return-type object (**arrow/l-2 arg-types rhs-type)))))))
  236.  
  237.  
  238. ;;; These functions are part of the generalization process.
  239.  
  240. ;;; This function processes user signature declarations for the set of
  241. ;;; variables defined in a declaration.  Since unification of one signature
  242. ;;; may change the type associated with a previously verified signature,
  243. ;;; signature unification is done twice unless only one variable is
  244. ;;; involved.  The context of the signatures is returned to compare
  245. ;;; with the overall context of the declaration group.
  246.  
  247. (define (check-user-signatures vars)
  248.   (cond ((null? (cdr vars))
  249.      (let* ((var (car vars))
  250.         (sig (var-signature var)))
  251.        (if (eq? sig '#f)
  252.            '()
  253.            (list (tuple var (check-var-signature var sig))))))
  254.     (else
  255.      (let ((sigs '()))
  256.        (dolist (var vars)
  257.          (let ((sig (var-signature var)))
  258.            (unless (eq? sig '#f)
  259.          (check-var-signature var sig))))
  260.        (dolist (var vars)
  261.          (let ((sig (var-signature var)))
  262.            (unless (eq? sig '#f)
  263.          (push (tuple var (check-var-signature var sig)) sigs))))
  264.        sigs))))
  265.  
  266.  
  267. (define (check-var-signature var sig)
  268.   (mlet (((sig-type sig-vars) (instantiate-gtype/newvars sig)))
  269.     (dolist (tyvar sig-vars)
  270.       (setf (ntyvar-read-only? tyvar) '#t))
  271.     (type-unify (remove-recursive-type (var-type var)) sig-type
  272.          (signature-mismatch var))
  273.     (dolist (tyvar sig-vars)
  274.       (setf (ntyvar-read-only? tyvar) '#f))
  275.     sig-vars))
  276.   
  277. ;;; Once the declaration context is computed, it must be compared to the
  278. ;;; contexts given by the user.  All we need to check is that all tyvars
  279. ;;; constrained in the user signatures are also in the decl-context.
  280. ;;; All user supplied contexts are correct at this point - we just need
  281. ;;; to see if some ambiguous portion of the context exists.
  282.  
  283. ;;; This error message needs work.  We need to present the contexts.
  284.  
  285. (define (reconcile-sig-contexts overloaded-tyvars sig-contexts)
  286.   (dolist (sig sig-contexts)
  287.     (let ((sig-vars (tuple-2-2 sig)))
  288.       (dolist (d overloaded-tyvars)
  289.     (when (not (memq d sig-vars))
  290.       (type-error
  291. "Declaration signature has insufficiant context in declaration~%~A~%"
  292.             (tuple-2-1 sig)))))))
  293.  
  294. ;;; This is used for noisy type inference
  295.  
  296. (define (report-typing var)
  297.  (when (memq 'type (dynamic *printers*))
  298.   (let* ((name (symbol->string (def-name var))))
  299.     (when (not (or (string-starts? "sel-" name)
  300.            (string-starts? "i-" name)
  301.            (string-starts? "default-" name)
  302.            (string-starts? "dict-" name)))
  303.       (format '#t "~A :: ~A~%" var (var-type var))))))
  304.  
  305. ;;; This is used during error recovery.  When a type error occurs, all
  306. ;;; variables defined in the enclosing declaration are set to type `a'
  307. ;;; and typing is resumed.
  308.  
  309. ;;; 12/93 - Changed this to use user supplied signatures when present.
  310.  
  311. (define (make-dummy-sigs decls)
  312.   (let ((dummy-type (make gtype (context '(()))
  313.                     (type (**gtyvar 0)))))
  314.     (dolist (d decls)
  315.       (dolist (var-ref (collect-pattern-vars (valdef-lhs d)))
  316.         (let ((var (var-ref-var var-ref)))
  317.       (if (eq? (var-signature var) '#f)
  318.           (setf (var-type var) dummy-type)
  319.           (setf (var-type var) (var-signature var))))))))
  320.  
  321.  
  322. ;;; This is used to generalize the variable signatures.  If there is
  323. ;;; an attached signature, the signature is used.  Otherwise the ntype
  324. ;;; is converted to a gtype.
  325.  
  326. (define (generalize-type var)
  327.   (if (eq? (var-signature var) '#f)
  328.       (setf (var-type var) (ntype->gtype (var-type var)))
  329.       (setf (var-type var) (var-signature var)))
  330.   (report-typing var))
  331.       
  332. ;;; For overloaded types, it is necessary to map the declaration context
  333. ;;; onto the generalized type.  User signatures may provide different but
  334. ;;; equivilant contexts for different declarations in a decl goup.
  335.  
  336. ;;; The overloaded-vars argument allows ambiguous contexts.  This is not
  337. ;;; needed for non-recursive vars since the context cannot be ambiguous.
  338.  
  339. (define (generalize-overloaded-type decl overloaded-vars)
  340.   (let* ((var (decl-var decl))
  341.      (sig (var-signature var))
  342.      (new-tyvars '()))
  343.     (cond ((eq? sig '#f)
  344.        (mlet (((gtype tyvars)
  345.            (ntype->gtype/env (var-type var) overloaded-vars)))
  346.           (setf (var-type var) gtype)
  347.           (setf new-tyvars tyvars)))
  348.       (else
  349.        (mlet (((ntype tyvars) (instantiate-gtype/newvars sig)))
  350.          (unify ntype (var-type var))
  351.          (setf (var-type var) sig)
  352.          (setf new-tyvars (prune/l tyvars)))))
  353.     (report-typing var)
  354.     (dictionary-conversion/definition decl new-tyvars)
  355.     new-tyvars))
  356.  
  357. (define (remove-recursive-type ty)
  358.   (if (recursive-type? ty)
  359.       (recursive-type-type ty)
  360.       ty))
  361.  
  362.