1 files changed, 184 insertions, 0 deletions
diff --git a/parser/annotation-parser.scm b/parser/annotation-parser.scm
new file mode 100644
index 0000000..4ae33cf
--- /dev/null
+++ b/parser/annotation-parser.scm
@@ -0,0 +1,184 @@
+
+(define *annotation-escape* '())
+
+(define (parse-annotations)
+ (let ((save-layout (dynamic *layout-stack*)))
+  (setf (dynamic *layout-stack*) '())
+  (advance-token)
+  (let/cc annotation-escape
+   (setf *annotation-escape* (lambda () 
+			       (setf (dynamic *layout-stack*) save-layout)
+			       (advance-to-annotation-end)
+			       (funcall annotation-escape '())))
+   (let ((res (start-layout (function parse-annotation-list-1))))
+    (setf (dynamic *layout-stack*) save-layout)
+    (token-case
+     (end-annotation res)
+     (else (signal-annotation-error)))))))
+
+(define (parse-annotation-list-1 in-layout?)
+  (let ((kind (get-annotation-kind)))
+    (cond ((eq? kind 'decl)
+	   (let ((d (parse-annotation-decl)))
+	     (token-case
+	      (\; (cons d (parse-annotation-list-1 in-layout?)))
+	      (else (close-layout in-layout?)
+		    (list d)))))
+	  ((eq? kind 'value)
+	   (let ((d (parse-annotation-value)))
+	     (token-case
+	      (\; (cons d (parse-annotation-list-1 in-layout?)))
+	      (else (close-layout in-layout?)
+		    (list d)))))
+	  (else
+	   (close-layout in-layout?)
+	   '()))))
+
+(define (get-annotation-kind)
+  (token-case
+   ((no-advance end-annotation) 'end)
+   ((no-advance \() 'decl)
+   ((var con)
+    (let ((next (peek-1-type)))
+      (cond ((eq? next '|,|)
+	     'decl)
+	    ((eq? next '|::|)
+	     'decl)
+	    (else
+	     'value))))
+   (else 'error)))
+
+(define (parse-annotation-decl)
+  (let* ((names (parse-aname-list))
+	 (decls (parse-aval-list)))
+    (make annotation-decl (names names) (annotations decls))))
+
+(define (parse-aname-list)
+ (let ((name 'foo))
+  (token-case
+   (var
+    (setf name (var->symbol)))
+   (con
+    (setf name (con->symbol)))
+   (else (signal-annotation-error)))
+  (token-case (\, (cons name (parse-aname-list)))
+	      (|::| (list name))
+	      (else (signal-annotation-error)))))
+
+
+(define (parse-aval-list)
+  (let ((ann (parse-annotation-value)))
+    (token-case (\, (cons ann (parse-aval-list)))
+		(else (list ann)))))
+
+(define (parse-annotation-value)
+  (token-case
+   (name (let* ((name (token->symbol))
+		(args (parse-annotation-args name)))
+	   (make annotation-value (name name) (args args))))))
+
+(define (parse-annotation-args name)
+  (token-case
+   (\( (parse-annotation-args-1 name 0))
+   (else '())))
+
+;;; This routine can invoke special parsers for the arguments
+
+(define (parse-annotation-args-1 name i)
+  (let* ((argtype (get-annotation-arg-description name i))
+	 (arg (parse-annotation-arg argtype)))
+    (token-case
+     (\) (list arg))
+     (\, (cons arg (parse-annotation-args-1 name (1+ i))))
+     (else (signal-annotation-error)))))
+
+(define (parse-annotation-arg type)
+  (cond ((eq? type 'string)
+	 (token-case
+	  ((string no-advance)
+	   (let ((res (car *token-args*)))
+	     (advance-token)
+	     res))
+	  (else (signal-annotation-error))))
+	;; The following is for a datatype import/export.  It is
+	;; Type(Con1(strs),Con2(strs),...)
+	((eq? type 'integer)
+	 (token-case
+	  ((integer no-advance) (token->integer))
+	  (else (signal-annotation-error))))
+	((eq? type 'constr-list)
+	 (parse-annotation-constr-list))
+	(else
+	 (signal-annotation-error))))
+	   
+(define (signal-annotation-error)
+  (parser-error/recoverable 'annotation-error "Error in annotation syntax")
+  (funcall *annotation-escape*))
+
+(define (parse-annotation-constr-list)
+  (token-case
+   (tycon (let ((type-name (token->symbol)))
+	    (token-case (\( (let* ((args (parse-acl1))
+				   (res (tuple type-name args)))
+			      (token-case  ; leave the ) to end the args
+			       ((no-advance \)) (list res))
+			       (\, (cons res (parse-annotation-constr-list)))
+			       (else (signal-annotation-error)))))
+			(else (signal-annotation-error)))))
+   (else (signal-annotation-error))))
+
+(define (parse-acl1)
+  (token-case
+   (con (let ((con-name (con->symbol)))
+	  (token-case (\( (let ((str-args (parse-string-list)))
+			    (token-case
+			     (\, (cons (tuple con-name str-args)
+				       (parse-acl1)))
+			     (\) (list (tuple con-name str-args)))
+			     (else (signal-annotation-error)))))
+		      (else (signal-annotation-error)))))
+   (else (signal-annotation-error))))
+
+(define (parse-string-list)
+  (token-case
+   ((string no-advance)
+    (let ((res (read-lisp-object (car *token-args*))))
+      (advance-token)
+      (token-case
+       (\) (list res))
+       (\, (cons res (parse-string-list)))
+       (else (signal-annotation-error)))))
+   (else (signal-annotation-error))))
+
+(define (advance-to-annotation-end)
+  (token-case
+   (eof '())
+   (end-annotation
+     (advance-token))
+   (else
+    (advance-token)
+    (advance-to-annotation-end))))
+  
+(define *known-annotations* '(
+  (|LispName| string)
+  (|Prelude|)
+  (|Strictness| string)
+  (|Strict|)
+  (|NoConversion|)
+  (|Inline|)
+  (|STRICT|)
+  (|ImportLispType| constr-list)
+  (|ExportLispType| constr-list)
+  (|Complexity| integer)
+  ))
+
+(define (get-annotation-arg-description annotation i)
+  (let ((s (assq annotation *known-annotations*)))
+    (cond ((eq? s '#f)
+	   (parser-error/recoverable 'unknown-annotation
+             "Annotation ~A is not defined in this system - ignored."
+	     annotation)
+	   'unknown)
+	  ((>= i (length s))
+	   'error)
+	  (else (list-ref s (1+ i))))))