X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3dca7758421664a838c54b273bd9221f02072045..450a4be6a6d832ce1e54169d9cc7740f5a04dc89:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 9cad3d4..bccc37b 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -48,21 +48,28 @@ ;;; Fragments. (define-pluggable-parser module code (scanner pset) - ;; `code' id `:' id [constraints] `{' c-fragment `}' + ;; `code' id `:' item-name [constraints] `{' c-fragment `}' ;; ;; constrains ::= `[' constraint-list `]' - ;; constraint ::= id+ + ;; constraint ::= item-name+ + ;; item-name ::= id | `(' id+ `)' (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) - (flet ((kw () - (parse (seq ((kw :id)) (intern (string-upcase kw) 'keyword))))) + (labels ((kw () + (parse (seq ((kw :id)) + (intern (frob-identifier kw) 'keyword)))) + (item () + (parse (or (kw) + (seq (#\( (names (list (:min 1) (kw))) #\)) + names))))) (parse (seq ("code" (reason (kw)) #\: - (name (kw)) + (name (item)) (constraints (? (seq (#\[ (constraints (list (:min 1) - (list (:min 1) (kw)) + (list (:min 1) + (item)) #\,)) #\]) constraints))) @@ -94,17 +101,21 @@ (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 `;' @@ -148,6 +159,29 @@ (cerror* "Error loading Lisp file ~S: ~A" path error))))))))))) +;;; Setting properties. + +(define-pluggable-parser module set (scanner pset) + ;; `set' property-list `;' + (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)) + (setf (p-seenp prop) t)) + pset)) + (parse (skip-many (:min 0) + (error (:ignore-unconsumed t) + (parse-property scanner module-pset) + (skip-until (:keep-end t) #\, #\;)) + #\,)))) + #\;)))) + ;;; Lisp escape. (define-pluggable-parser module lisp (scanner pset) @@ -167,13 +201,49 @@ ;;;-------------------------------------------------------------------------- ;;; Class declarations. +(export 'class-item) + +(define-pluggable-parser class-item initfrags (scanner class pset) + ;; raw-class-item ::= frag-keyword `{' c-fragment `}' + ;; frag-keyword ::= `init' | `teardown' + (with-parser-context (token-scanner-context :scanner scanner) + (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))))) + +(define-pluggable-parser class-item initargs (scanner class pset) + ;; initarg-item ::= `initarg' declspec+ init-declarator-list + ;; 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))) @@ -188,6 +258,7 @@ ;; names. (parse-declarator scanner base-type + :keywordp t :kernel (parser () (seq ((name-a :id) (name-b (? (seq (#\. (id :id)) id)))) @@ -220,50 +291,12 @@ body sub-pset scanner)))) (parse-initializer () - ;; initializer ::= `=' c-fragment | `=' `{' c-fragment `}' + ;; initializer ::= `=' c-fragment ;; - ;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a - ;; `sod-initializer' constructor. - - ;; 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))))))) + ;; Return a VALUE, ready for passing to a `sod-initializer' + ;; constructor. + (parse-delimited-fragment scanner #\= (list #\, #\;) + :keep-end t)) (parse-slot-item (sub-pset base-type type name) ;; slot-item ::= @@ -277,8 +310,7 @@ sub-pset scanner) (when init (make-sod-instance-initializer - class nick name (car init) (cdr init) - sub-pset scanner))) + class nick name init sub-pset scanner))) (skip-many () (seq (#\, (ds (parse-declarator scanner @@ -288,25 +320,26 @@ sub-pset scanner) (when init (make-sod-instance-initializer - class nick (cdr ds) - (car init) (cdr init) + class nick (cdr ds) init sub-pset scanner)))) #\;))) - (parse-initializer-item (sub-pset constructor) + (parse-initializer-item (sub-pset must-init-p 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)) - #\,) - #\;))) + ;; 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 @@ -322,7 +355,7 @@ (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) @@ -337,6 +370,7 @@ ;; | method-item ;; | slot-item ;; | initializer-item + ;; | initfrag-item ;; ;; Most of the above begin with declspecs and a declarator ;; (which might be dotted). So we parse that here and @@ -345,16 +379,17 @@ (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 + sub-pset t #'make-sod-class-initializer)) (parse-initializer-item - sub-pset + sub-pset nil #'make-sod-instance-initializer))))) (parse (seq (#\{ @@ -364,18 +399,19 @@ (check-unused-properties sub-pset)))) (nil (error () #\}))) (finalize-sod-class class) - (add-to-module *module* class))))))) + (unless duff + (add-to-module *module* class)))))))) (define-pluggable-parser module class (scanner pset) - ;; `class' id [`:' id-list] class-body + ;; `class' id `:' id-list 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)))))))))))