X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/1d8cc67a3f4ded443f5efc673a616883cbae9c50..refs/heads/master:/src/lexer-proto.lisp diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp index d2181e1..a237a92 100644 --- a/src/lexer-proto.lisp +++ b/src/lexer-proto.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -52,69 +52,92 @@ 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 consumedp) +(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/~ - ~@[ at ~A~]" - (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)) - (and consumedp (file-location 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) (&key (keep-end nil keep-end-p)) &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) 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 @@ -124,27 +147,60 @@ were never here. Otherwise, try to recover in a sensible way so we can continue parsing. The details of this recovery are subject to change, but the final action is generally to invoke the RECOVER parser and return its - result." + result. + + If IGNORE-UNCONSUMED evaluates non-nil, then just propagate a failure of + SUB if it didn't consume input. (This makes it suitable for use where the + parser containing `error' might be optional.)" `(parse-error-recover ,(parser-scanner context) (parser () ,sub) - (parser () ,recover))) + (parser () ,recover) + :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. +(export 'scan-comment) (defun scan-comment (char-scanner) "Scan a comment (either `/* ... */' or `// ...') from 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 --------------------------------------------------