home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / alg-syn.scm next >
Encoding:
Text File  |  1994-09-27  |  7.8 KB  |  235 lines  |  [TEXT/CCL2]
  1.  
  2. ;;; Description: Convert algdata & synonym from ast to definition form.
  3. ;;;              Lots of error checking.
  4.  
  5. ;;;  Algdata:
  6. ;;;   Errors detected:
  7. ;;;    Types & classes (deriving & context) resolved
  8. ;;;    context tyvars must be parameters
  9. ;;;    all parameter tyvars must be referenced
  10. ;;;    only parameter tyvars must be referenced
  11.  
  12. (define (algdata->def data-decl)
  13.   (remember-context data-decl
  14.    (with-slots data-decl (context simple constrs deriving annotations) data-decl
  15.       (let* ((def (tycon-def simple))
  16.          (tyvars (simple-tyvar-list simple))
  17.          (enum? '#t)
  18.          (tag 0)
  19.          (derived-classes '())
  20.          (tyvars-referenced '())
  21.          (all-con-vars '())
  22.          (all-strict? (process-alg-strictness-annotation annotations))
  23.          (constr-defs
  24.           (map (lambda (constr)
  25.              (with-slots constr (constructor types) constr
  26.                (let ((constr-def (con-ref-con constructor))
  27.                  (c-arity (length types))
  28.                  (con-vars '())
  29.                  (all-types '())
  30.                  (strictness '()))
  31.              (when (not (eqv? c-arity 0))
  32.                (setf enum? '#f))
  33.              (dolist (type types)
  34.                (let* ((ty (tuple-2-1 type))
  35.                   (anns (tuple-2-2 type))
  36.                   (tyvars1 (resolve-type ty)))
  37.                  (push ty all-types)
  38.                  (push (get-constr-strictness anns all-strict?)
  39.                    strictness)
  40.                  (dolist (v tyvars1)
  41.                    (if (not (memq v tyvars))
  42.                    (signal-bad-algdata-tyvar v)))
  43.                  (setf con-vars (append tyvars1 tyvars-referenced))
  44.                  (setf tyvars-referenced
  45.                    (append tyvars1 tyvars-referenced))))
  46.              (push (tuple constr con-vars) all-con-vars)
  47.              (update-slots con constr-def
  48.                    (arity c-arity)
  49.                (types (reverse all-types))
  50.                (tag tag)
  51.                (alg def)
  52.                (infix? (con-ref-infix? constructor))
  53.                (slot-strict? (reverse strictness)))
  54.              (incf tag)
  55.              constr-def)))
  56.            constrs)))
  57.     (dolist (class deriving)
  58.       (let* ((name (add-di-prefix (class-ref-name class)))
  59.          (di (resolve-toplevel-name name)))
  60.         (if (eq? di '#f)
  61.         (recoverable-error 'unknown-deriving
  62.             "Derivable instance ~A not known" (class-ref-name class))
  63.         (push di derived-classes))))
  64.     (when (not (null? constrs))
  65.        (dolist (tyvar tyvars)
  66.           (when (not (memq tyvar tyvars-referenced))
  67.          (signal-unreferenced-tyvar-arg tyvar))))
  68.     (resolve-signature-aux tyvars context)
  69.     ;; This computes a signature for the datatype as a whole.
  70.     (let ((gtype (ast->gtype context simple)))
  71.       ;; This sets the signatures for the constructors
  72.       (dolist (con constr-defs)
  73.         (let* ((con-type (**arrow-type/l (append (con-types con)
  74.                              (list simple))))
  75.            (con-context (restrict-context
  76.                  context (tuple-2-2 (assq con all-con-vars))))
  77.            (con-signature (ast->gtype con-context con-type)))
  78.           (setf (con-signature con) con-signature)))
  79.       (update-slots algdata def
  80.         (n-constr (length constrs))
  81.         (constrs constr-defs)
  82.         (context context)
  83.         (tyvars tyvars)
  84.         (signature gtype)
  85.         (classes '())
  86.         (enum? enum?)
  87.         (tuple? (and (not (null? constrs)) (null? (cdr constrs))))
  88.         (real-tuple? '#f)
  89.         (deriving derived-classes)
  90.         ))
  91.     (setf (algdata-runtime-var def)
  92.           (make-runtime-var def "-type" (core-symbol "DataType")))
  93.     (process-alg-annotations def)
  94.     def))))
  95.  
  96.  
  97. (define (process-alg-strictness-annotation anns)
  98.   (let ((res '#f))
  99.     (dolist (a anns)
  100.      (if (and (annotation-value? a)
  101.           (eq? (annotation-value-name a) '|STRICT|)
  102.           (null? (annotation-value-args a)))
  103.      (setf res '#t)
  104.      (signal-unknown-annotation a)))
  105.     res))
  106.  
  107. (define (get-constr-strictness anns all-strict?)
  108.   (let ((res all-strict?))
  109.     (dolist (a anns)
  110.        (cond ((annotation-value? a)
  111.           (if (and (eq? (annotation-value-name a) '|STRICT|)
  112.                (null? (annotation-value-args a)))
  113.           (setf res '#t)
  114.           (signal-unknown-annotation a)))
  115.          (else (signal-unknown-annotation a))))
  116.     res))
  117.  
  118. (define (process-alg-annotations alg)
  119.   (dolist (a (module-annotations *module*))
  120.     (when (and (annotation-value? a)
  121.            (or (eq? (annotation-value-name a) '|ImportLispType|)
  122.            (eq? (annotation-value-name a) '|ExportLispType|))
  123.            (assq (def-name alg) (car (annotation-value-args a))))
  124.       (if (eq? (annotation-value-name a) '|ImportLispType|)
  125.       (setf (algdata-implemented-by-lisp? alg) '#t)
  126.       (setf (algdata-export-to-lisp? alg) '#t))
  127.       (let ((constrs (tuple-2-2 (assq (def-name alg)
  128.                       (car (annotation-value-args a))))))
  129.     (dolist (c constrs)
  130.           (process-annotated-constr
  131.        alg
  132.        (lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg))
  133.        (tuple-2-2 c)))))))
  134.  
  135. (define (lookup-alg-constr name constrs)
  136.   (if (null? constrs)
  137.       (fatal-error 'bad-constr-name "Constructor ~A not in algdata~%"
  138.            name)
  139.       (if (eq? name (def-name (car constrs)))
  140.       (car constrs)
  141.       (lookup-alg-constr name (cdr constrs)))))
  142.  
  143. (define (process-annotated-constr alg con lisp-fns)
  144.   ;; For nullary tuples, allow a single annotation to represent a constant
  145.   ;; and generate the test function by default.
  146.   (when (and (eqv? (con-arity con) 0)
  147.          lisp-fns
  148.          (null? (cdr lisp-fns)))
  149.     (push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns))
  150.   ;; Insert an implicit test function for tuples (never used anyway!)
  151.   (when (and (algdata-tuple? alg)
  152.          (eqv? (+ 1 (con-arity con)) (length lisp-fns)))
  153.     (push '(lambda (x) '#t) lisp-fns))
  154.   (when (or (not (null? (con-lisp-fns con)))
  155.         (not (eqv? (length lisp-fns) (+ 2 (con-arity con)))))
  156.       (fatal-error 'bad-constr-annotation
  157.            "Bad annotation for ~A in ~A~%" con alg))
  158.   (setf (con-lisp-fns con) lisp-fns))
  159.  
  160. ;;; This should be obsolete - the parser now checks annotations thoroughly.
  161.  
  162. (define (signal-unknown-annotation a)
  163.   (recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%"
  164.       a))
  165.  
  166. (define (restrict-context context vars)
  167.   (if (null? context)
  168.       '()
  169.       (let ((rest (restrict-context (cdr context) vars)))
  170.     (if (memq (context-tyvar (car context)) vars)
  171.         (cons (car context) rest)
  172.         rest))))
  173.  
  174. (define (signal-bad-algdata-tyvar tyvar)
  175.   (phase-error 'bad-algdata-tyvar
  176. "Only type variables defined by the left hand side of a data declaration~%~
  177.  may be used on the right side.  Type variable ~a is can not be used on~%~
  178.  the right side of this data declaration."
  179.     tyvar))
  180.  
  181. (define (signal-unreferenced-tyvar-arg tyvar)
  182.   (phase-error 'unreferenced-tyvar-arg
  183.     "Type variable ~a is defined by the left hand side of a data declaration~%~
  184.      but is not referenced on the right hand side."
  185.     tyvar))
  186.  
  187. ;;; Synonyms
  188.  
  189. ;;; Errors detected:
  190.  
  191. (define (synonym->def synonym-decl)
  192.  (remember-context synonym-decl
  193.   (with-slots synonym-decl (simple body) synonym-decl
  194.     (let* ((def (tycon-def simple))
  195.        (tyvars (simple-tyvar-list simple))
  196.        (tyvars-referenced (resolve-type body)))
  197.       (dolist (v tyvars)
  198.     (if (not (memq v tyvars-referenced))
  199.       (signal-unreferenced-synonym-arg v)))
  200.       (dolist (v tyvars-referenced)
  201.     (if (not (memq v tyvars))
  202.         (signal-bad-synonym-tyvar v)))
  203.       (update-slots synonym def
  204.      (args tyvars)
  205.      (body body))
  206.       (push (cons def (gather-synonyms body '())) *synonym-refs*)
  207.       def))))
  208.  
  209. (define (signal-bad-synonym-tyvar tyvar)
  210.   (phase-error 'bad-synonym-tyvar
  211.     "The variable ~a is referenced on the right hand side of a type synonym~%~
  212.      declaration but is not bound by the left hand side."
  213.     tyvar))
  214.  
  215. (define (signal-unreferenced-synonym-arg tyvar)
  216.   (haskell-warning 'unreferenced-synonym-arg
  217. "The variable ~a is bound by the left hand side of a type synonym declaration~%~
  218.  but is not referenced on the right hand side."
  219.     tyvar))
  220.  
  221. (define (gather-synonyms type acc)
  222.   (cond ((tyvar? type)
  223.      acc)
  224.     ((and (synonym? (tycon-def type))
  225.           (eq? *unit* (def-unit (tycon-def type))))
  226.      (gather-synonyms/list (tycon-args type)
  227.                    (cons (tycon-def type) acc)))
  228.     (else
  229.      (gather-synonyms/list (tycon-args type) acc))))
  230.  
  231. (define (gather-synonyms/list types acc)
  232.   (if (null? types)
  233.       acc
  234.       (gather-synonyms/list (cdr types) (gather-synonyms (car types) acc))))
  235.