From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 parser/parser-errors.scm | 74 ++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 74 insertions(+)
 create mode 100644 parser/parser-errors.scm

(limited to 'parser/parser-errors.scm')

diff --git a/parser/parser-errors.scm b/parser/parser-errors.scm
new file mode 100644
index 0000000..ae4d097
--- /dev/null
+++ b/parser/parser-errors.scm
@@ -0,0 +1,74 @@
+;;; 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))
+
+
-- 
cgit v1.2.3