1 files changed, 228 insertions, 0 deletions
diff --git a/tdecl/alg-syn.scm b/tdecl/alg-syn.scm
new file mode 100644
index 0000000..b128486
--- /dev/null
+++ b/tdecl/alg-syn.scm
@@ -0,0 +1,228 @@
+
+;;; Description: Convert algdata & synonym from ast to definition form.
+;;;              Lots of error checking.
+
+;;;  Algdata:
+;;;   Errors detected:
+;;;    Types & classes (deriving & context) resolved
+;;;    context tyvars must be parameters
+;;;    all parameter tyvars must be referenced
+;;;    only parameter tyvars must be referenced
+
+(define (algdata->def data-decl)
+  (remember-context data-decl
+   (with-slots data-decl (context simple constrs deriving annotations) data-decl
+      (let* ((def (tycon-def simple))
+	     (tyvars (simple-tyvar-list simple))
+	     (enum? '#t)
+	     (tag 0)
+	     (derived-classes '())
+	     (tyvars-referenced '())
+	     (all-con-vars '())
+	     (all-strict? (process-alg-strictness-annotation annotations))
+	     (constr-defs
+	      (map (lambda (constr)
+		     (with-slots constr (constructor types) constr
+		       (let ((constr-def (con-ref-con constructor))
+			     (c-arity (length types))
+			     (con-vars '())
+			     (all-types '())
+			     (strictness '()))
+			 (when (not (eqv? c-arity 0))
+			   (setf enum? '#f))
+			 (dolist (type types)
+			   (let* ((ty (tuple-2-1 type))
+				  (anns (tuple-2-2 type))
+				  (tyvars1 (resolve-type ty)))
+			     (push ty all-types)
+			     (push (get-constr-strictness anns all-strict?)
+				   strictness)
+			     (dolist (v tyvars1)
+			       (if (not (memq v tyvars))
+				   (signal-bad-algdata-tyvar v)))
+			     (setf con-vars (append tyvars1 tyvars-referenced))
+			     (setf tyvars-referenced
+				   (append tyvars1 tyvars-referenced))))
+			 (push (tuple constr con-vars) all-con-vars)
+			 (update-slots con constr-def
+		           (arity c-arity)
+			   (types (reverse all-types))
+			   (tag tag)
+			   (alg def)
+			   (infix? (con-ref-infix? constructor))
+			   (slot-strict? (reverse strictness)))
+			 (incf tag)
+			 constr-def)))
+		   constrs)))
+	(dolist (class deriving)
+	  (if (eq? (class-ref-name class) '|Printers|)
+	      (setf (class-ref-class class) *printer-class*)
+	      (resolve-class class))
+	  (when (not (eq? (class-ref-class class) *undefined-def*))
+	    (push (class-ref-class class) derived-classes)))
+	(when (not (null? constrs))
+	   (dolist (tyvar tyvars)
+	      (when (not (memq tyvar tyvars-referenced))
+		 (signal-unreferenced-tyvar-arg tyvar))))
+	(resolve-signature-aux tyvars context)
+	;; This computes a signature for the datatype as a whole.
+	(let ((gtype (ast->gtype context simple)))
+	  ;; This sets the signatures for the constructors
+	  (dolist (con constr-defs)
+	    (let* ((con-type (**arrow-type/l (append (con-types con)
+						     (list simple))))
+		   (con-context (restrict-context
+				 context (tuple-2-2 (assq con all-con-vars))))
+		   (con-signature (ast->gtype con-context con-type)))
+	      (setf (con-signature con) con-signature)))
+	  (update-slots algdata def
+	    (n-constr (length constrs))
+	    (constrs constr-defs)
+	    (context context)
+	    (tyvars tyvars)
+	    (signature gtype)
+	    (classes '())
+	    (enum? enum?)
+	    (tuple? (and (not (null? constrs)) (null? (cdr constrs))))
+	    (real-tuple? '#f)
+	    (deriving derived-classes)
+	    ))
+	(process-alg-annotations def)
+	def))))
+
+
+(define (process-alg-strictness-annotation anns)
+  (let ((res '#f))
+    (dolist (a anns)
+     (if (and (annotation-value? a)
+	      (eq? (annotation-value-name a) '|STRICT|)
+	      (null? (annotation-value-args a)))
+	 (setf res '#t)
+	 (signal-unknown-annotation a)))
+    res))
+
+(define (get-constr-strictness anns all-strict?)
+  (let ((res all-strict?))
+    (dolist (a anns)
+       (cond ((annotation-value? a)
+	      (if (and (eq? (annotation-value-name a) '|STRICT|)
+		       (null? (annotation-value-args a)))
+		  (setf res '#t)
+		  (signal-unknown-annotation a)))
+	     (else (signal-unknown-annotation a))))
+    res))
+
+(define (process-alg-annotations alg)
+  (dolist (a (module-annotations *module*))
+    (when (and (annotation-value? a)
+	       (or (eq? (annotation-value-name a) '|ImportLispType|)
+		   (eq? (annotation-value-name a) '|ExportLispType|))
+	       (assq (def-name alg) (car (annotation-value-args a))))
+      (if (eq? (annotation-value-name a) '|ImportLispType|)
+	  (setf (algdata-implemented-by-lisp? alg) '#t)
+	  (setf (algdata-export-to-lisp? alg) '#t))
+      (let ((constrs (tuple-2-2 (assq (def-name alg)
+				      (car (annotation-value-args a))))))
+	(dolist (c constrs)
+          (process-annotated-constr
+	   alg
+	   (lookup-alg-constr (tuple-2-1 c) (algdata-constrs alg))
+	   (tuple-2-2 c)))))))
+
+(define (lookup-alg-constr name constrs)
+  (if (null? constrs)
+      (fatal-error 'bad-constr-name "Constructor ~A not in algdata~%"
+		   name)
+      (if (eq? name (def-name (car constrs)))
+	  (car constrs)
+	  (lookup-alg-constr name (cdr constrs)))))
+
+(define (process-annotated-constr alg con lisp-fns)
+  ;; For nullary tuples, allow a single annotation to represent a constant
+  ;; and generate the test function by default.
+  (when (and (eqv? (con-arity con) 0)
+	     lisp-fns
+	     (null? (cdr lisp-fns)))
+	(push `(lambda (x) (eq? x ,(car lisp-fns))) lisp-fns))
+  ;; Insert an implicit test function for tuples (never used anyway!)
+  (when (and (algdata-tuple? alg)
+	     (eqv? (+ 1 (con-arity con)) (length lisp-fns)))
+	(push '(lambda (x) '#t) lisp-fns))
+  (when (or (not (null? (con-lisp-fns con)))
+	    (not (eqv? (length lisp-fns) (+ 2 (con-arity con)))))
+      (fatal-error 'bad-constr-annotation
+		   "Bad annotation for ~A in ~A~%" con alg))
+  (setf (con-lisp-fns con) lisp-fns))
+
+(define (signal-unknown-annotation a)
+  (recoverable-error 'bad-annotation "Bad or misplaced annotation: ~A%"
+      a))
+
+(define (restrict-context context vars)
+  (if (null? context)
+      '()
+      (let ((rest (restrict-context (cdr context) vars)))
+	(if (memq (context-tyvar (car context)) vars)
+	    (cons (car context) rest)
+	    rest))))
+
+(define (signal-bad-algdata-tyvar tyvar)
+  (phase-error 'bad-algdata-tyvar
+    "~a is referenced on the right-hand side of a data type declaration,~%~
+     but is not bound as a type variable."
+    tyvar))
+
+(define (signal-unreferenced-tyvar-arg tyvar)
+  (phase-error 'unreferenced-tyvar-arg
+    "~a is bound as a type variable in a data type declaration,~%~
+     but is not referenced on the right-hand side."
+    tyvar))
+
+;;; Synonyms
+
+;;; Errors detected:
+
+(define (synonym->def synonym-decl)
+ (remember-context synonym-decl
+  (with-slots synonym-decl (simple body) synonym-decl
+    (let* ((def (tycon-def simple))
+	   (tyvars (simple-tyvar-list simple))
+	   (tyvars-referenced (resolve-type body)))
+      (dolist (v tyvars)
+	(if (not (memq v tyvars-referenced))
+	  (signal-unreferenced-synonym-arg v)))
+      (dolist (v tyvars-referenced)
+	(if (not (memq v tyvars))
+	    (signal-bad-synonym-tyvar v)))
+      (update-slots synonym def
+	 (args tyvars)
+	 (body body))
+      (push (cons def (gather-synonyms body '())) *synonym-refs*)
+      def))))
+
+(define (signal-bad-synonym-tyvar tyvar)
+  (phase-error 'bad-synonym-tyvar
+    "~a is referenced on the right-hand side of a type synonym declaration,~%~
+     but is not bound as a type variable."
+    tyvar))
+
+(define (signal-unreferenced-synonym-arg tyvar)
+  (haskell-warning 'unreferenced-synonym-arg
+    "~a is bound as a type variable in a type synonym declaration,~%~
+     but is not referenced on the right-hand side."
+    tyvar))
+
+(define (gather-synonyms type acc)
+  (cond ((tyvar? type)
+	 acc)
+	((and (synonym? (tycon-def type))
+	      (eq? *unit* (def-unit (tycon-def type))))
+	 (gather-synonyms/list (tycon-args type)
+			       (cons (tycon-def type) acc)))
+	(else
+	 (gather-synonyms/list (tycon-args type) acc))))
+
+(define (gather-synonyms/list types acc)
+  (if (null? types)
+      acc
+      (gather-synonyms/list (cdr types) (gather-synonyms (car types) acc))))