X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/c91b90c3bfd3d3e68cc3d3ff3f431d1e73920061..9ec578d9fe450b7e7f9030dc9d930185593aa991:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 6fb6be8..df4ea27 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -28,13 +28,11 @@ ;;;-------------------------------------------------------------------------- ;;; Toplevel syntax. -(export 'module) - ;;; Type names. -(define-pluggable-parser module typename (scanner) - ;; `typename' ID ( `,' ID )* `;' - +(define-pluggable-parser module typename (scanner pset) + ;; `typename' id ( `,' id )* `;' + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (and "typename" (skip-many (:min 1) @@ -49,30 +47,37 @@ ;;; Fragments. -(define-pluggable-parser module code (scanner) - ;; `code' ID `:' ID [ CONSTRAINTS ] `{' C-FRAGMENT `}' - +(define-pluggable-parser module code (scanner pset) + ;; `code' id `:' id [constraints] `{' c-fragment `}' + ;; + ;; constrains ::= `[' constraint-list `]' + ;; constraint ::= id+ + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) - (parse (seq ("code" - (reason :id) - #\: - (name :id) - (constraints (? (seq (#\[ - (constraints (list (:min 1) - (list (:min 1) :id) - #\,)) - #\]) - constraints))) - (fragment (parse-delimited-fragment scanner #\{ #\}))) - (add-to-module *module* (make-instance 'code-fragment-item - :fragment fragment - :constraints constraints - :reason reason - :name name)))))) + (flet ((kw () + (parse (seq ((kw :id)) (intern (string-upcase kw) 'keyword))))) + (parse (seq ("code" + (reason (kw)) + #\: + (name (kw)) + (constraints (? (seq (#\[ + (constraints (list (:min 1) + (list (:min 1) (kw)) + #\,)) + #\]) + constraints))) + (fragment (parse-delimited-fragment scanner #\{ #\}))) + (add-to-module *module* + (make-instance 'code-fragment-item + :fragment fragment + :constraints constraints + :reason reason + :name name))))))) ;;; External files. -(defun read-module (pathname &key (truename (truename pathname)) location) +(export 'read-module) +(defun read-module (pathname &key (truename nil truep) location) "Parse the file at PATHNAME as a module, returning it. This is the main entry point for parsing module files. You may well know @@ -83,6 +88,9 @@ `file-location' object, though it might be anything other than `t' which can be printed in the event of circular imports." + (setf pathname (merge-pathnames pathname + (make-pathname :type "SOD" :case :common))) + (unless truep (setf truename (truename pathname))) (define-module (pathname :location location :truename truename) (with-open-file (f-stream pathname :direction :input) (let* ((*readtable* (copy-readtable)) @@ -92,19 +100,23 @@ :char-scanner char-scanner))) (with-default-error-location (scanner) (with-parser-context (token-scanner-context :scanner scanner) - (parse (skip-many () (plug module scanner))))))))) - -(define-pluggable-parser module test (scanner) - ;; `demo' STRING `;' - + (parse (skip-many () + (seq ((pset (parse-property-set scanner)) + (nil (error () + (plug module scanner pset)))) + (check-unused-properties pset)))))))))) + +(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) #\;) (format t ";; DEMO ~S~%" string))))) -(define-pluggable-parser module file (scanner) - ;; `import' STRING `;' - ;; `load' STRING `;' - +(define-pluggable-parser module file (scanner pset) + ;; `import' string `;' + ;; `load' string `;' + (declare (ignore pset)) (flet ((common (name type what thunk) (find-file scanner (merge-pathnames name @@ -138,9 +150,9 @@ ;;; Lisp escape. -(define-pluggable-parser module lisp (scanner) +(define-pluggable-parser module lisp (scanner pset) ;; `lisp' s-expression `;' - + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ((sexp (if (and (eql (token-type scanner) :id) (string= (token-value scanner) "lisp")) @@ -155,11 +167,13 @@ ;;;-------------------------------------------------------------------------- ;;; Class declarations. -(defun parse-class-body (scaner pset name supers) +(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 (mapcat #'find-sod-class supers) + (let* ((class (make-sod-class name (mapcar #'find-sod-class supers) pset scanner)) (nick (sod-class-nickname class))) @@ -174,20 +188,18 @@ ;; names. (parse-declarator scanner base-type - :centre (parser () + :kernel (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 (or #\; (parse-method-item sub-pset + type nick name)))) (parse-method-item (sub-pset type sub-nick name) ;; method-item ::= @@ -205,13 +217,46 @@ ;; ;; 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))))) + + ;; This is kind of tricky because we have to juggle both + ;; layers of the parsing machinery. The character scanner + ;; will already have consumed the lookahead token (which, if + ;; we're going to do anything, is `='). + (let ((char-scanner (token-scanner-char-scanner scanner))) + + ;; First, skip the character-scanner past any whitespace. + ;; We don't record this consumption, which is a bit + ;; naughty, but nobody will actually mind. + (loop + (when (or (scanner-at-eof-p char-scanner) + (not (whitespace-char-p + (scanner-current-char char-scanner)))) + (return)) + (scanner-step char-scanner)) + + ;; Now maybe read an initializer. + (cond ((not (eql (token-type scanner) #\=)) + ;; It's not an `=' after all. There's no + ;; initializer. + (values '(#\=) nil nil)) + + ((and (not (scanner-at-eof-p char-scanner)) + (char= (scanner-current-char char-scanner) + #\{)) + ;; There's a brace after the `=', so we should + ;; consume the `=' here, and read a compound + ;; initializer enclosed in braces. + (parse (seq (#\= (frag (parse-delimited-fragment + scanner #\{ #\}))) + (cons :compound frag)))) + + (t + ;; No brace, so read from the `=' up to, but not + ;; including, the trailing `,' or `;' delimiter. + (parse (seq ((frag (parse-delimited-fragment + scanner #\= '(#\; #\,) + :keep-end t))) + (cons :simple frag))))))) (parse-slot-item (sub-pset base-type type name) ;; slot-item ::= @@ -226,7 +271,7 @@ (when init (make-sod-instance-initializer class nick name (car init) (cdr init) - nil scanner))) + sub-pset scanner))) (skip-many () (seq (#\, (ds (parse-declarator scanner @@ -238,7 +283,7 @@ (make-sod-instance-initializer class nick (cdr ds) (car init) (cdr init) - nil scanner)))) + sub-pset scanner)))) #\;))) (parse-initializer-item (sub-pset constructor) @@ -289,14 +334,14 @@ ;; 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 + (parse (or (plug class-item scanner class sub-pset) + ;(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)) + (nil (class-item-dispatch sub-pset + ds + (car dc) + (cdr dc)))));) (and "class" (parse-initializer-item sub-pset @@ -305,16 +350,18 @@ sub-pset #'make-sod-instance-initializer))))) - (parse (and #\{ - (skip-many () - (seq ((sub-pset (? (parse-property-set))) - (nil (parse-raw-class-item sub-pset))))) - #\})))))) + (parse (seq (#\{ + (nil (skip-many () + (seq ((sub-pset (parse-property-set scanner)) + (nil (parse-raw-class-item sub-pset))) + (check-unused-properties sub-pset)))) + (nil (error () #\}))) + (finalize-sod-class class) + (add-to-module *module* class))))))) -(define-pluggable-parser module class (scanner) +(define-pluggable-parser module class (scanner pset) ;; `class' id [`:' id-list] class-body ;; `class' id `;' - (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ("class" (name :id) @@ -326,14 +373,4 @@ scanner pset name supers))))))))))) - - - - (parse (seq ("class" - (name :id) - (supers (? (seq (#\: (supers (list (:min 1) :id #\,))) - supers))) - #\{ - - ;;;----- That's all, folks --------------------------------------------------