X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/26c5ecfef79e0158c3ea38e9c32ad1fe3e85be3e..6afec9101d5ea87e3df4bda2239ffd05f8154fa6:/src/lexer-proto.lisp diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp index a70addc..a237a92 100644 --- a/src/lexer-proto.lisp +++ b/src/lexer-proto.lisp @@ -52,50 +52,67 @@ indicator) (export 'syntax-error) -(defun syntax-error (scanner expected &key (continuep t)) +(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 "" + value)) + (:int "") + (:string "") + (:char "") + (:eof "") + (:ellipsis "`...'") + (:shl "`<<'") + (:shr "`>>'") + (:eq "`=='") + (:ne "`!='") + (:le "`<='") + (:ge "`>='") + (:and "`&&'") + (:or "`||'") + (t (format nil "" 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 "" 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 "" value)) - (:int "") - (:string "") - (:char "") - (:eof "") - (:ellipsis "`...'") - (t (format nil "" 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 "" thing))))) - (funcall (if continuep #'cerror* #'error) - "Syntax error: ~ - expected ~{~#[~;~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) -(defun lexer-error (char-scanner expected) +(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 "" (cadr exp))) + ((eql :eof) "") + ((eql :any) "") + (t (format nil "" exp))))) + (report-parser-error error stream + #'show-expected #'show-char))))) +(defun lexer-error (char-scanner expected &key location) "Signal a continuable lexical error." - (cerror* "Lexical error: ~ - expected ~{~#[~;~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 "" - (cadr exp))) - ((eql :eof) "") - ((eql :any) "") - (t (format nil "" 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) @@ -103,19 +120,24 @@ &rest token-types) "Discard tokens until we find one listed in TOKEN-TYPES. + Each of the TOKEN-TYPES is an expression which evaluates to either a + two-item list (TYPE VALUE), or a singleton TYPE; the latter is equivalent + to a list (TYPE t). Such a pair matches a token with the corresponding + TYPE and VALUE, except that a VALUE of `t' matches any token value. + If KEEP-END is true then retain the found token for later; otherwise discard it. KEEP-END defaults to true if multiple TOKEN-TYPES are given; otherwise false. If end-of-file is encountered then the indicator list is simply the list of TOKEN-TYPES; otherwise the result is `nil'." - `(skip-until ,(parser-scanner context) + `(%skip-until ,(parser-scanner context) (list ,@token-types) :keep-end ,(if keep-end-p keep-end (> (length token-types) 1)))) (export 'error) (defparse error (:context (context token-scanner-context) - (&key ignore-unconsumed) - sub &optional (recover t)) + (&key ignore-unconsumed force-progress) + sub &optional (recover t) &body body) "Try to parse SUB; if it fails then report an error, and parse RECOVER. This is the main way to recover from errors and continue parsing. Even @@ -133,7 +155,17 @@ `(parse-error-recover ,(parser-scanner context) (parser () ,sub) (parser () ,recover) - :ignore-unconsumed ,ignore-unconsumed)) + :ignore-unconsumed ,ignore-unconsumed + :force-progress ,force-progress + :action ,(and body `(lambda () ,@body)))) + +(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. @@ -144,14 +176,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 --------------------------------------------------