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 /util/signature.scm |
Import to github.
Diffstat (limited to 'util/signature.scm')
-rw-r--r-- | util/signature.scm | 90 |
1 files changed, 90 insertions, 0 deletions
diff --git a/util/signature.scm b/util/signature.scm new file mode 100644 index 0000000..aea41eb --- /dev/null +++ b/util/signature.scm @@ -0,0 +1,90 @@ +;;; This file handles the scoping and error checking of signatures. + +;;; Possible errors: +;;; Wrong arity in a tycon +;;; Ambiguous context + +;;; Other errors may be present; these are detected at a higher level. +;;; The list of variables used in the signature is returned. + +(define (resolve-signature signature) + (with-slots signature (context type) signature + (let ((tyvars (resolve-type type))) + (resolve-signature-aux tyvars context) + tyvars))) + +(define (resolve-signature-aux tyvars context) + (dolist (ctxt context) + (with-slots context (class tyvar) ctxt + (when (not (memq tyvar tyvars)) + (signal-ambiguous-context tyvar)) + (resolve-class class)))) + +(define (resolve-type type) + (resolve-type-1 type '())) + +(define (resolve-type-1 type vars) + (cond ((tyvar? type) + (cons (tyvar-name type) vars)) + (else + (resolve-tycon type) + (with-slots tycon (name def args) type + (when (not (eq? def *undefined-def*)) + (if (eqv? (tycon-def-arity def) -1) + (setf (tycon-def-arity def) (length args)) + (when (not (eqv? (length args) (tycon-def-arity def))) + (signal-tycon-arity name type)))) + (resolve-type/list args vars))))) + +(define (resolve-type/list args vars) + (if (null? args) + vars + (resolve-type/list (cdr args) (resolve-type-1 (car args) vars)))) + +;;; This returns the names of the tyvars in a simple tycon + +(define (simple-tyvar-list simple) + (remember-context simple + (let* ((res (map (lambda (x) (tyvar-name x)) (tycon-args simple))) + (dups (find-duplicates res))) + (when (not (null? dups)) + (signal-non-linear-type-vars simple)) + res))) + +;;; This is used to build the class dictionary signature. + +(define (substitute-tyvar type tyvar new) + (cond ((tyvar? type) + (if (eq? (tyvar-name type) tyvar) + new + (**tyvar (tyvar-name type)))) + ((tycon? type) + (with-slots tycon (name def args) type + (make tycon (name name) (def def) + (args (map (lambda (x) (substitute-tyvar x tyvar new)) + args))))) + (else + (**signature (signature-context type) + (substitute-tyvar (signature-type type) tyvar new))))) + + + +;;; Error signalling routines + +(define (signal-ambiguous-context tyvar) + (phase-error 'ambiguous-context + "~a is referenced in a context, but is not bound as a type variable." + tyvar)) + +(define (signal-tycon-arity name type) + (phase-error 'tycon-arity + "The wrong number of arguments are supplied to the constructor ~a~%~ + in the type ~a." + name type)) + + +(define (signal-non-linear-type-vars simple) + (phase-error 'non-linear-type-vars + "There are duplicate type variables in ~s." + simple)) + |