X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/239fa5bd3dff0b38b0cebdd3438311f21c24ba4f..c91b90c3bfd3d3e68cc3d3ff3f431d1e73920061:/src/module-parse.lisp

diff --git a/src/module-parse.lisp b/src/module-parse.lisp
index f87c586..6fb6be8 100644
--- a/src/module-parse.lisp
+++ b/src/module-parse.lisp
@@ -155,12 +155,180 @@ (define-pluggable-parser module lisp (scanner)
 ;;;--------------------------------------------------------------------------
 ;;; 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)
-  ;; `class' id [`:' id-list] `{' class-item* `}'
+  ;; `class' id [`:' id-list] class-body
+  ;; `class' id `;'
 
   (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 #\,)))