1 files changed, 98 insertions, 0 deletions
diff --git a/parser/interface-parser.scm b/parser/interface-parser.scm
new file mode 100644
index 0000000..184fdb0
--- /dev/null
+++ b/parser/interface-parser.scm
@@ -0,0 +1,98 @@
+;;; This is the parser for interface files.
+
+(define (parse-tokens/interface tokens)
+  (init-token-stream tokens)
+  (let ((interface (token-case
+		    (|interface| (parse-interface))
+		    (|module| (interface-required-error))
+		    (else (crud-in-interface-error)))))
+    (cons interface (parse-interface-list))))
+
+(define (interface-required-error)
+  (parser-error 'interface-required "Expecting `interface' keyword"))
+
+(define (crud-in-interface-error)
+  (parser-error 'unexpected-interface-crud "Junk after interface"))
+
+(define (parse-interface-list)
+  (token-case
+   (|interface|
+     (let ((interface (parse-interface)))
+       (cons interface (parse-interface-list))))
+   (|module| (interface-required-error))
+   (eof '())
+   (else (crud-in-interface-error))))
+
+(define (parse-interface)
+  (token-case
+   (modid
+    (let ((module-name (token->symbol)))
+      (require-token |where|
+       (signal-missing-token "`where'" "interface definition"))
+      (let ((mod-ast (make module (name module-name)
+			          (type 'interface)
+				  (exports '()))))
+	(start-layout (lambda (in-layout?)
+		       (parse-interface-decls mod-ast in-layout? 'import))))))))
+
+(define (parse-interface-decls mod-ast in-layout? state)
+  (token-case
+    (|import| (let ((import (parse-import)))
+		(when (not (eq? (import-decl-mode import) 'by-name))
+		   (phase-error 'illegal-import
+    "Imports in interfaces must specify specific entities"))
+		(if (eq? state 'import)
+		    (push-decl-list import (module-imports mod-ast))
+		    (signal-misplaced-import)))
+	      (terminate-interface-topdecl mod-ast in-layout? state))
+    (|infix| (terminate-interface-topdecl mod-ast in-layout?
+			       (parse-fixity 'n mod-ast state)))
+    (|infixl| (terminate-interface-topdecl mod-ast in-layout?
+			       (parse-fixity 'l mod-ast state)))
+    (|infixr| (terminate-interface-topdecl mod-ast in-layout?
+			       (parse-fixity 'r mod-ast state)))
+    (|data| (let ((data-decl (parse-type-decl '#t)))
+	      (push-decl-list data-decl (module-algdatas mod-ast)))
+	    (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
+    (|type| (let ((synonym-decl (parse-synonym-decl)))
+	     (push-decl-list synonym-decl (module-synonyms mod-ast)))
+	    (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
+    (|class| (let ((class-decl (parse-class-decl)))
+	       (check-class-default-decls class-decl)
+	       (push-decl-list class-decl (module-classes mod-ast)))
+	     (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
+    (|instance| (let ((instance-decl (parse-instance-decl '#t)))
+		  (push-decl-list instance-decl (module-instances mod-ast)))
+		(terminate-interface-topdecl mod-ast in-layout? 'topdecl))
+    (var (let ((decl (parse-signdecl)))
+	   (setf (module-decls mod-ast)
+		 (decl-push decl (module-decls mod-ast))))
+	 (terminate-interface-topdecl mod-ast in-layout? 'topdecl))
+    ((begin-annotation no-advance)
+     (let ((annotations (parse-annotations)))
+       (setf (module-annotations mod-ast)
+	     (append (module-annotations mod-ast) annotations)))
+     (terminate-interface-topdecl mod-ast in-layout? state))
+    (else
+     (maybe-end-interface mod-ast in-layout?))))
+
+(define (maybe-end-interface mod-ast in-layout?)
+  (cond ((or (eq-token? '|interface|) (eq-token? 'eof) (eq-token? '\})
+	     (eq-token? '$\}))
+	 (close-layout in-layout?)
+	 (wrapup-module mod-ast)
+	 mod-ast)
+	(else
+	 (signal-invalid-syntax "a topdecl"))))
+
+(define (terminate-interface-topdecl mod-ast in-layout? state)
+  (token-case
+   (\; (parse-interface-decls mod-ast in-layout? state))
+   (else (maybe-end-interface mod-ast in-layout?))))
+
+(define (check-class-default-decls class-decl)
+  (dolist (d (class-decl-decls class-decl))
+    (when (valdef? d)
+      (remember-context d
+       (recoverable-error 'no-defaults-in-interface
+         "Class defaults should not be put in interface files")))))