X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/450a4be6a6d832ce1e54169d9cc7740f5a04dc89..40d95de71fca4c3b7b145d5ba73d1420e8854673:/src/lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index 349e2a0..d5f25fd 100644
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -52,52 +52,59 @@ (defun define-indicator (indicator description)
   indicator)
 
 (export 'syntax-error)
+(define-condition syntax-error (parser-error base-syntax-error)
+  ((found :type cons))
+  (:report (lambda (error stream)
+	     (labels ((show-token (type value)
+			(if (characterp type) (show-char type)
+			    (case type
+			      (:id (format nil "<identifier~@[ `~A'~]>"
+					   value))
+			      (:int "<integer-literal>")
+			      (:string "<string-literal>")
+			      (:char "<character-literal>")
+			      (:eof "<end-of-file>")
+			      (:ellipsis "`...'")
+			      (t (format nil "<? ~S~@[ ~S~]>" type value)))))
+		      (show-expected (thing)
+			(acond ((gethash thing *indicator-map*) it)
+			       ((atom thing) (show-token thing nil))
+			       ((eq (car thing) :id)
+				(format nil "`~A'" (cadr thing)))
+			       (t (format nil "<? ~S>" thing)))))
+	       (report-parser-error error stream
+				    #'show-expected
+				    (lambda (found)
+				      (show-token (car found)
+						  (cdr found))))))))
 (defun syntax-error (scanner expected &key (continuep t) location)
   "Signal a (maybe) continuable syntax error."
-  (labels ((show-token (type value)
-	     (if (characterp type)
-		 (format nil "~/sod::show-char/" type)
-		 (case type
-		   (:id (format nil "<identifier~@[ `~A'~]>" value))
-		   (:int "<integer-literal>")
-		   (:string "<string-literal>")
-		   (:char "<character-literal>")
-		   (:eof "<end-of-file>")
-		   (:ellipsis "`...'")
-		   (t (format nil "<? ~S~@[ ~S~]>" type value)))))
-	   (show-expected (thing)
-	     (acond ((gethash thing *indicator-map*) it)
-		    ((atom thing) (show-token thing nil))
-		    ((eq (car thing) :id)
-		     (format nil "`~A'" (cadr thing)))
-		    (t (format nil "<? ~S>" thing)))))
-    (funcall (if continuep #'cerror*-with-location #'error-with-location)
-	     (or location scanner)
-	     "Syntax error: ~
-	      expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
-	      but found ~A"
-	     (mapcar #'show-expected expected)
-	     (show-token (token-type scanner) (token-value scanner)))))
+  (funcall (if continuep #'cerror*-with-location #'error-with-location)
+	   (or location scanner) 'syntax-error
+	   :expected expected
+	   :found (cons (token-type scanner) (token-value scanner))))
 
 (export 'lexer-error)
+(define-condition lexer-error (parser-error base-lexer-error)
+  ((found :type (or character nil)))
+  (:report (lambda (error stream)
+	     (flet ((show-expected (exp)
+		      (typecase exp
+			(character (show-char exp))
+			(string (format nil "`~A'" exp))
+			((cons (eql :digit) *)
+			 (format nil "<radix-~A digit>" (cadr exp)))
+			((eql :eof) "<end-of-file>")
+			((eql :any) "<character>")
+			(t (format nil "<? ~S>" exp)))))
+	       (report-parser-error error stream
+				    #'show-expected #'show-char)))))
 (defun lexer-error (char-scanner expected &key location)
   "Signal a continuable lexical error."
-  (cerror*-with-location (or location char-scanner)
-			 "Lexical error: ~
-			  expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
-			  but found ~/sod::show-char/"
-	   (mapcar (lambda (exp)
-		     (typecase exp
-		       (character (format nil "~/sod::show-char/" exp))
-		       (string (format nil "`~A'" exp))
-		       ((cons (eql :digit) *) (format nil "<radix-~A digit>"
-						      (cadr exp)))
-		       ((eql :eof) "<end-of-file>")
-		       ((eql :any) "<character>")
-		       (t (format nil "<? ~S>" exp))))
-		   expected)
-	   (and (not (scanner-at-eof-p char-scanner))
-		(scanner-current-char char-scanner))))
+  (cerror*-with-location (or location char-scanner) 'lexer-error
+			 :expected expected
+			 :found (and (not (scanner-at-eof-p char-scanner))
+				     (scanner-current-char char-scanner))))
 
 (export 'skip-until)
 (defparse skip-until (:context (context token-scanner-context)
@@ -138,6 +145,14 @@ (defparse error (:context (context token-scanner-context)
 			:ignore-unconsumed ,ignore-unconsumed
 			:force-progress ,force-progress))
 
+(export 'must)
+(defparse must (:context (context token-scanner-context)
+		sub &optional default)
+  "Try to parse SUB; if it fails, report an error, and return DEFAULT.
+
+   This parser can't actually fail."
+  `(parse (error () ,sub (t ,default))))
+
 ;;;--------------------------------------------------------------------------
 ;;; Lexical analysis utilities.
 
@@ -147,14 +162,31 @@ (defun scan-comment (char-scanner)
 
    The result isn't interesting."
   (with-parser-context (character-scanner-context :scanner char-scanner)
-    (parse (or (and "/*"
-		    (and (skip-many ()
-			   (and (skip-many () (not #\*))
-				(label "*/" (skip-many (:min 1) #\*)))
-			   (not #\/))
-			 #\/))
-	       (and "//"
-		    (skip-many () (not #\newline))
-		    (? #\newline))))))
+    (let ((start (file-location char-scanner)))
+      (parse (or (and "/*"
+		      (lisp (let ((state nil))
+			      (loop (cond ((scanner-at-eof-p char-scanner)
+					   (lexer-error char-scanner
+							(list "*/"))
+					   (info-with-location
+					    start "Comment started here")
+					   (return (values nil t t)))
+					  ((char= (scanner-current-char
+						   char-scanner)
+						  #\*)
+					   (setf state '*)
+					   (scanner-step char-scanner))
+					  ((and (eq state '*)
+						(char= (scanner-current-char
+							char-scanner)
+						       #\/))
+					   (scanner-step char-scanner)
+					   (return (values nil t t)))
+					  (t
+					   (setf state nil)
+					   (scanner-step char-scanner)))))))
+		 (and "//"
+		      (skip-many () (not #\newline))
+		      (? #\newline)))))))
 
 ;;;----- That's all, folks --------------------------------------------------