X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/300a3f0a55f777216bcc7e9de833b28fb57104ac..6362119ed7d736a6617f59f46ec98b6351cb9867:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 9fa9a1f..e175a5b 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -31,26 +31,29 @@ (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" - (skip-many (:min 1) - (seq ((id :id)) - (if (gethash id *module-type-map*) - (cerror* "Type `~A' already defined" id) - (add-to-module *module* - (make-instance 'type-item - :name id)))) + (skip-many () + (error () + (seq ((id :id)) + (if (or (gethash id *module-type-map*) + (find-simple-c-type id)) + (cerror* "Type `~A' already defined" id) + (add-to-module *module* + (make-instance 'type-item + :name id)))) + (skip-until () #\, #\;)) #\,) - #\;)))) + (must #\;))))) ;;; Fragments. (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)) @@ -63,23 +66,28 @@ (define-pluggable-parser module code (scanner pset) (seq (#\( (names (list (:min 1) (kw))) #\)) names))))) (parse (seq ("code" - (reason (kw)) - #\: - (name (item)) + (reason (must (kw))) + (nil (must #\:)) + (name (must (item))) (constraints (? (seq (#\[ - (constraints (list (:min 1) - (list (:min 1) - (item)) - #\,)) + (constraints + (list () + (list (:min 1) + (error (:ignore-unconsumed t) + (item) + (skip-until () + :id #\( #\, #\]))) + #\,)) #\]) constraints))) (fragment (parse-delimited-fragment scanner #\{ #\}))) - (add-to-module *module* - (make-instance 'code-fragment-item - :fragment fragment - :constraints constraints - :reason reason - :name name))))))) + (when name + (add-to-module *module* + (make-instance 'code-fragment-item + :fragment fragment + :constraints constraints + :reason reason + :name name)))))))) ;;; External files. @@ -103,7 +111,8 @@ (define-module (pathname :location location :truename truename) (let* ((*readtable* (copy-readtable)) (*package* (find-package '#:sod-user)) (char-scanner (make-instance 'charbuf-scanner - :stream f-stream)) + :stream f-stream + :filename (namestring pathname))) (scanner (make-instance 'sod-token-scanner :char-scanner char-scanner))) (with-default-error-location (scanner) @@ -112,7 +121,9 @@ (define-module (pathname :location location :truename truename) (parse (skip-many () (seq ((pset (parse-property-set scanner)) (nil (error () - (plug module scanner pset)))) + (plug module scanner pset) + (skip-until (:keep-end nil) + #\; #\})))) (check-unused-properties pset)))) (declare (ignore consumedp)) (unless winp (syntax-error scanner result))))))))) @@ -121,7 +132,7 @@ (define-pluggable-parser module test (scanner pset) ;; `demo' string `;' (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) - (parse (seq ("demo" (string :string) #\;) + (parse (seq ("demo" (string (must :string)) (nil (must #\;))) (format t ";; DEMO ~S~%" string))))) (define-pluggable-parser module file (scanner pset) @@ -129,14 +140,15 @@ (define-pluggable-parser module file (scanner pset) ;; `load' string `;' (declare (ignore pset)) (flet ((common (name type what thunk) - (find-file scanner - (merge-pathnames name - (make-pathname :type type - :case :common)) - what - thunk))) + (when name + (find-file scanner + (merge-pathnames name + (make-pathname :type type + :case :common)) + what + thunk)))) (with-parser-context (token-scanner-context :scanner scanner) - (parse (or (seq ("import" (name :string) #\;) + (parse (or (seq ("import" (name (must :string)) (nil (must #\;))) (common name "SOD" "module" (lambda (path true) (handler-case @@ -149,8 +161,12 @@ (define-pluggable-parser module file (scanner pset) *module*)))) (file-error (error) (cerror* "Error reading module ~S: ~A" + path error)) + (error (error) + (cerror* "Unexpected error reading ~ + module ~S: ~A" path error)))))) - (seq ("load" (name :string) #\;) + (seq ("load" (name (must :string)) (nil (must #\;))) (common name "LISP" "Lisp file" (lambda (path true) (handler-case @@ -162,23 +178,23 @@ (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) + (parse (skip-many (:min (if pset 0 1)) (error (:ignore-unconsumed t) - (parse-property scanner module-pset) - (skip-until (:keep-end t) #\, #\;)) + (parse-property scanner module-pset) + (skip-until () #\, #\;)) #\,)))) #\;)))) @@ -195,7 +211,7 @@ (define-pluggable-parser module lisp (scanner pset) (scanner-step scanner) (values sexp t t)) (values '((:id "lisp")) nil nil))) - #\;) + (nil (must #\;))) (eval sexp))))) ;;;-------------------------------------------------------------------------- @@ -213,7 +229,7 @@ (define-pluggable-parser class-item initfrags (scanner class pset) (funcall make class frag pset scanner))))) (define-pluggable-parser class-item initargs (scanner class pset) - ;; initarg-item ::= `initarg' declspec+ init-declarator-list + ;; initarg-item ::= `initarg' declspec+ list[init-declarator] ;; init-declarator ::= declarator [`=' initializer] (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ("initarg" @@ -229,15 +245,35 @@ (define-pluggable-parser class-item initargs (scanner class pset) (car declarator) pset init scanner)) #\,)) - #\;))))) + (nil (must #\;))))))) + +(defun synthetic-name () + "Return an obviously bogus synthetic not-identifier." + (let ((ix *temporary-index*)) + (incf *temporary-index*) + (make-instance 'temporary-variable :tag (format nil "%%#~A" ix)))) (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) + (when name (make-class-type name)) + (let* ((duff (null name)) + (synthetic-name (or name + (let ((var (synthetic-name))) + (unless pset + (setf pset (make-property-set))) + (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)) (nick (sod-class-nickname class))) @@ -295,10 +331,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) @@ -320,11 +355,10 @@ (defun parse-class-body (scanner pset name supers) (parse-initializer-item (sub-pset must-init-p constructor) ;; initializer-item ::= - ;; [`class'] -!- slot-initializer-list `;' + ;; [`class'] -!- list[slot-initializer] `;' ;; ;; slot-initializer ::= id `.' id [initializer] - (let ((parse-init (if must-init-p - #'parse-initializer + (let ((parse-init (if must-init-p #'parse-initializer (parser () (? (parse-initializer)))))) (parse (and (skip-many () (seq ((name-a :id) #\. (name-b :id) @@ -347,9 +381,8 @@ (defun parse-class-body (scanner pset name supers) ;; 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.") + (cerror* + "Method declarations must have function type") (setf name (cdr name))) (parse-slot-item sub-pset base-type type name)) ((consp name) @@ -379,11 +412,9 @@ (defun parse-class-body (scanner pset name supers) (car dc) (cdr dc)))))) (and "class" - (parse-initializer-item - sub-pset t + (parse-initializer-item sub-pset t #'make-sod-class-initializer)) - (parse-initializer-item - sub-pset nil + (parse-initializer-item sub-pset nil #'make-sod-instance-initializer))))) (parse (seq (#\{ @@ -392,19 +423,22 @@ (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) + (name (must :id)) (nil (or (seq (#\;) - (make-class-type name)) - (seq ((supers (? (seq (#\: (ids (list () :id #\,))) - ids))) + (when name (make-class-type name))) + (seq ((supers (must (seq (#\: + (ids (list () :id #\,))) + ids))) (nil (parse-class-body scanner pset name supers)))))))))))