diff options
author | Yale AI Dept <ai@nebula.cs.yale.edu> | 1993-07-14 13:08:00 -0500 |
---|---|---|
committer | Duncan McGreggor <duncan.mcgreggor@rackspace.com> | 1993-07-14 13:08:00 -0500 |
commit | 4e987026148fe65c323afbc93cd560c07bf06b3f (patch) | |
tree | 26ae54177389edcbe453d25a00c38c2774e8b7d4 /type/default.scm |
Import to github.
Diffstat (limited to 'type/default.scm')
-rw-r--r-- | type/default.scm | 47 |
1 files changed, 47 insertions, 0 deletions
diff --git a/type/default.scm b/type/default.scm new file mode 100644 index 0000000..529f4f8 --- /dev/null +++ b/type/default.scm @@ -0,0 +1,47 @@ +;;; This handles the default rule. + +(define (maybe-default-ambiguous-tyvar type def module) + (let ((classes (ntyvar-context type))) + (and (not (null? classes)) ; this happens only during cleanup after an error + (let ((non-standard? '#f) + (numeric? '#f)) + (dolist (class classes) + (cond ((eq? (class-kind class) 'numeric) + (setf numeric? '#t)) + ((not (eq? (class-kind class) 'standard)) + (setf non-standard? '#t)))) + (cond ((or non-standard? (not numeric?)) + (remember-context def + (phase-error 'Non-defaultable-ambiguous-context +"An ambiguous context, ~A, cannot be defaulted.~%Ambiguity in call to ~A~%" + classes def)) + '#f) + (else + (find-default-type type classes classes + (tuple-2-2 (assq module *default-decls*))))))))) + +(define (find-default-type tyvar classes all-classes defaults) + (cond ((null? defaults) + (phase-error 'no-default-applies + "Ambiguous context: ~A~%No default applies.~%" + all-classes) + '#f) + ((null? classes) + (instantiate-tyvar tyvar (car defaults)) + '#t) + ((type-in-class? (car defaults) (car classes)) + (find-default-type tyvar (cdr classes) all-classes defaults)) + (else + (find-default-type tyvar all-classes all-classes (cdr defaults))))) + +(define (type-in-class? ntype class) + (let* ((ntype (expand-ntype-synonym ntype)) + (alg (ntycon-tycon ntype)) + (inst (lookup-instance alg class))) + (if (eq? inst '#f) + '#f + (let ((res '#t)) + (do-contexts (c (instance-context inst)) (ty (ntycon-args ntype)) + (when (not (type-in-class? ty c)) + (setf res '#f))) + res)))) |