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