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.

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

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

diff --git a/parser/type-parser.scm b/parser/type-parser.scm
new file mode 100644
index 0000000..79c5dbf
--- /dev/null
+++ b/parser/type-parser.scm
@@ -0,0 +1,116 @@
+;;; File: type-parser        Author: John
+
+(define (parse-type)
+  (let ((type (parse-btype)))
+    (token-case
+      (->
+       (**tycon/def (core-symbol "Arrow") (list type (parse-type))))
+      (else type))))
+
+(define (parse-btype)
+  (token-case
+   (tycon (let* ((tycon (tycon->ast))
+		 (tycon-args (parse-atype-list)))
+	    (setf (tycon-args tycon) tycon-args)
+	    tycon))
+   (else
+    (parse-atype))))
+
+(define (parse-atype-list)
+  (token-case
+    (atype-start
+     (let ((atype (parse-atype)))
+       (cons atype (parse-atype-list))))
+    (else '())))
+
+(define (parse-atype)
+  (token-case
+    (tyvar (tyvar->ast))
+    (tycon (tycon->ast))
+    (\( (token-case
+	  (\) (**tycon/def (core-symbol "UnitType") '()))
+	  (else
+	    (let ((type (parse-type)))
+	      (token-case
+	       (\) type)
+	       (\, (let ((types  (cons type (parse-type-list))))
+		     (**tycon/def (tuple-tycon (length types)) types)))
+	       (else
+		(signal-missing-token "`)' or `,'" "type expression")))))))
+    (\[ (let ((type (parse-type)))
+	  (require-token \] (signal-missing-token "`]'" "type expression"))
+	  (**tycon/def (core-symbol "List") (list type))))
+    (else
+     (signal-invalid-syntax "an atype"))))
+
+(define (parse-type-list)
+  (let ((type (parse-type)))
+    (token-case (\, (cons type (parse-type-list)))
+		(\) (list type))
+		(else (signal-missing-token "`)' or `,'" "type expression")))))
+
+;;; This is used to determine whether a type is preceded by a context
+
+(define (has-optional-context?)
+  (let* ((saved-excursion (save-scanner-state))
+	 (res (token-case
+		(conid	
+		 (token-case
+		  (varid (eq-token? '=>))
+		  (else '#f)))
+		(\( (scan-context))
+		(else '#f))))
+    (restore-excursion saved-excursion)
+    res))
+
+(define (scan-context)
+  (token-case
+    (conid
+     (token-case
+       (varid
+	 (token-case
+	   (\) (eq-token? '=>))
+	   (\, (scan-context))
+	   (else '#f)))
+       (else '#f)))
+    (else '#f)))
+
+(define (parse-context)
+ (let ((contexts (token-case
+	           (tycon
+		    (list (parse-single-context)))
+		   (\( (parse-contexts))
+		   (else
+		    (signal-invalid-syntax "a context")))))
+   (require-token => (signal-missing-token "`=>'" "context"))
+   contexts))
+
+(define (parse-single-context)
+  (let ((class (class->ast)))
+    (token-case
+      (tyvar
+       (let ((tyvar (token->symbol)))
+	 (make context (class class) (tyvar tyvar))))
+      (else (signal-missing-token "<tyvar>" "class assertion")))))
+
+(define (parse-contexts)
+  (token-case
+    (tycon (let ((context (parse-single-context)))
+	      (token-case
+		(\, (cons context (parse-contexts)))
+		(\) (list context))
+		(else (signal-missing-token "`)' or `,'" "context")))))
+    (else (signal-missing-token "<tycon>" "class assertion"))))
+
+(define (parse-optional-context)
+  (if (has-optional-context?)
+      (parse-context)
+      '()))
+
+(define (parse-signature)
+  (let* ((contexts (parse-optional-context))
+	 (type (parse-type)))
+    (make signature (context contexts) (type type))))
+
+
+		 
\ No newline at end of file
-- 
cgit v1.2.3