X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/002d481f71272b0605ac310f3cea595780dae531..a5b9e2bef2e640d841229bd7ec1b69782e6e7e70:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 63d75cd..81a3956 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -226,7 +226,7 @@ (parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag) (seq ("teardown") #'make-sod-class-tearfrag))) (frag (parse-delimited-fragment scanner #\{ #\}))) - (funcall make class frag pset scanner))))) + (funcall make class frag pset :location scanner))))) (define-pluggable-parser class-item initargs (scanner class pset) ;; initarg-item ::= `initarg' declspec+ list[init-declarator] @@ -243,7 +243,9 @@ (make-sod-user-initarg class (cdr declarator) (car declarator) - pset init scanner)) + pset + :default init + :location scanner)) #\,)) (nil (must #\;))))))) @@ -260,6 +262,21 @@ (with-parser-context (token-scanner-context :scanner scanner) (when name (make-class-type name)) (let* ((duff (null name)) + (superclasses + (let ((superclasses (restart-case + (mapcar #'find-sod-class + (or supers (list "SodObject"))) + (continue () + (setf duff t) + (list (find-sod-class "SodObject")))))) + (find-duplicates (lambda (first second) + (declare (ignore second)) + (setf duff t) + (cerror* "Class `~A' has duplicate ~ + direct superclass `~A'" + name first)) + superclasses) + (delete-duplicates superclasses))) (synthetic-name (or name (let ((var (synthetic-name))) (unless pset @@ -267,33 +284,30 @@ (unless (pset-get pset "nick") (add-property pset "nick" var :type :id)) var))) - (class (make-sod-class synthetic-name - (restart-case - (mapcar #'find-sod-class - (or supers (list "SodObject"))) - (continue () - (setf duff t) - (list (find-sod-class "SodObject")))) - pset scanner)) + (class (make-sod-class synthetic-name superclasses pset + :location 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 - ;; + (labels ((must-id () + (parse (must :id (progn (setf duff t) (synthetic-name))))) + + (parse-maybe-dotted-name () ;; maybe-dotted-name ::= [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 - :keywordp t - :kernel (parser () - (seq ((name-a :id) - (name-b (? (seq (#\. (id :id)) id)))) - (if name-b (cons name-a name-b) - name-a))))) + (parse (seq ((name-a (must-id)) + (name-b (? (seq (#\. (id (must-id))) id)))) + (if name-b (cons name-a name-b) + name-a)))) + + (parse-maybe-dotted-declarator (base-type) + ;; Parse a declarator or dotted-declarator, i.e., one whose + ;; centre is maybe-dotted-name above. + (parse-declarator scanner base-type + :keywordp t + :kernel #'parse-maybe-dotted-name)) (parse-message-item (sub-pset type name) ;; message-item ::= @@ -302,8 +316,8 @@ ;; Don't allow a method-body here if the message takes a ;; varargs list, because we don't have a name for the ;; `va_list' parameter. - (let ((message (make-sod-message class name type - sub-pset scanner))) + (let ((message (make-sod-message class name type sub-pset + :location scanner))) (if (varargs-message-p message) (parse #\;) (parse (or #\; (parse-method-item sub-pset @@ -319,7 +333,8 @@ scanner #\{ #\})))) (restart-case (make-sod-method class sub-nick name type - body sub-pset scanner) + body sub-pset + :location scanner) (continue () :report "Continue"))))) (parse-initializer () @@ -327,7 +342,7 @@ ;; ;; Return a VALUE, ready for passing to a `sod-initializer' ;; constructor. - (parse-delimited-fragment scanner #\= (list #\, #\;) + (parse-delimited-fragment scanner #\= '(#\, #\;) :keep-end t)) (parse-slot-item (sub-pset base-type type name) @@ -339,24 +354,26 @@ (flet ((make-it (name type init) (restart-case (progn - (make-sod-slot class name type - sub-pset scanner) + (make-sod-slot class name type sub-pset + :location scanner) (when init - (make-sod-instance-initializer class - nick name - init - sub-pset - scanner))) + (make-sod-instance-initializer + class nick name init sub-pset + :location scanner))) (continue () :report "Continue")))) - (parse (and (seq ((init (? (parse-initializer)))) - (make-it name type init)) + (parse (and (error () + (seq ((init (? (parse-initializer)))) + (make-it name type init)) + (skip-until () #\, #\;)) (skip-many () - (seq (#\, - (ds (parse-declarator scanner - base-type)) - (init (? (parse-initializer)))) - (make-it (cdr ds) (car ds) init))) - #\;)))) + (error (:ignore-unconsumed t) + (seq (#\, + (ds (parse-declarator scanner + base-type)) + (init (? (parse-initializer)))) + (make-it (cdr ds) (car ds) init)) + (skip-until () #\, #\;))) + (must #\;))))) (parse-initializer-item (sub-pset must-init-p constructor) ;; initializer-item ::= @@ -366,15 +383,19 @@ (let ((parse-init (if must-init-p #'parse-initializer (parser () (? (parse-initializer)))))) (parse (and (skip-many () - (seq ((name-a :id) #\. (name-b :id) - (init (funcall parse-init))) - (restart-case - (funcall constructor class - name-a name-b init - sub-pset scanner) - (continue () :report "Continue"))) + (error (:ignore-unconsumed t) + (seq ((name-a :id) #\. + (name-b (must-id)) + (init (funcall parse-init))) + (restart-case + (funcall constructor class + name-a name-b init + sub-pset + :location scanner) + (continue () :report "Continue"))) + (skip-until () #\, #\;)) #\,) - #\;)))) + (must #\;))))) (class-item-dispatch (sub-pset base-type type name) ;; Logically part of `parse-raw-class-item', but the @@ -424,12 +445,12 @@ (parse-initializer-item sub-pset nil #'make-sod-instance-initializer))))) - (parse (seq (#\{ + (parse (seq ((nil (must #\{)) (nil (skip-many () (seq ((sub-pset (parse-property-set scanner)) (nil (parse-raw-class-item sub-pset))) (check-unused-properties sub-pset)))) - (nil (error () #\}))) + (nil (must #\}))) (unless (finalize-sod-class class) (setf duff t)) (unless duff