annotation-parser.scm

(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))))))