lib/sod-hosted.c (sod_makev): Use two statements rather than tricky expression.

[sod] / src / lexer-proto.lisp

diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp
index d2181e1..a237a92 100644 (file)
--- a/src/lexer-proto.lisp
+++ b/src/lexer-proto.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- 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
 ;;;
 ;;; 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)
   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 "<identifier~@[ `~A'~]>"
+                                          value))
+                             (:int "<integer-literal>")
+                             (:string "<string-literal>")
+                             (:char "<character-literal>")
+                             (:eof "<end-of-file>")
+                             (:ellipsis "`...'")
+                             (:shl "`<<'")
+                             (:shr "`>>'")
+                             (:eq "`=='")
+                             (:ne "`!='")
+                             (:le "`<='")
+                             (:ge "`>='")
+                             (:and "`&&'")
+                             (:or "`||'")
+                             (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."
   "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* #'error)
-            "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)
 
 (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 "<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."
   "Signal a continuable lexical error."

-  (cerror* "Lexical error: ~
-           expected ~{~#[<bug>~;~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 "<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))
-          (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.
 
 (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'."
    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))))
 
               (list ,@token-types)
               :keep-end ,(if keep-end-p keep-end
                              (> (length token-types) 1))))
 

+(export 'error)

 (defparse error (:context (context token-scanner-context)
 (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
   "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
    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)
   `(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.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; 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)
 (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 --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------