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))
+