home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / type-utils.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  11.6 KB  |  251 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; The `prune' function removes instantiated type variables at the
  3. ;;; top level of a type.
  4.  
  5. ;;; It returns an uninstantiated type variable or a type constructor.
  6.  
  7. (define-integrable (prune ntype)
  8.   (if (ntyvar? ntype)
  9.       (if (instantiated? ntype)
  10.       (prune-1 (ntyvar-value ntype))
  11.       ntype)
  12.       ntype))
  13.  
  14. ;;; This is because lucid can't hack inlining recursive fns.
  15.  
  16. (define (prune-1 x) (prune x))
  17.  
  18. (define-integrable (instantiated? ntyvar)
  19.   (ntyvar-value ntyvar))
  20. ;  (not (eq? (ntyvar-value ntyvar) '#f)))  ;*** Lucid compiler bug?
  21.  
  22. (define (prune/l l)
  23.   (map (function prune) l))
  24.  
  25.  
  26. ;;; These functions convert between AST types and gtypes.  Care is taken to
  27. ;;; ensure that the gtyvars are in the same order that they appear in the
  28. ;;; context.  This is needed to make dictionary conversion work right.
  29.  
  30. (define (ast->gtype context type)
  31.   (mlet (((gcontext env) (context->gcontext context '() '()))
  32.      ((type env1) (type->gtype type env))
  33.      (gcontext-classes (arrange-gtype-classes env1 gcontext)))
  34.     (**gtype gcontext-classes type)))
  35.  
  36. ;;; This is similar except that the ordering of the tyvars is as defined in
  37. ;;; the data type.  This is used only for instance declarations and allows
  38. ;;; for simple context implication checks.  It also used by the signature
  39. ;;; of the dictionary variable.
  40.  
  41. (define (ast->gtype/inst context type)
  42.   (mlet (((type env) (type->gtype type '()))
  43.      ((gcontext env1) (context->gcontext context '() env))
  44.      (gcontext-classes (arrange-gtype-classes env1 gcontext)))
  45.     (**gtype gcontext-classes type)))
  46.  
  47. ;;; This converts a context into gtype form [[class]]: a list of classes
  48. ;;; for each gtyvar.  This returns the context and the gtyvar environment.
  49.  
  50. (define (context->gcontext context gcontext env)
  51.   (if (null? context)
  52.       (values gcontext env)
  53.       (mlet ((sym (context-tyvar (car context)))
  54.          (class (class-ref-class (context-class (car context))))
  55.          ((n new-env) (ast->gtyvar sym env))
  56.          (old-context (get-gtyvar-context n gcontext))
  57.          (new-context (merge-single-class class old-context))
  58.          (new-gcontext (cons (tuple n new-context) gcontext)))
  59.     (context->gcontext (cdr context) new-gcontext new-env))))
  60.  
  61. ;;; This assigns a gtyvar number to a tyvar name.
  62.  
  63. (define (ast->gtyvar sym env)
  64.   (let ((res (assq sym env)))
  65.     (if (eq? res '#f)
  66.     (let ((n (length env)))
  67.       (values n (cons (tuple sym n) env)))
  68.     (values (tuple-2-2 res) env))))
  69.  
  70. (define (get-gtyvar-context n gcontext)
  71.   (cond ((null? gcontext)
  72.      '())
  73.     ((eqv? n (tuple-2-1 (car gcontext)))
  74.      (tuple-2-2 (car gcontext)))
  75.     (else (get-gtyvar-context n (cdr gcontext)))))
  76.  
  77. (define (type->gtype type env)
  78.   (if (tyvar? type)
  79.       (mlet (((n env1) (ast->gtyvar (tyvar-name type) env)))
  80.     (values (**gtyvar n) env1))
  81.       (mlet (((types env1) (type->gtype/l (tycon-args type) env)))
  82.     (values (**ntycon (tycon-def type) types) env1))))
  83.  
  84. (define (type->gtype/l types env)
  85.   (if (null? types)
  86.       (values '() env)
  87.       (mlet (((type env1) (type->gtype (car types) env))
  88.          ((other-types env2) (type->gtype/l (cdr types) env1)))
  89.      (values (cons type other-types) env2))))
  90.  
  91. (define (arrange-gtype-classes env gcontext)
  92.   (arrange-gtype-classes-1 0 (length env) env gcontext))
  93.  
  94. (define (arrange-gtype-classes-1 m n env gcontext)
  95.   (if (equal? m n)
  96.       '()
  97.       (cons (get-gtyvar-context m gcontext)
  98.         (arrange-gtype-classes-1 (1+ m) n env gcontext))))
  99.  
  100. ;;; These routines convert gtypes back to ordinary types.
  101.  
  102. (define (instantiate-gtype g)
  103.  (mlet (((gtype _) (instantiate-gtype/newvars g)))
  104.     gtype))
  105.  
  106. (define (instantiate-gtype/newvars g)
  107.   (if (null? (gtype-context g))
  108.       (values (gtype-type g) '())
  109.       (let ((new-tyvars (create-new-tyvars (gtype-context g))))
  110.     (values (copy-gtype (gtype-type g) new-tyvars) new-tyvars))))
  111.  
  112. (define (create-new-tyvars ctxts)
  113.   (if (null? ctxts)
  114.       '()
  115.       (let ((tyvar (**ntyvar)))
  116.     (setf (ntyvar-context tyvar) (map (function forward-def) (car ctxts)))
  117.     (cons tyvar (create-new-tyvars (cdr ctxts))))))
  118.  
  119. (define (copy-gtype g env)
  120.   (cond ((ntycon? g)
  121.      (**ntycon (forward-def (ntycon-tycon g))
  122.            (map (lambda (g1) (copy-gtype g1 env))
  123.             (ntycon-args g))))
  124.     ((ntyvar? g)
  125.      g)
  126.     ((gtyvar? g)
  127.      (list-ref env (gtyvar-varnum g)))
  128.     ((const-type? g)
  129.      (const-type-type g))))
  130.  
  131. ;;; ntypes may contain synonyms.  These are expanded here.  Only the
  132. ;;; top level synonym is expanded.
  133.  
  134. (define (expand-ntype-synonym type)
  135.  (let ((type (prune type)))
  136.   (if (ntycon? type)
  137.       (let ((syn (forward-def (ntycon-tycon type))))
  138.     (if (synonym? syn)
  139.         (expand-ntype-synonym
  140.          (expand-ntype-synonym-1 (synonym-body syn)
  141.                      (map(car ctxt1) (car ctxt2))
  142.        (full-context-implies? (cdr ctxt1) (cdr ctxt2)))))
  143.  
  144. ;;; This is used to avoid type circularity on unification.
  145.  
  146. (define (occurs-in-type tyvar type) ; Cardelli algorithm
  147.   (let ((type (prune type)))
  148.     (if (ntyvar? type)
  149.     (eq? type tyvar)
  150.     (occurs-in-type/l tyvar (ntycon-args type)))))
  151.  
  152. ; Does a tyvar occur in a list of types?
  153. (define (occurs-in-type/l tyvar types)
  154.   (if (null? types)
  155.       '#f
  156.       (or (occurs-in-type tyvar (car types))
  157.       (occurs-in-type/l tyvar (cdr types)))))
  158.  
  159. (define-integrable (non-generic? tyvar)
  160.   (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*)))
  161.  
  162. (define (collect-tyvars ntype)
  163.   (collect-tyvars-1 ntype '()))
  164.  
  165. (define (collect-tyvars-1 ntype vars)
  166.  (let ((ntype (prune ntype)))
  167.   (if (ntyvar? ntype)
  168.       (if (or (memq ntype vars) (non-generic? ntype))
  169.       vars
  170.       (cons ntype vars))
  171.       (collect-tyvars/l-1 (ntycon-args ntype) vars))))
  172.  
  173. (define (collect-tyvars/l types)
  174.   (collect-tyvars/l-1 types '()))
  175.  
  176. (define (collect-tyvars/l-1 types vars)
  177.   (if (null? types)
  178.       vars
  179.       (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars))))
  180.  
  181. ;;; Random utilities
  182.  
  183. (define (decl-var decl)
  184.   (var-ref-var (var-pat-var (valdef-lhs decl))))
  185.  
  186. ;;; Support for dynamic typing
  187.  
  188. (define (rconvert-gtype gtype)
  189.   (**app (**con/def (core-symbol "MkSignature"))
  190.      (rconvert-context (gtype-context gtype))
  191.      (rconvert-ntype (gtype-type gtype))))
  192.  
  193. (define (rconvert-context ctxt)
  194.  (**list/l (map (lambda (cl)
  195.            (**list/l (map (lambda (c)
  196.                      (**var/def (class-runtime-var c)))
  197.                    cl)))
  198.          ctxt)))
  199.  
  200. (predefine (remember-placeholder p))
  201.  
  202. (define (rconvert-ntype ntype)
  203.  (setf ntype (expand-ntype-synonym ntype))
  204.  (cond ((ntycon? ntype)
  205.     (let ((tycon (forward-def (ntycon-tycon ntype))))
  206.       (if (algdata-skolem-type? tycon)
  207.           (rconvert-tycon tycon)
  208.           (**app (**con/def (core-symbol "Tycon"))
  209.              (rconvert-tycon tycon)
  210.              (**list/l (map (function rconvert-ntype)
  211.                     (ntycon-args ntype)))))))
  212.        ((gtyvar? ntype)
  213.     (**app (**con/def (core-symbol "Tyvar"))
  214.            (**int (gtyvar-varnum ntype))))
  215.        ((ntyvar? ntype)
  216.     (setf (ntyvar-context ntype)
  217.       (if (null? (ntyvar-context ntype))
  218.           (list (core-symbol "DynamicType"))
  219.           (merge-contexts (list (core-symbol "DynamicType"))
  220.                   (ntyvar-context ntype))))
  221.     (let ((p (**dtype-placeholder ntype)))
  222.       (remember-placeholder p)
  223.       p))
  224.        (else
  225.     (error "Bad gtype in rconvert-ntype!"))))
  226.  
  227. (define (rconvert-tycon tycon)
  228.   (setf tycon (forward-def tycon))
  229.   (if (eq? tycon *undefined-def*)
  230.       (**null) ; just filler
  231.       (if (algdata-real-tuple? tycon)
  232.       (**app (**var/def (core-symbol "genTupleType"))
  233.          (**int (tuple-constructor-arity
  234.              (car (algdata-constrs tycon)))))
  235.       (**var/def (algdata-runtime-var tycon)))))
  236.  
  237. (define (**dtype-placeholder tyvar)
  238.    (make dtype-placeholder (exp '#f) (tyvar tyvar)))
  239.  
  240.  
  241. ;;; This removed the dynamic class from a context
  242.  
  243. (define (remove-dynamic classes)
  244.   (if (null? classes)
  245.       '()
  246.       (if (eq? (car classes) (core-symbol "DynamicType"))
  247.       (cdr classes)
  248.       (cons (car classes) (remove-dynamic (cdr classes))))))
  249.  
  250.  
  251.