From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 type/type-main.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 56 insertions(+)
 create mode 100644 type/type-main.scm

(limited to 'type/type-main.scm')

diff --git a/type/type-main.scm b/type/type-main.scm
new file mode 100644
index 0000000..c5ffe14
--- /dev/null
+++ b/type/type-main.scm
@@ -0,0 +1,56 @@
+
+;;; This is the main entry point to the type checker.
+
+
+(define (do-haskell-type-check object modules)
+  (type-init modules)
+  (when (is-type? 'let object) ; may be void
+    (dynamic-let ((*non-generic-tyvars* '())
+		  (*placeholders* '())
+		  (*enclosing-decls* '()))
+      (type-check/decls let decls
+	 (setf (dynamic *non-generic-tyvars*) '())
+         (process-placeholders (dynamic *placeholders*) '() '()))))
+  'done)
+
+;;; This is the main recursive entry to the type checker.
+
+(define (dispatch-type-check exp)
+ (remember-context exp
+  (call-walker type exp)))
+
+(define (do-type-check/list exps)
+  (if (null? exps)
+      (values '() '())
+      (mlet (((obj1 type1) (dispatch-type-check (car exps)))
+	     ((objs types) (do-type-check/list (cdr exps))))
+	(values (cons obj1 objs) (cons type1 types)))))
+
+(define (type-init modules)
+  ;; Built in types
+  (setf *char-type* (**ntycon (core-symbol "Char") '()))
+  (setf *string-type* (**ntycon (core-symbol "List")
+				(list *char-type*)))
+  (setf *bool-type* (**ntycon (core-symbol "Bool") '()))
+  (setf *int-type* (**ntycon (core-symbol "Int") '()))
+  (setf *integer-type* (**ntycon (core-symbol "Integer") '()))
+  (setf *rational-type* (**ntycon (core-symbol "Ratio")
+				  (list *integer-type*)))
+  (setf *default-decls* '())
+  (dolist (m modules)
+    (let ((default-types '()))
+      (dolist (d (default-decl-types (module-default m)))
+        (let* ((ty (ast->gtype '() d))
+	       (ntype (gtype-type ty)))
+	  (cond ((not (null? (gtype-context ty)))
+		 (recoverable-error 'not-monotype
+		   "~A is not a monotype in default decl" ty))
+		((not (type-in-class? ntype (core-symbol "Num")))
+		 (recoverable-error 'not-Num-class
+		   "~A is not in class Num" ty))
+		(else
+		 (push ntype default-types)))))
+      (push (tuple (module-name m) (reverse default-types)) *default-decls*))))
+
+(define (remember-placeholder placeholder)
+  (push placeholder (dynamic *placeholders*)))
-- 
cgit v1.2.3