X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/c1098ad8614af0cf52d057df6e9c2a17aaf19fe3..97d10f8b1f631cd32ea5ac9118b253cb4142d391:/src/lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index 1850326..122da75 100644
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -52,7 +52,7 @@
   indicator)
 
 (export 'syntax-error)
-(defun syntax-error (scanner expected &key (continuep t))
+(defun syntax-error (scanner expected &key (continuep t) location)
   "Signal a (maybe) continuable syntax error."
   (labels ((show-token (type value)
 	     (if (characterp type)
@@ -71,7 +71,8 @@
 		    ((eq (car thing) :id)
 		     (format nil "`~A'" (cadr thing)))
 		    (t (format nil "<? ~S>" thing)))))
-    (funcall (if continuep #'cerror* #'error)
+    (funcall (if continuep #'cerror*-with-location #'error-with-location)
+	     (or location scanner)
 	     "Syntax error: ~
 	      expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
 	      but found ~A"
@@ -79,12 +80,15 @@
 	     (show-token (token-type scanner) (token-value scanner)))))
 
 (export 'lexer-error)
-(defun lexer-error (char-scanner expected consumedp)
+(defun lexer-error (char-scanner expected &key location)
   "Signal a continuable lexical error."
-  (cerror* "Lexical error: ~
-	    expected ~{~#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
-	    but found ~/sod::show-char/~
-	    ~@[ at ~A~]"
+  (cerror*-with-location (or location char-scanner)
+			 "Lexical error: ~
+			  ~:[unexpected~;~
+			     expected ~:*~{~#[~;~A~;~A or ~A~:;~
+					      ~@{~A, ~#[~;or ~A~]~}~]~} ~
+			     but found~] ~
+			  ~/sod::show-char/"
 	   (mapcar (lambda (exp)
 		     (typecase exp
 		       (character (format nil "~/sod::show-char/" exp))
@@ -96,8 +100,7 @@
 		       (t (format nil "<? ~S>" exp))))
 		   expected)
 	   (and (not (scanner-at-eof-p char-scanner))
-		(scanner-current-char char-scanner))
-	   (and consumedp (file-location char-scanner))))
+		(scanner-current-char char-scanner))))
 
 (export 'skip-until)
 (defparse skip-until (:context (context token-scanner-context)
@@ -116,7 +119,7 @@
 
 (export 'error)
 (defparse error (:context (context token-scanner-context)
-		 (&key ignore-unconsumed)
+		 (&key ignore-unconsumed force-progress)
 		 sub &optional (recover t))
   "Try to parse SUB; if it fails then report an error, and parse RECOVER.
 
@@ -135,7 +138,8 @@
   `(parse-error-recover ,(parser-scanner context)
 			(parser () ,sub)
 			(parser () ,recover)
-			:ignore-unconsumed ,ignore-unconsumed))
+			:ignore-unconsumed ,ignore-unconsumed
+			:force-progress ,force-progress))
 
 ;;;--------------------------------------------------------------------------
 ;;; Lexical analysis utilities.
@@ -146,14 +150,31 @@
 
    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 --------------------------------------------------