home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / type / dynamic-typing.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.5 KB  |  136 lines  |  [TEXT/CCL2]
  1. ;;; Dynamic typing stuff
  2.  
  3. ;;; This takes an expression and generates the type of the expression
  4.  
  5. ;;; This is a stripped down version of the type-non-recursive function.
  6. ;;; The important difference is that monomorphism is not applied.
  7.  
  8. (define (dynamic-type-exp exp)
  9.   (let* ((temp-var (create-temp-var "DT"))
  10.      (decl (**valdef (**var-pat/def temp-var) '() exp))
  11.      (old-placeholders (dynamic *placeholders*)))
  12.     (setf (dynamic *placeholders*) '())
  13.     (let* ((rhs-type (type-decl-rhs decl))
  14.        (all-tyvars (collect-tyvars rhs-type))
  15.        (overloaded-tyvars '()))
  16.       (dolist (tyvar all-tyvars) ; This does not collect existential tyvars
  17.     (when (ntyvar-context tyvar)
  18.         (push tyvar overloaded-tyvars)))
  19.       ; Monomorphism does NOT apply here!!
  20.       (if (null? overloaded-tyvars)
  21.       (setf (var-type temp-var) (ntype->gtype rhs-type))
  22.       (mlet (((gtype tyvars)
  23.           (ntype->gtype/env rhs-type overloaded-tyvars)))
  24.          (setf (var-type temp-var) gtype)
  25.          (dictionary-conversion/definition decl tyvars)))
  26.       (setf (dynamic *placeholders*)
  27.         (process-placeholders
  28.          (dynamic *placeholders*) old-placeholders (list decl)))
  29.       (values decl (rconvert-gtype (var-type temp-var)) temp-var))))
  30.  
  31. (define (type-check-type-of arg)
  32.   (mlet (((decl ty _) (dynamic-type-exp arg)))
  33.     (return-type (**let (list decl) ty) *signature-type*)))
  34.      
  35.  
  36. (define (type-check-to-dynamic arg)
  37.   (mlet (((decl ty temp) (dynamic-type-exp arg)))
  38.     (return-type
  39.      (**let (list decl)
  40.         (**app (**con/def (core-symbol "MkDynamic")) ty (**var/def temp)))
  41.      *dynamic-type*)))
  42.  
  43. (define (type-check-from-dynamic object)
  44.  (type-check app arg arg-type
  45.   (type-unify arg-type *dynamic-type*
  46.     (type-mismatch/fixed object
  47.         "Argument of fromDynamic is not Dynamic" arg-type))
  48.   (fresh-monomorphic-type res-type
  49.       (let* ((temp-var (create-temp-var "DY"))
  50.          (temp2 (create-temp-var "Magic"))
  51.          (ty (ntype->gtype res-type)))
  52.     (setf (var-type temp-var) ty)
  53.     (setf (var-type temp2) *magic-type*)
  54.     (return-type 
  55.      (**let (list (**valdef/def
  56.                temp-var
  57.                (**case (**app (**var/def (core-symbol "coerce"))
  58.                       (app-arg object)
  59.                       (rconvert-gtype ty))
  60.                    (list
  61.                 (**alt/simple
  62.                  (**pcon/def (core-symbol "DFailure") '())
  63.                  (**abort "fromDynamic failed."))
  64.                 (**alt/simple
  65.                  (**pcon/def (core-symbol "DSucc")
  66.                          (list (**pat temp2)))
  67.                  (**var/def temp2))))))
  68.         (**var/def temp-var))
  69.      res-type)))))
  70.  
  71. (define-type-checker dynamic-pat
  72.   (let* ((sig (dynamic-pat-sig object))
  73.      (gt (ast->gtype (signature-context sig) (signature-type sig)))
  74.      (new-type (skolemize-gtype gt object)))
  75.     (type-check dynamic-pat pat pattern-type
  76.       (type-unify pattern-type new-type
  77.         (type-mismatch/fixed object
  78. "The pattern type is not compatible with the signature in a dynamic type"
  79.                pattern-type))
  80.       (return-type object *dynamic-type*))))
  81.  
  82. (define (skolemize-gtype gtype object)
  83.   (let ((new-types (map (function new-skolem-type) (gtype-context gtype))))
  84.     (setf (dynamic-pat-runtime-vars object) new-types)
  85.     (insert-skolem-types (gtype-type gtype) new-types)))
  86.  
  87. (define (new-skolem-type context)
  88.   (let* ((tname (gensym "eType"))
  89.      (tvar (create-temp-var "eTD"))
  90.      (stype (make algdata
  91.                   (name tname)
  92.           (unit *unit*)
  93.           (module *module-name*)
  94.           (n-constr 0)
  95.           (constrs '())
  96.           (context '())
  97.           (classes context)
  98.           (tyvars '())
  99.           (skolem-type? '#t)
  100.           (runtime-var tvar))))
  101.     stype))
  102.  
  103. (define (insert-skolem-types ty new-types)
  104.   (if (gtyvar? ty)
  105.       (**ntycon (list-ref new-types (gtyvar-varnum ty)) '())
  106.       (**ntycon (ntycon-tycon ty) (map (lambda (ty1)
  107.                      (insert-skolem-types ty1 new-types))
  108.                        (ntycon-args ty)))))
  109.  
  110. (define (remove-dynamic-type-context c)
  111.   (if (null? c)
  112.       c
  113.       (if (eq? (car c) (core-symbol "DynamicType"))
  114.       (cdr c)
  115.       (cons (car c) (remove-dynamic-type-context (cdr c))))))
  116.  
  117. ;;; Major bootstrap problem here: avoid looking at the sig of PatternMatchError
  118.  
  119. (define (type-check-pme object)
  120.   (let ((fn-type (**arrow
  121.           (**list-of
  122.            (**ntycon (core-symbol "Char") '()))
  123.           (**list-of
  124.            (**ntycon (core-symbol "Dynamic") '()))
  125.           (**ntyvar))))
  126.     (type-check app arg arg-type
  127.       (fresh-type res-type
  128.         (fresh-type arg-type-1
  129.           (type-unify fn-type (**arrow arg-type-1 res-type)
  130.               (type-mismatch/fixed object
  131.                "Attempt to call a non-function"
  132.                fn-type))
  133.       (type-unify arg-type-1 arg-type
  134.            (type-mismatch object
  135.             "Argument type mismatch" arg-type-1 arg-type))
  136.       (return-type object res