1 files changed, 308 insertions, 0 deletions
diff --git a/util/type-utils.scm b/util/type-utils.scm
new file mode 100644
index 0000000..c9b4504
--- /dev/null
+++ b/util/type-utils.scm
@@ -0,0 +1,308 @@
+
+;;; The `prune' function removes instantiated type variables at the
+;;; top level of a type.
+
+;;; It returns an uninstantiated type variable or a type constructor.
+
+(define-integrable (prune ntype)
+  (if (ntyvar? ntype)
+      (if (instantiated? ntype)
+	  (prune-1 (ntyvar-value ntype))
+	  ntype)
+      ntype))
+
+;;; This is because lucid can't hack inlining recursive fns.
+
+(define (prune-1 x) (prune x))
+
+(define-integrable (instantiated? ntyvar)
+  (ntyvar-value ntyvar))
+;  (not (eq? (ntyvar-value ntyvar) '#f)))  ;*** Lucid compiler bug?
+
+(define (prune/l l)
+  (map (function prune) l))
+
+
+;;; These functions convert between AST types and gtypes.  Care is taken to
+;;; ensure that the gtyvars are in the same order that they appear in the
+;;; context.  This is needed to make dictionary conversion work right.
+
+(define (ast->gtype context type)
+  (mlet (((gcontext env) (context->gcontext context '() '()))
+	 ((type env1) (type->gtype type env))
+	 (gcontext-classes (arrange-gtype-classes env1 gcontext)))
+    (**gtype gcontext-classes type)))
+
+;;; This is similar except that the ordering of the tyvars is as defined in
+;;; the data type.  This is used only for instance declarations and allows
+;;; for simple context implication checks.  It also used by the signature
+;;; of the dictionary variable.
+
+(define (ast->gtype/inst context type)
+  (mlet (((type env) (type->gtype type '()))
+	 ((gcontext env1) (context->gcontext context '() env))
+	 (gcontext-classes (arrange-gtype-classes env1 gcontext)))
+    (**gtype gcontext-classes type)))
+
+;;; This converts a context into gtype form [[class]]: a list of classes
+;;; for each gtyvar.  This returns the context and the gtyvar environment.
+
+(define (context->gcontext context gcontext env)
+  (if (null? context)
+      (values gcontext env)
+      (mlet ((sym (context-tyvar (car context)))
+	     (class (class-ref-class (context-class (car context))))
+	     ((n new-env) (ast->gtyvar sym env))
+	     (old-context (get-gtyvar-context n gcontext))
+	     (new-context (merge-single-class class old-context))
+	     (new-gcontext (cons (tuple n new-context) gcontext)))
+	(context->gcontext (cdr context) new-gcontext new-env))))
+
+;;; This assigns a gtyvar number to a tyvar name.
+
+(define (ast->gtyvar sym env)
+  (let ((res (assq sym env)))
+    (if (eq? res '#f)
+	(let ((n (length env)))
+	  (values n (cons (tuple sym n) env)))
+	(values (tuple-2-2 res) env))))
+
+(define (get-gtyvar-context n gcontext)
+  (cond ((null? gcontext)
+	 '())
+	((eqv? n (tuple-2-1 (car gcontext)))
+	 (tuple-2-2 (car gcontext)))
+	(else (get-gtyvar-context n (cdr gcontext)))))
+
+(define (type->gtype type env)
+  (if (tyvar? type)
+      (mlet (((n env1) (ast->gtyvar (tyvar-name type) env)))
+	(values (**gtyvar n) env1))
+      (mlet (((types env1) (type->gtype/l (tycon-args type) env)))
+	(values (**ntycon (tycon-def type) types) env1))))
+
+(define (type->gtype/l types env)
+  (if (null? types)
+      (values '() env)
+      (mlet (((type env1) (type->gtype (car types) env))
+	     ((other-types env2) (type->gtype/l (cdr types) env1)))
+	 (values (cons type other-types) env2))))
+
+(define (arrange-gtype-classes env gcontext)
+  (arrange-gtype-classes-1 0 (length env) env gcontext))
+
+(define (arrange-gtype-classes-1 m n env gcontext)
+  (if (equal? m n)
+      '()
+      (cons (get-gtyvar-context m gcontext)
+	    (arrange-gtype-classes-1 (1+ m) n env gcontext))))
+
+;;; These routines convert gtypes back to ordinary types.
+
+(define (instantiate-gtype g)
+ (mlet (((gtype _) (instantiate-gtype/newvars g)))
+    gtype))
+
+(define (instantiate-gtype/newvars g)
+  (if (null? (gtype-context g))
+      (values (gtype-type g) '())
+      (let ((new-tyvars (create-new-tyvars (gtype-context g))))
+	(values (copy-gtype (gtype-type g) new-tyvars) new-tyvars))))
+
+(define (create-new-tyvars ctxts)
+  (if (null? ctxts)
+      '()
+      (let ((tyvar (**ntyvar)))
+	(setf (ntyvar-context tyvar) (car ctxts))
+	(cons tyvar (create-new-tyvars (cdr ctxts))))))
+
+(define (copy-gtype g env)
+  (cond ((ntycon? g)
+	 (**ntycon (ntycon-tycon g)
+		   (map (lambda (g1) (copy-gtype g1 env))
+			(ntycon-args g))))
+	((ntyvar? g)
+	 g)
+	((gtyvar? g)
+	 (list-ref env (gtyvar-varnum g)))
+	((const-type? g)
+	 (const-type-type g))))
+
+;;; ntypes may contain synonyms.  These are expanded here.  Only the
+;;; top level synonym is expanded.
+
+(define (expand-ntype-synonym type)
+  (if (and (ntycon? type)
+	   (synonym? (ntycon-tycon type)))
+      (let ((syn (ntycon-tycon type)))
+	(expand-ntype-synonym
+  	  (expand-ntype-synonym-1 (synonym-body syn)
+				  (map (lambda (var val)
+					 (tuple var val))
+				       (synonym-args syn)
+				       (ntycon-args type)))))
+      type))
+
+(define (expand-ntype-synonym-1 type env)
+  (if (tyvar? type)
+      (tuple-2-2 (assq (tyvar-name type) env))
+      (**ntycon (tycon-def type)
+		(map (lambda (ty) (expand-ntype-synonym-1 ty env))
+		     (tycon-args type)))))
+
+;;; This is used in generalization.  Note that ntyvars will remain when
+;;; non-generic tyvars are encountered.
+
+(define (ntype->gtype ntype)
+  (mlet (((res _) (ntype->gtype/env ntype '())))
+    res))
+
+(define (ntype->gtype/env ntype required-vars)
+  (mlet (((gtype env) (ntype->gtype-1 ntype required-vars)))
+   (values 
+    (make gtype (type gtype) (context (map (lambda (x) (ntyvar-context x))
+					  env)))
+    env)))
+
+(define (ntype->gtype-1 ntype env)
+ (let ((ntype (prune ntype)))
+  (cond ((ntycon? ntype)
+	 (mlet (((args env1) (ntype->gtype/l (ntycon-args ntype) env)))
+	   (values (**ntycon (ntycon-tycon ntype) args) env1)))
+	(else
+	 (ntyvar->gtyvar ntype env)))))
+
+(define (ntype->gtype/l types env)
+  (if (null? types)
+      (values '() env)
+      (mlet (((type env1) (ntype->gtype-1 (car types) env))
+	     ((types2 env2) (ntype->gtype/l (cdr types) env1)))
+	(values (cons type types2) env2))))
+
+(define (ntyvar->gtyvar ntyvar env)
+  (if (non-generic? ntyvar)
+      (values ntyvar env)
+      (let ((l (list-pos ntyvar env)))
+	(if (eq? l '#f)
+	    (values (**gtyvar (length env)) (append env (list ntyvar)))
+	    (values (**gtyvar l) env)))))
+     
+(define (list-pos x l)
+  (list-pos-1 x l 0))
+
+(define (list-pos-1 x l n)
+  (cond ((null? l)
+	 '#f)
+	((eq? x (car l))
+	 n)
+	(else
+	 (list-pos-1 x (cdr l) (1+ n)))))
+
+
+;;; These utils are used in dictionary conversion.
+
+(define (**dsel/method class method dict-code)
+  (let ((pos (locate-in-list method (class-method-vars class) 0)))
+    (**tuple-sel (class-dict-size class) pos dict-code)))
+
+(define (**dsel/dict class dict-class dict-code)
+  (let ((pos (locate-in-list
+	      dict-class (class-super* class) (class-n-methods class))))
+    (**tuple-sel (class-dict-size class) pos dict-code)))
+  
+(define (locate-in-list var l pos)
+  (if (null? l)
+      (error "Locate in list failed")
+      (if (eq? var (car l))
+	  pos
+	  (locate-in-list var (cdr l) (1+ pos)))))
+
+;;; These routines deal with contexts.  A context is a list classes.
+
+;;; A context is normalized whenever class is a superclass of another.
+
+(define (merge-contexts ctxt1 ctxt2)
+  (if (null? ctxt1)
+      ctxt2
+      (merge-single-class (car ctxt1) (merge-contexts (cdr ctxt1) ctxt2))))
+
+;;; This could perhaps avoid some consing but I don't imagine it would
+;;; make much difference.
+
+(define (merge-single-class class ctxt)
+  (cond ((null? ctxt)
+	 (list class))
+	((eq? class (car ctxt))
+	 ctxt)
+	((memq class (class-super* (car ctxt)))
+	 ctxt)
+	((memq (car ctxt) (class-super* class))
+	 (merge-single-class class (cdr ctxt)))
+	(else
+	 (cons (car ctxt) (merge-single-class class (cdr ctxt))))))
+
+;;; This determines if ctxt2 is contained in ctxt1.
+
+(define (context-implies? ctxt1 ctxt2)
+  (or (null? ctxt2)
+      (and (single-class-implies? ctxt1 (car ctxt2))
+	   (context-implies? ctxt1 (cdr ctxt2)))))
+
+(define (single-class-implies? ctxt class)
+  (and (not (null? ctxt))
+       (or (memq class ctxt)
+	   (super-class-implies? ctxt class))))
+
+(define (super-class-implies? ctxt class)
+  (and (not (null? ctxt))
+       (or (memq class (class-super* (car ctxt)))
+	   (super-class-implies? (cdr ctxt) class))))
+
+;;; This looks at the context of a full signature.
+
+(define (full-context-implies? ctxt1 ctxt2)
+  (or (null? ctxt1)
+      (and (context-implies? (car ctxt1) (car ctxt2))
+	   (full-context-implies? (cdr ctxt1) (cdr ctxt2)))))
+
+;;; This is used to avoid type circularity on unification.
+
+(define (occurs-in-type tyvar type) ; Cardelli algorithm
+  (let ((type (prune type)))
+    (if (ntyvar? type)
+	(eq? type tyvar)
+	(occurs-in-type/l tyvar (ntycon-args type)))))
+
+; Does a tyvar occur in a list of types?
+(define (occurs-in-type/l tyvar types)
+  (if (null? types)
+      '#f
+      (or (occurs-in-type tyvar (car types))
+	  (occurs-in-type/l tyvar (cdr types)))))
+
+(define-integrable (non-generic? tyvar)
+  (occurs-in-type/l tyvar (dynamic *non-generic-tyvars*)))
+
+(define (collect-tyvars ntype)
+  (collect-tyvars-1 ntype '()))
+
+(define (collect-tyvars-1 ntype vars)
+ (let ((ntype (prune ntype)))
+  (if (ntyvar? ntype)
+      (if (or (memq ntype vars) (non-generic? ntype))
+	  vars
+	  (cons ntype vars))
+      (collect-tyvars/l-1 (ntycon-args ntype) vars))))
+
+(define (collect-tyvars/l types)
+  (collect-tyvars/l-1 types '()))
+
+(define (collect-tyvars/l-1 types vars)
+  (if (null? types)
+      vars
+      (collect-tyvars/l-1 (cdr types) (collect-tyvars-1 (car types) vars))))
+
+;;; Random utilities
+
+(define (decl-var decl)
+  (var-ref-var (var-pat-var (valdef-lhs decl))))