X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/a42893dda5f4dd2b89fbfe4e497da261159225ca..ceed01afc84505ed0d116ee7a00e8b4a1a4bed6c:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index f6d69ee..4d4d818 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -31,7 +31,7 @@ (in-package #:sod) ;;; Type names. (define-pluggable-parser module typename (scanner pset) - ;; `typename' id ( `,' id )* `;' + ;; `typename' list[id] `;' (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (and "typename" @@ -50,7 +50,7 @@ (define-pluggable-parser module typename (scanner pset) (define-pluggable-parser module code (scanner pset) ;; `code' id `:' item-name [constraints] `{' c-fragment `}' ;; - ;; constrains ::= `[' constraint-list `]' + ;; constraints ::= `[' list[constraint] `]' ;; constraint ::= item-name+ ;; item-name ::= id | `(' id+ `)' (declare (ignore pset)) @@ -101,17 +101,21 @@ (defun read-module (pathname &key (truename nil truep) location) (define-module (pathname :location location :truename truename) (with-open-file (f-stream pathname :direction :input) (let* ((*readtable* (copy-readtable)) + (*package* (find-package '#:sod-user)) (char-scanner (make-instance 'charbuf-scanner :stream f-stream)) (scanner (make-instance 'sod-token-scanner :char-scanner char-scanner))) (with-default-error-location (scanner) (with-parser-context (token-scanner-context :scanner scanner) - (parse (skip-many () - (seq ((pset (parse-property-set scanner)) - (nil (error () - (plug module scanner pset)))) - (check-unused-properties pset)))))))))) + (multiple-value-bind (result winp consumedp) + (parse (skip-many () + (seq ((pset (parse-property-set scanner)) + (nil (error () + (plug module scanner pset)))) + (check-unused-properties pset)))) + (declare (ignore consumedp)) + (unless winp (syntax-error scanner result))))))))) (define-pluggable-parser module test (scanner pset) ;; `demo' string `;' @@ -158,22 +162,22 @@ (define-pluggable-parser module file (scanner pset) ;;; Setting properties. (define-pluggable-parser module set (scanner pset) - ;; `set' property-list `;' + ;; `set' list[property] `;' (with-parser-context (token-scanner-context :scanner scanner) (parse (and "set" (lisp (let ((module-pset (module-pset *module*))) (when pset (pset-map (lambda (prop) - (add-property module-pset - (p-name prop) - (p-value prop) - :type (p-type prop) - :location (p-location prop)) + (add-property + module-pset + (p-name prop) (p-value prop) + :type (p-type prop) + :location (p-location prop)) (setf (p-seenp prop) t)) pset)) (parse (skip-many (:min 0) (error (:ignore-unconsumed t) - (parse-property scanner module-pset) + (parse-property scanner module-pset) (skip-until (:keep-end t) #\, #\;)) #\,)))) #\;)))) @@ -208,13 +212,38 @@ (define-pluggable-parser class-item initfrags (scanner class pset) (frag (parse-delimited-fragment scanner #\{ #\}))) (funcall make class frag pset scanner))))) +(define-pluggable-parser class-item initargs (scanner class pset) + ;; initarg-item ::= `initarg' declspec+ list[init-declarator] + ;; init-declarator ::= declarator [`=' initializer] + (with-parser-context (token-scanner-context :scanner scanner) + (parse (seq ("initarg" + (base-type (parse-c-type scanner)) + (nil (skip-many (:min 1) + (seq ((declarator (parse-declarator scanner + base-type)) + (init (? (parse-delimited-fragment + scanner #\= (list #\; #\,) + :keep-end t)))) + (make-sod-user-initarg class + (cdr declarator) + (car declarator) + pset init scanner)) + #\,)) + #\;))))) + (defun parse-class-body (scanner pset name supers) ;; class-body ::= `{' class-item* `}' ;; ;; class-item ::= property-set raw-class-item (with-parser-context (token-scanner-context :scanner scanner) (make-class-type name) - (let* ((class (make-sod-class name (mapcar #'find-sod-class supers) + (let* ((duff nil) + (class (make-sod-class name + (restart-case + (mapcar #'find-sod-class supers) + (continue () + (setf duff t) + (list (find-sod-class "SodObject")))) pset scanner)) (nick (sod-class-nickname class))) @@ -272,10 +301,9 @@ (defun parse-class-body (scanner pset name supers) (parse-slot-item (sub-pset base-type type name) ;; slot-item ::= ;; declspec+ declarator -!- [initializer] - ;; [`,' init-declarator-list] `;' + ;; [`,' list[init-declarator]] `;' ;; - ;; init-declarator-list ::= - ;; declarator [initializer] [`,' init-declarator-list] + ;; init-declarator ::= declarator [initializer] (parse (and (seq ((init (? (parse-initializer)))) (make-sod-slot class name type sub-pset scanner) @@ -295,19 +323,21 @@ (defun parse-class-body (scanner pset name supers) sub-pset scanner)))) #\;))) - (parse-initializer-item (sub-pset constructor) + (parse-initializer-item (sub-pset must-init-p constructor) ;; initializer-item ::= - ;; [`class'] -!- slot-initializer-list `;' + ;; [`class'] -!- list[slot-initializer] `;' ;; - ;; 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 init - sub-pset scanner)) - #\,) - #\;))) + ;; slot-initializer ::= id `.' id [initializer] + (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))) + (funcall constructor class + name-a name-b init + sub-pset scanner)) + #\,) + #\;)))) (class-item-dispatch (sub-pset base-type type name) ;; Logically part of `parse-raw-class-item', but the @@ -323,7 +353,7 @@ (defun parse-class-body (scanner pset name supers) (when (consp name) (cerror*-with-location scanner - "Method declarations must have function type.") + "Method declarations must have function type") (setf name (cdr name))) (parse-slot-item sub-pset base-type type name)) ((consp name) @@ -347,16 +377,15 @@ (defun parse-class-body (scanner pset name supers) (peek (seq ((ds (parse-c-type scanner)) (dc (parse-maybe-dotted-declarator ds)) + (nil (commit)) (nil (class-item-dispatch sub-pset ds (car dc) (cdr dc)))))) (and "class" - (parse-initializer-item - sub-pset + (parse-initializer-item sub-pset t #'make-sod-class-initializer)) - (parse-initializer-item - sub-pset + (parse-initializer-item sub-pset nil #'make-sod-instance-initializer))))) (parse (seq (#\{ @@ -365,19 +394,21 @@ (defun parse-class-body (scanner pset name supers) (nil (parse-raw-class-item sub-pset))) (check-unused-properties sub-pset)))) (nil (error () #\}))) - (finalize-sod-class class) - (add-to-module *module* class))))))) + (unless (finalize-sod-class class) + (setf duff t)) + (unless duff + (add-to-module *module* class)))))))) (define-pluggable-parser module class (scanner pset) - ;; `class' id [`:' id-list] class-body + ;; `class' id `:' list[id] class-body ;; `class' id `;' (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ("class" (name :id) (nil (or (seq (#\;) (make-class-type name)) - (seq ((supers (? (seq (#\: (ids (list () :id #\,))) - ids))) + (seq ((supers (seq (#\: (ids (list () :id #\,))) + ids)) (nil (parse-class-body scanner pset name supers)))))))))))