home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / util / signature.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  2.6 KB  |  89 lines  |  [TEXT/CCL2]
  1. ;;; This file handles the scoping and error checking of signatures.
  2.  
  3. ;;; Possible errors:
  4. ;;;  Wrong arity in a tycon
  5. ;;;  Ambiguous context
  6.  
  7. ;;; Other errors may be present; these are detected at a higher level.
  8. ;;; The list of variables used in the signature is returned.
  9.  
  10. (define (resolve-signature signature)
  11.   (with-slots signature (context type) signature
  12.     (let ((tyvars (resolve-type type)))
  13.       (resolve-signature-aux tyvars context)
  14.       tyvars)))
  15.  
  16. (define (resolve-signature-aux tyvars context)
  17.   (dolist (ctxt context)
  18.     (with-slots context (class tyvar) ctxt
  19.       (when (not (memq tyvar tyvars))
  20.     (signal-ambiguous-context tyvar))
  21.       (resolve-class class))))
  22.  
  23. (define (resolve-type type)
  24.   (resolve-type-1 type '()))
  25.  
  26. (define (resolve-type-1 type vars)
  27.   (cond ((tyvar? type)
  28.      (cons (tyvar-name type) vars))
  29.     (else
  30.      (resolve-tycon type)
  31.      (with-slots tycon (def args) type
  32.        (when (not (eq? def *undefined-def*))
  33.          (if (eqv? (tycon-def-arity def) -1)
  34.          (setf (tycon-def-arity def) (length args))
  35.          (when (not (eqv? (length args) (tycon-def-arity def)))
  36.              (signal-tycon-arity def (tycon-def-arity def)))))
  37.        (resolve-type/list args vars)))))
  38.  
  39. (define (resolve-type/list args vars)
  40.   (if (null? args)
  41.       vars
  42.       (resolve-type/list (cdr args) (resolve-type-1 (car args) vars))))
  43.  
  44. ;;; This returns the names of the tyvars in a simple tycon
  45.  
  46. (define (simple-tyvar-list simple)
  47.   (remember-context simple
  48.     (let* ((res (map (lambda (x) (tyvar-name x)) (tycon-args simple)))
  49.        (dups (find-duplicates res)))
  50.       (when (not (null? dups))
  51.     (signal-non-linear-type-vars simple))
  52.       res)))
  53.  
  54. ;;; This is used to build the class dictionary signature.
  55.  
  56. (define (substitute-tyvar type tyvar new)
  57.   (cond ((tyvar? type)
  58.      (if (eq? (tyvar-name type) tyvar)
  59.          new
  60.          (**tyvar (tyvar-name type))))
  61.     ((tycon? type)
  62.      (with-slots tycon (name def args) type
  63.        (make tycon (name name) (def def)
  64.                (args (map (lambda (x) (substitute-tyvar x tyvar new))
  65.                   args)))))
  66.     (else
  67.      (**signature (signature-context type)
  68.               (substitute-tyvar (signature-type type) tyvar new)))))
  69.  
  70.  
  71.  
  72. ;;; Error signalling routines
  73.  
  74. (define (signal-ambiguous-context tyvar)
  75.   (phase-error 'ambiguous-context
  76.     "~a is referenced in a context, but is not bound as a type variable."
  77.     tyvar))
  78.  
  79. (define (signal-tycon-arity type arity)
  80.   (phase-error/objs 'tycon-arity (list type)
  81.     "The type ~A expects ~A arguments."
  82.     (get-object-name type) arity))
  83.  
  84. (define (signal-non-linear-type-vars simple)
  85.   (phase-error 'non-linear-type-vars
  86.     "There are duplicate type variables in ~s."
  87.     simple))
  88.  
  89.