;;; This contains parser error handlers.  They, in turn, call the
;;; system error handlers.

(define (lexer-error id . msgs)
  (parser-error/common id 'recoverable msgs '#t)
  `#\?)

(define (parser-error id . msgs)
  (parser-error/common id 'phase msgs '#f)
  (if (null? *layout-stack*)
      (abort-compilation)
      (recover-to-next-decl *token-stream*)))

(define (parser-error/recoverable id . args)
  (parser-error/common id 'recoverable args '#f))

(define (parser-error/common id type msgs in-lexer?)
  (let ((place
	 (if in-lexer?
	     (list "Error occured at in file ~A at line ~A, column ~A."
		   *current-file* *current-line* *current-col*)
	     (list "Error occured at in file ~A at line ~A, token ~A."
		   *current-file* *current-line*
		   (cond ((null? *token-args*)
			  *token*)
			 ((null? (cdr *token-args*))
			  (car *token-args*))
			 (else *token-args*)))))) ; could be better
    (haskell-error id type (list place msgs))))

(define (recover-to-next-decl tokens)
  (cond ((null? tokens)
	 (abort-compilation))
	((eq? (car (car tokens)) 'line)
	 (search-layout-stack *layout-stack* tokens (caddr (car tokens))))
	(else (recover-to-next-decl (cdr tokens)))))

(define (search-layout-stack layouts tokens column)
  (cond ((null? layouts)
	 (abort-compilation))
	((> column (layout-col (car layouts)))
	 (recover-to-next-decl (cdr tokens)))
	((= column (layout-col (car layouts)))
	 (setf *current-col* column)
	 (setf *current-line* (cadr (car tokens)))
	 (setf *token-stream* (cdr tokens))
	 (advance-token)  ; loads up *token*
	 ;; *** layout-recovery-fn is not defined anywhere!
	 (funcall (layout-recovery-fn (car layouts))))
	(else
	 (setf *layout-stack* (cdr *layout-stack*))
	 (search-layout-stack (cdr layouts) tokens column))))


;;; Here are some very commonly used signalling functions.
;;; Other (more specific) signalling functions are defined near
;;; the places where they are called.


;;; This is used when a particular token isn't found.

(define (signal-missing-token what where)
  (parser-error 'missing-token
		"Missing ~a in ~a." what where))


;;; This is used to signal more complicated parse failures involving
;;; failure to match a nonterminal.

(define (signal-invalid-syntax where)
  (parser-error 'invalid-syntax
		"Invalid syntax appears where ~a is expected." where))