Daily work in progress.

diff --git a/src/fragment-parse.lisp b/src/fragment-parse.lisp
index 6e71994ebeb8c95fc26294fbfffd504f04550edd..b1e9e8c0c0b50cbdcc99473a91f876c3fcb78ba7 100644 (file)
--- a/src/fragment-parse.lisp
+++ b/src/fragment-parse.lisp
@@ -32,7 +32,9 @@ (export 'scan-c-fragment)
 (defun scan-c-fragment (scanner end-chars)
   "Parse a C fragment from the SCANNER.
 
 (defun scan-c-fragment (scanner end-chars)
   "Parse a C fragment from the SCANNER.
 

-   SCANNER must be a `sod-token-scanner' instance.
+   SCANNER must be a `sod-token-scanner' instance.  The END-CHARS are a
+   sequence of characters, any of which delimits the fragment.  The
+   delimiting character is left current in the scanner.

 
    The parsing process is a simple approximation to C lexical analysis.  It
    takes into account comments (both C and C++ style), string and character
 
    The parsing process is a simple approximation to C lexical analysis.  It
    takes into account comments (both C and C++ style), string and character


@@ -75,12 +77,14 @@ (defun scan-c-fragment (scanner end-chars)
              ((satisfies whitespace-char-p) (parse :whitespace))
              ((scan-comment char-scanner))
 
              ((satisfies whitespace-char-p) (parse :whitespace))
              ((scan-comment char-scanner))
 

-             ;; See if we've reached the end.  There's a small trick here: I
-             ;; capture the result in the `if-char' consequent to ensure
-             ;; that we don't include the delimiter.
-             ((if-char () (and (null delim) (member it end-chars))
-                (values (result) t t)
-                (values end-chars nil nil))
+             ;; See if we've reached the end.  We must leave the delimiter
+             ;; in the scanner, so `if-char' and its various friends aren't
+             ;; appropriate.
+             ((lisp (if (and (null delim)
+                             (member (scanner-current-char char-scanner)
+                                     end-chars))
+                        (values (result) t t)
+                        (values end-chars nil nil)))

               (return (values it t t)))
              (:eof
               (lexer-error char-scanner '(:any) cp)
               (return (values it t t)))
              (:eof
               (lexer-error char-scanner '(:any) cp)


@@ -111,21 +115,33 @@ (defun scan-c-fragment (scanner end-chars)
               (lexer-error char-scanner exp cp)))))))))
 
 (export 'parse-delimited-fragment)
               (lexer-error char-scanner exp cp)))))))))
 
 (export 'parse-delimited-fragment)

-(defun parse-delimited-fragment (scanner begin end)
+(defun parse-delimited-fragment (scanner begin end &key keep-end)

   "Parse a C fragment delimited by BEGIN and END.
 
   "Parse a C fragment delimited by BEGIN and END.
 

-   The BEGIN and END arguments are characters.  (Currently, BEGIN can be any
-   token type, but you probably shouldn't rely on this.)"
+   The BEGIN and END arguments are the start and end delimiters.  BEGIN can
+   be any token type, but is usually a delimiter character; it may also be t
+   to mean `don't care' -- but there must be an initial token of some kind
+   for annoying technical reasons.  END may be either a character or a list
+   of characters.  If KEEP-END is true, the trailing delimiter is left in the
+   token scanner so that it's available for further parsing decisions: this
+   is probably what you want if END is a list."

 
   ;; This is decidedly nasty.  The basic problem is that `scan-c-fragment'
   ;; works at the character level rather than at the lexical level, and if we
 
   ;; This is decidedly nasty.  The basic problem is that `scan-c-fragment'
   ;; works at the character level rather than at the lexical level, and if we

-  ;; commit to the `[' too early then `scanner-step' will eat the first few
-  ;; characters of the fragment -- and then the rest of the parse will get
-  ;; horrifically confused.
-
-  (if (eql (token-type scanner) begin)
-      (multiple-value-prog1 (values (scan-c-fragment scanner (list end)) t t)
-       (scanner-step scanner))
+  ;; commit to the BEGIN character too early then `scanner-step' will eat the
+  ;; first few characters of the fragment -- and then the rest of the parse
+  ;; will get horrifically confused.
+
+  (if (if (eq begin t)
+         (not (scanner-at-eof-p scanner))
+         (eql (token-type scanner) begin))
+      (multiple-value-prog1 (values (scan-c-fragment scanner
+                                                    (if (listp end)
+                                                        end
+                                                        (list end)))
+                                   t t)
+       (scanner-step scanner)
+       (unless keep-end (scanner-step scanner)))

       (values (list begin) nil nil)))
 
 ;;;----- That's all, folks --------------------------------------------------
       (values (list begin) nil nil)))
 
 ;;;----- That's all, folks --------------------------------------------------

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index f87c586707399f35891bdfcf75e6b86cc40c8a1d..6fb6be800b4a813e461446c8893dd69b41a2a75e 100644 (file)
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -155,12 +155,180 @@ (define-pluggable-parser module lisp (scanner)
 ;;;--------------------------------------------------------------------------
 ;;; Class declarations.
 
 ;;;--------------------------------------------------------------------------
 ;;; Class declarations.
 

+(defun parse-class-body (scaner pset name supers)
+  ;; class-body ::= `{' class-item* `}'
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (make-class-type name)
+    (let* ((class (make-sod-class name (mapcat #'find-sod-class supers)
+                                 pset scanner))
+          (nick (sod-class-nickname class)))
+
+      (labels ((parse-maybe-dotted-declarator (base-type)
+                ;; Parse a declarator or dotted-declarator, i.e., one whose
+                ;; centre is
+                ;;
+                ;; maybe-dotted-identifier ::= [id `.'] id
+                ;;
+                ;; A plain identifier is returned as a string, as usual; a
+                ;; dotted identifier is returned as a cons cell of the two
+                ;; names.
+                (parse-declarator
+                 scanner base-type
+                 :centre (parser ()
+                           (seq ((name-a :id)
+                                 (name-b (? (seq (#\. (id :id)) id))))
+                             (if name-b (cons name-a name-b)
+                                 name-a)))))
+
+              ;; class-item ::= [property-set] raw-class-item
+              ;;
+
+              (parse-message-item (sub-pset type name)
+                ;; message-item ::=
+                ;;     declspec+ declarator -!- (method-body | `;')
+                (make-sod-message class name type sub-pset scanner)
+                (parse (or #\; (parse-method-item nil type nick name))))
+
+              (parse-method-item (sub-pset type sub-nick name)
+                ;; method-item ::=
+                ;;     declspec+ dotted-declarator -!- method-body
+                ;;
+                ;; method-body ::= `{' c-fragment `}' | `extern' `;'
+                (parse (seq ((body (or (seq ("extern" #\;) nil)
+                                       (parse-delimited-fragment
+                                        scanner #\{ #\}))))
+                         (make-sod-method class sub-nick name type
+                                          body sub-pset scanner))))
+
+              (parse-initializer ()
+                ;; initializer ::= `=' c-fragment | `=' `{' c-fragment `}'
+                ;;
+                ;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a
+                ;; `sod-initializer' constructor.
+                (parse (or (peek (seq (#\= (frag (parse-delimited-fragment
+                                                  scanner #\{ #\})))
+                                   (cons :compound frag)))
+                           (seq ((frag (parse-delimited-fragment
+                                        scanner #\= '(#\; #\,)
+                                        :keep-end t)))
+                             (cons :simple frag)))))
+
+              (parse-slot-item (sub-pset base-type type name)
+                ;; slot-item ::=
+                ;;     declspec+ declarator -!- [initializer]
+                ;;             [`,' init-declarator-list] `;'
+                ;;
+                ;; init-declarator-list ::=
+                ;;     declarator [initializer] [`,' init-declarator-list]
+                (parse (and (seq ((init (? (parse-initializer))))
+                              (make-sod-slot class name type
+                                             sub-pset scanner)
+                              (when init
+                                (make-sod-instance-initializer
+                                 class nick name (car init) (cdr init)
+                                 nil scanner)))
+                            (skip-many ()
+                              (seq (#\,
+                                    (ds (parse-declarator scanner
+                                                          base-type))
+                                    (init (? (parse-initializer))))
+                                (make-sod-slot class (cdr ds) (car ds)
+                                               sub-pset scanner)
+                                (when init
+                                  (make-sod-instance-initializer
+                                   class nick (cdr ds)
+                                   (car init) (cdr init)
+                                   nil scanner))))
+                            #\;)))
+
+              (parse-initializer-item (sub-pset constructor)
+                ;; initializer-item ::=
+                ;;     [`class'] -!- slot-initializer-list `;'
+                ;;
+                ;; slot-initializer ::= id `.' id initializer
+                (parse (and (skip-many ()
+                              (seq ((name-a :id) #\. (name-b :id)
+                                    (init (parse-initializer)))
+                                (funcall constructor class
+                                         name-a name-b
+                                         (car init) (cdr init)
+                                         sub-pset scanner))
+                              #\,)
+                            #\;)))
+
+              (class-item-dispatch (sub-pset base-type type name)
+                ;; Logically part of `parse-raw-class-item', but the
+                ;; indentation was getting crazy.  We're currently at
+                ;;
+                ;; raw-class-item ::=
+                ;;     declspec+ (declarator | dotted-declarator) -!- ...
+                ;;   | other-items
+                ;;
+                ;; If the declarator is dotted then this must be a method
+                ;; definition; otherwise it might be a message or slot.
+                (cond ((not (typep type 'c-function-type))
+                       (when (consp name)
+                         (cerror*-with-location
+                          scanner
+                          "Method declarations must have function type.")
+                         (setf name (cdr name)))
+                       (parse-slot-item sub-pset base-type type name))
+                      ((consp name)
+                       (parse-method-item sub-pset type
+                                          (car name) (cdr name)))
+                      (t
+                       (parse-message-item sub-pset type name))))
+
+              (parse-raw-class-item (sub-pset)
+                ;; raw-class-item ::=
+                ;;     message-item
+                ;;   | method-item
+                ;;   | slot-item
+                ;;   | initializer-item
+                ;;
+                ;; Most of the above begin with declspecs and a declarator
+                ;; (which might be dotted).  So we parse that here and
+                ;; dispatch based on what we find.
+                (parse (or (peek
+                            (seq ((ds (parse-c-type scanner))
+                                  (dc (parse-maybe-dotted-declarator ds))
+                                  (result (class-item-dispatch sub-pset
+                                                               ds
+                                                               (car dc)
+                                                               (cdr dc))))
+                              result))
+                           (and "class"
+                                (parse-initializer-item
+                                 sub-pset
+                                 #'make-sod-class-initializer))
+                           (parse-initializer-item
+                            sub-pset
+                            #'make-sod-instance-initializer)))))
+
+       (parse (and #\{
+                   (skip-many ()
+                     (seq ((sub-pset (? (parse-property-set)))
+                           (nil (parse-raw-class-item sub-pset)))))
+                   #\}))))))
+

 (define-pluggable-parser module class (scanner)
 (define-pluggable-parser module class (scanner)

-  ;; `class' id [`:' id-list] `{' class-item* `}'
+  ;; `class' id [`:' id-list] class-body
+  ;; `class' id `;'

 
   (with-parser-context (token-scanner-context :scanner scanner)
 
   (with-parser-context (token-scanner-context :scanner scanner)

-    (labels ((parse-item ()
-              ;; class-item ::= property-set
+    (parse (seq ("class"
+                (name :id)
+                (nil (or (seq (#\;)
+                           (make-class-type name))
+                         (seq ((supers (? (seq (#\: (ids (list () :id #\,)))
+                                            ids)))
+                               (nil (parse-class-body
+                                     scanner
+                                     pset name supers)))))))))))
+
+
+
+

     (parse (seq ("class"
                 (name :id)
                 (supers (? (seq (#\: (supers (list (:min 1) :id #\,)))
     (parse (seq ("class"
                 (name :id)
                 (supers (? (seq (#\: (supers (list (:min 1) :id #\,)))

diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp
index 879db4c1946ad324ef90813f6a021805c3b18f83..f60e4254ecd3a80f4095b3f2bb7544249229790d 100644 (file)
--- a/src/parser/parser-proto.lisp
+++ b/src/parser/parser-proto.lisp
@@ -843,7 +843,7 @@ (defparse token (:context (context token-parser-context)
    A token matches under the following conditions:
 
      * If the value of TYPE is `t' then the match succeeds if and only if the
    A token matches under the following conditions:
 
      * If the value of TYPE is `t' then the match succeeds if and only if the

-       parser it not at end-of-file.
+       parser is not at end-of-file.

 
      * If the value of TYPE is not `eql' to the token type then the match
        fails.
 
      * If the value of TYPE is not `eql' to the token type then the match
        fails.

diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp
index be7984e91fccca8d60b5de4ab93fb0602e48530d..0bc4680072ce2f5c607dd533b720ff30d8178f66 100644 (file)
--- a/src/pset-parse.lisp
+++ b/src/pset-parse.lisp
@@ -23,6 +23,8 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 

+(in-package #:sod)
+

 ;;;--------------------------------------------------------------------------
 ;;; The expression parser.
 
 ;;;--------------------------------------------------------------------------
 ;;; The expression parser.
 


@@ -127,14 +129,14 @@ (defun parse-property (scanner pset)
 
 (export 'parse-property-set)
 (defun parse-property-set (scanner)
 
 (export 'parse-property-set)
 (defun parse-property-set (scanner)

-  "Parse an optional property set from the SCANNER and return it, or `nil'."
-  ;; property-set ::= [`[' property-list `]']
+  "Parse an optional property set from the SCANNER and return it."
+  ;; property-set ::= `[' property-list `]'

   (with-parser-context (token-scanner-context :scanner scanner)
   (with-parser-context (token-scanner-context :scanner scanner)

-    (parse (? (seq (#\[
-                   (pset (many (pset (make-property-set) pset)
-                           (parse-property scanner pset)
-                           #\,))
-                   #\])
-               pset)))))
+    (parse (seq (#\[
+                (pset (many (pset (make-property-set) pset)
+                        (parse-property scanner pset)
+                        #\,))
+                #\])
+            pset))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------