git.fiddlerwoaroof.com
type/type-vars.scm
4e987026
 ;;; 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))))