;;; File: decl-parser           Author: John
 
 (define (parse-decl)
   (let ((decl-type (find-decl-type)))
     (cond ((eq? decl-type 'signdecl)
 	   (parse-signdecl))
 	  ((eq? decl-type 'pat-or-op)
 	   (parse-pat-or-op))
 	  ((eq? decl-type 'fundef)
 	   (parse-fundef))
 	  ((eq? decl-type 'plus-def)
 	   (parse-plus-def))
 	  ((eq? decl-type 'annotation)
 	   (make annotation-decls (annotations (parse-annotations)))))))
 
 ;;; This looks at the first tokens in a definition to determine it's type.
 ;;;   var (:: | ,)      - signdecl
 ;;;   var apat-start    - function definition
 ;;;   (var | _) +       - definition of infix +
 ;;;   anything alse     - pattern binding or infix definition
 
 (define (find-decl-type)
   (let* ((saved-excursion (save-scanner-state))
 	 (decl-type
 	  (token-case
 	   (var (scan-var)
 		(token-case
 		 ((\, \:\:) 'signdecl)
 		 (apat-start 'fundef)
 		 (+ 'plus-def)
 		 (else 'pat-or-op)))
 	   (_ (token-case
 	       (+ 'plus-def)
 	       (else 'pat-or-op)))
 	   (begin-annotation 'annotation)
 	   (else 'pat-or-op))))
     (restore-excursion saved-excursion)
     decl-type))
 
 ;;; These are the different flavors of decl parsers
 
 (define (parse-signdecl)
  (save-parser-context
   (trace-parser signdecl
     (let ((vars (parse-signdecl-vars)))
       (require-token \:\:
 		     (signal-missing-token "`::'" "signature declaration"))
       (let ((signature (parse-signature)))
 	(make signdecl (vars vars) (signature signature)))))))
  
 (define (parse-signdecl-vars)
   (token-case
    (var (let ((var (var->ast)))
 	  (token-case (\, (cons var (parse-signdecl-vars)))
 		      (else (list var)))))
    (else (signal-missing-token "<var>" "signature declaration"))))
 
 (define (parse-pat-or-op)
   (trace-parser patdef
     (let* ((line-number (capture-current-line))
 	   (pat (parse-pat)))
       (token-case
        (varop (parse-infix-def pat line-number))
        (else (add-rhs pat '() '#f line-number))))))
 
 (define (parse-infix-def pat1 line-number)
   (let* ((op (make var-pat (var (varop->ast))))
 	 (pat2 (parse-pat)))
 	(add-rhs op (list pat1 pat2) '#t line-number)))
 
 (define (parse-fundef)
  (trace-parser fundef
   (let* ((start-line (capture-current-line))
 	 (fn (parse-apat))  ; must be a single variable
 	 (args (parse-apat-list)))
     (add-rhs fn args '#f start-line))))
 
 (define (parse-plus-def)
   (trace-parser plus-def
     (let* ((start-line (capture-current-line))
 	   (var (parse-apat)))
       (parse-infix-def var start-line))))
 
 (define (add-rhs pat args infix? start-line)
   (let* ((rhs (parse-rhs))
 	 (decls (parse-where-decls))
 	 (single (make single-fun-def
 		       (args args)
 		       (rhs-list rhs)
 		       (where-decls decls)
 		       (infix? infix?)))
 	 (valdef (make valdef (lhs pat) (definitions (list single)))))
     (setf (ast-node-line-number single) start-line)
     (setf (ast-node-line-number valdef) start-line)
     valdef))
 
 (define (parse-rhs)
   (token-case
    (= (let ((rhs (parse-exp)))
 	(list (make guarded-rhs (guard (make omitted-guard)) (rhs rhs)))))
    (\| (parse-guarded-rhs))
    (else
     (signal-missing-token "`=' or `|'" "rhs of valdef"))))
 
 (define (parse-guarded-rhs) ; assume just past |
  (trace-parser guard
   (let ((guard (parse-exp-i)))  ; 1.2 change
     (require-token = (signal-missing-token "`='" "guarded rhs"))
     (let* ((exp (parse-exp))
 	   (res (make guarded-rhs (guard guard) (rhs exp))))
       (token-case
        (\| (cons res (parse-guarded-rhs)))
        (else (list res)))))))
 
 (define (parse-where-decls)
   (token-case
    (|where|
     (parse-decl-list))
    (else '())))
 
 (define (parse-decl-list)
   (start-layout (function parse-decl-list-1)))
 
 (define (parse-decl-list-1 in-layout?)
   (token-case
    ((apat-start begin-annotation)
     (let ((decl (parse-decl)))
       (token-case
        (\; (decl-cons decl (parse-decl-list-1 in-layout?)))
        (else (close-layout in-layout?)
 	     (list decl)))))
    (else
     (close-layout in-layout?)
     '())))
 
 ;;; This adds a new decl to a decl list.  Successive decls for the same fn
 ;;; are combined.
 
 (define (decl-cons decl decl-list)
   (cond ((null? decl-list)
 	 (list decl))
 	(else (nconc (combine-decls decl (car decl-list)) (cdr decl-list)))))
 
 (define (decl-push decl decl-stack)
   (cond ((null? decl-stack)
 	 (list decl))
 	(else (nconc (nreverse (combine-decls (car decl-stack) decl))
 		     (cdr decl-stack)))))
 
 (define (combine-decls decl1 decl2)
   (if (and (is-type? 'valdef decl1)
 	   (is-type? 'valdef decl2)
 	   (same-decl-var? (valdef-lhs decl1) (valdef-lhs decl2)))
       (if (eqv? (length (single-fun-def-args (car (valdef-definitions decl1))))
 		(length (single-fun-def-args (car (valdef-definitions decl2)))))
 	  (begin
 	    (setf (valdef-definitions decl1)
 		  (nconc (valdef-definitions decl1)
 			 (valdef-definitions decl2)))
 	    (list decl1))
 	  (signal-multiple-definitions-arity-mismatch (valdef-lhs decl1)))
       (list decl1 decl2)))
 
 (define (same-decl-var? pat1 pat2)
   (and (is-type? 'var-pat pat1)
        (is-type? 'var-pat pat2)
        (eq? (var-ref-name (var-pat-var pat1))
 	    (var-ref-name (var-pat-var pat2)))))
 
 (define (signal-multiple-definitions-arity-mismatch pat)
   (parser-error 'multiple-definitions-arity-mismatch
 		"Definition of ~a does not match arity of previous definition."
 		pat))