From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 type/type-vars.scm | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 type/type-vars.scm

(limited to 'type/type-vars.scm')

diff --git a/type/type-vars.scm b/type/type-vars.scm
new file mode 100644
index 0000000..4091ce4
--- /dev/null
+++ b/type/type-vars.scm
@@ -0,0 +1,60 @@
+;;; This type checks a variable.  Possible cases:
+;;;  a) recursive variables
+;;;  b) method variables
+;;;  c) generalized variables 
+;;;  d) other variables
+
+(define-type-checker var-ref
+ (let* ((var (var-ref-var object))
+	(type (var-type var)))
+   (cond ((method-var? var)
+;;; The context of a method variable always has the carrier class
+;;; first.
+	  (mlet (((ntype new-tyvars) (instantiate-gtype/newvars type))
+		 (carrier-tyvar (car new-tyvars))
+		 (extra-context (cdr new-tyvars))
+		 (p (**method-placeholder
+		     var carrier-tyvar (dynamic *enclosing-decls*) object))
+		 (new-object (insert-dict-placeholders p extra-context object)))
+	    (remember-placeholder p)
+	    (return-type (**save-old-exp object new-object) ntype)))
+	 ((recursive-type? type)
+	  (let ((placeholder (**recursive-placeholder
+			      var (dynamic *enclosing-decls*))))
+	    (push placeholder (recursive-type-placeholders type))
+	    (return-type placeholder (recursive-type-type type))))
+	 ((gtype? type)
+	  (mlet (((ntype new-vars) (instantiate-gtype/newvars type))
+		 (object1 (insert-dict-placeholders object new-vars object)))
+            (return-type (if (eq? object1 object)
+			     object
+			     (**save-old-exp object object1))
+			 ntype)))
+	 (else
+	  (return-type object type)))))
+
+;;; This takes an expression and a context and returns an updated
+;;; expression containing placeholders for the context information
+;;; implied by the context.  Tyvars in the context are added to dict-vars.
+
+(define (insert-dict-placeholders object tyvars var)
+  (cond ((null? tyvars)
+	 object)
+	((null? (ntyvar-context (car tyvars)))
+	 (insert-dict-placeholders object (cdr tyvars) var))
+	(else
+	 (let ((tyvar (car tyvars)))
+	   (insert-dict-placeholders
+	    (insert-dict-placeholders/tyvar
+	     tyvar (ntyvar-context tyvar) object var)
+	    (cdr tyvars)
+	    var)))))
+
+(define (insert-dict-placeholders/tyvar tyvar classes object var)
+  (if (null? classes)
+      object
+      (let ((p (**dict-placeholder
+		 (car classes) tyvar (dynamic *enclosing-decls*) var)))
+	(remember-placeholder p)
+	(insert-dict-placeholders/tyvar tyvar (cdr classes) 
+					(**app object p) var))))
-- 
cgit v1.2.3