From 048d0b2d143b6a491ac73eed6ab972e97774391c Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Wed, 17 Jul 2013 21:03:27 +0100 Subject: [PATCH] Refactoring more or less complete. Maybe I should test it. --- pre-reorg/module-output.lisp | 131 ------------------------------- src/c-types-test.lisp | 81 ++++++++++--------- src/class-make-impl.lisp | 15 ++-- src/class-make-proto.lisp | 25 ++---- src/lexer-impl.lisp | 35 +++++++++ src/lexer-proto.lisp | 31 ++++++++ src/module-output.lisp | 183 +++++++++++++++++++++++++++++++++++++++++++ src/module-parse.lisp | 98 +++++++++++------------ src/module-proto.lisp | 2 +- src/parser/parser-proto.lisp | 7 +- src/pset-parse.lisp | 16 ++-- src/pset-proto.lisp | 57 ++++++++------ src/pset-test.lisp | 106 +++++++++++++++++++++++++ src/sod.asd | 6 +- 14 files changed, 507 insertions(+), 286 deletions(-) create mode 100644 src/module-output.lisp create mode 100644 src/pset-test.lisp diff --git a/pre-reorg/module-output.lisp b/pre-reorg/module-output.lisp index 891ff54..fd690ad 100644 --- a/pre-reorg/module-output.lisp +++ b/pre-reorg/module-output.lisp @@ -28,144 +28,13 @@ ;;;-------------------------------------------------------------------------- ;;; Utilities. -(defun banner (title output &key (blank-line-p t)) - (format output "~&/*----- ~A ~A*/~%" - title - (make-string (- 77 2 5 1 (length title) 1 2) - :initial-element #\-)) - (when blank-line-p - (terpri output))) - -(defun guard-name (filename) - "Return a sensible inclusion guard name for FILENAME." - (with-output-to-string (guard) - (let* ((pathname (make-pathname :name (pathname-name filename) - :type (pathname-type filename))) - (name (namestring pathname)) - (uscore t)) - (dotimes (i (length name)) - (let ((ch (char name i))) - (cond ((alphanumericp ch) - (write-char (char-upcase ch) guard) - (setf uscore nil)) - ((not uscore) - (write-char #\_ guard) - (setf uscore t)))))))) - -;;;-------------------------------------------------------------------------- -;;; Driving output. - -(defun guess-output-file (module type) - (merge-pathnames (make-pathname :type type :case :common) - (module-name module))) - -(defun output-module (module reason stream) - (let ((sequencer (make-instance 'sequencer)) - (stream (if (typep stream 'position-aware-output-stream) - stream - (make-instance 'position-aware-output-stream - :stream stream - :file (or (stream-pathname stream) - #p""))))) - (add-output-hooks module reason sequencer) - (invoke-sequencer-items sequencer stream))) - ;;;-------------------------------------------------------------------------- ;;; Main output protocol implementation. -(defmethod add-output-hooks progn ((module module) reason sequencer) - (dolist (item (module-items module)) - (add-output-hooks item reason sequencer))) - -(defmethod add-output-hooks progn - ((frag code-fragment-item) reason sequencer) - (when (eq reason (code-fragment-reason frag)) - (dolist (constraint (code-fragment-constraints frag)) - (add-sequencer-constraint sequencer constraint)) - (add-sequencer-item-function sequencer (code-fragment-name frag) - (lambda (stream) - (write (code-fragment frag) - :stream stream - :pretty nil - :escape nil))))) - ;;;-------------------------------------------------------------------------- ;;; Header output. -(defmethod add-output-hooks progn - ((module module) (reason (eql :h)) sequencer) - (sequence-output (stream sequencer) - :constraint (:prologue - (:guard :start) - (:typedefs :start) :typedefs (:typedefs :end) - (:includes :start) :includes (:includes :end) - (:classes :start) :classes (:classes :end) - (:guard :end) - :epilogue) - - (:prologue - (format stream "~ -/* -*-c-*- - * - * Header file generated by SOD for ~A - */~2%" - (namestring (module-name module)))) - - ((:guard :start) - (format stream "~ -#ifndef ~A -#define ~:*~A - -#ifdef __cplusplus - extern \"C\" { -#endif~2%" - (or (get-property (module-pset module) :guard :id) - (guard-name (or (stream-pathname stream) - (guess-output-file module "H")))))) - ((:guard :end) - (banner "That's all, folks" stream) - (format stream "~ -#ifdef __cplusplus - } -#endif - -#endif~%")) - - ((:typedefs :start) - (banner "Forward type declarations" stream)) - ((:typedefs :end) - (terpri stream)) - - ((:includes :start) - (banner "External header files" stream)) - ((:includes :end) - (terpri stream)))) - ;;;-------------------------------------------------------------------------- ;;; Source output. -(defmethod add-output-hooks progn - ((module module) (reason (eql :c)) sequencer) - (sequence-output (stream sequencer) - :constraint (:prologue - (:includes :start) :includes (:includes :end) - (:classes :start) (:classes :end) - :epilogue) - - (:prologue - (format stream "~ -/* -*-c-*- - * - * Implementation file generated by SOD for ~A - */~2%" - (namestring (module-name module)))) - - (:epilogue - (banner "That's all, folks" stream :blank-line-p nil)) - - ((:includes :start) - (banner "External header files" stream)) - ((:includes :end) - (terpri stream)))) - ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/c-types-test.lisp b/src/c-types-test.lisp index 16e41ce..0eadfe6 100644 --- a/src/c-types-test.lisp +++ b/src/c-types-test.lisp @@ -249,40 +249,51 @@ int ftw(const char */*dirpath*/, ;;;-------------------------------------------------------------------------- ;;; Parsing. -(def-test-method parse-c-type ((test c-types-test) :run nil) - (flet ((check (string c-type name) - (let* ((char-scanner (make-string-scanner string)) - (scanner (make-instance 'sod-token-scanner - :char-scanner char-scanner - :filename ""))) - (with-parser-context (token-scanner-context :scanner scanner) - (define-module ("" :truename nil :location scanner) - (multiple-value-bind (result winp consumedp) - (parse (seq ((ds (parse-c-type scanner)) - (dc (parse-declarator scanner ds)) - :eof) - dc)) - (declare (ignore consumedp)) - (cond ((null c-type) - (assert-false winp)) - (t - (assert-true winp) - (unless (eq c-type t) - (assert-cteqp (car result) c-type)) - (unless (eq name t) - (assert-equal (cdr result) name)))))))))) - - (check "int x" (c-type int) "x") - (check "int long unsigned long y" (c-type unsigned-long-long) "y") - (check "int long int x" nil nil) - (check "float v[69][42]" (c-type ([] float "69" "42")) "v") - (check "const char *const tab[]" - (c-type ([] (* (char :const) :const) "")) - "tab") - (check "void (*signal(int, void (*)(int)))(int)" - (c-type (func (* (func void (nil int))) - (nil int) - (nil (* (func void (nil int)))))) - "signal"))) +(defun check-c-type-parse (string c-type name) + (let* ((char-scanner (make-string-scanner string)) + (scanner (make-instance 'sod-token-scanner + :char-scanner char-scanner + :filename ""))) + (with-parser-context (token-scanner-context :scanner scanner) + (define-module ("" :truename nil :location scanner) + (multiple-value-bind (result winp consumedp) + (parse (seq ((ds (parse-c-type scanner)) + (dc (parse-declarator scanner ds)) + :eof) + dc)) + (declare (ignore consumedp)) + (cond ((null c-type) + (assert-false winp)) + (t + (assert-true winp) + (unless (eq c-type t) + (assert-cteqp (car result) c-type)) + (unless (eq name t) + (assert-equal (cdr result) name))))))))) + +(def-test-method parse-simple ((test c-types-test) :run nil) + (check-c-type-parse "int x" (c-type int) "x")) + +(def-test-method parse-hairy-declspec ((test c-types-test) :run nil) + (check-c-type-parse "int long unsigned long y" + (c-type unsigned-long-long) "y")) + +(def-test-method parse-bogus-declspec ((test c-types-test) :run nil) + (check-c-type-parse "int long int x" nil nil)) + +(def-test-method parse-array ((test c-types-test) :run nil) + (check-c-type-parse "float v[69][42]" (c-type ([] float "69" "42")) "v")) + +(def-test-method parse-array-of-pointers ((test c-types-test) :run nil) + (check-c-type-parse "const char *const tab[]" + (c-type ([] (* (char :const) :const) "")) + "tab")) + +(def-test-method parse-hairy-function-pointer ((test c-types-test) :run nil) + (check-c-type-parse "void (*signal(int, void (*)(int)))(int)" + (c-type (func (* (func void (nil int))) + (nil int) + (nil (* (func void (nil int)))))) + "signal"))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index 4470416..ae65392 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -87,8 +87,7 @@ :location (file-location location) :pset pset))) (with-slots (slots) class - (setf slots (append slots (list slot)))) - (check-unused-properties pset)))) + (setf slots (append slots (list slot))))))) (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) "This method does nothing. @@ -112,8 +111,7 @@ (file-location location)))) (with-slots (instance-initializers) class (setf instance-initializers - (append instance-initializers (list initializer)))) - (check-unused-properties pset)))) + (append instance-initializers (list initializer))))))) (defmethod make-sod-class-initializer ((class sod-class) nick name value-kind value-form pset @@ -126,8 +124,7 @@ (file-location location)))) (with-slots (class-initializers) class (setf class-initializers - (append class-initializers (list initializer)))) - (check-unused-properties pset)))) + (append class-initializers (list initializer))))))) (defmethod make-sod-initializer-using-slot ((class sod-class) (slot sod-slot) @@ -163,8 +160,7 @@ :location (file-location location) :pset pset))) (with-slots (messages) class - (setf messages (append messages (list message)))) - (check-unused-properties pset)))) + (setf messages (append messages (list message))))))) (defmethod shared-initialize :after ((message sod-message) slot-names &key pset) @@ -189,8 +185,7 @@ type body pset (file-location location)))) (with-slots (methods) class - (setf methods (append methods (list method))))) - (check-unused-properties pset))) + (setf methods (append methods (list method))))))) (defmethod make-sod-method-using-message ((message sod-message) (class sod-class) type body pset location) diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index 0a633de..2b4463a 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -41,9 +41,7 @@ `shared-initialize'. Minimal sanity checking is done during class construction; most of it is - left for `finalize-sod-class' to do (via `check-sod-class'). - - Unused properties in PSET are diagnosed as errors." + left for `finalize-sod-class' to do (via `check-sod-class')." (with-default-error-location (location) (let* ((pset (property-set pset)) @@ -53,7 +51,6 @@ :superclasses superclasses :location (file-location location) :pset pset))) - (check-unused-properties pset) class))) (export 'guess-metaclass) @@ -78,9 +75,7 @@ to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then constructed by `make-instance' passing the arguments as initargs; further behaviour is left to the standard CLOS instance construction protocol; for - example, `sod-slot' defines an `:after'-method on `shared-initialize'. - - Unused properties on PSET are diagnosed as errors.")) + example, `sod-slot' defines an `:after'-method on `shared-initialize'.")) (export 'make-sod-instance-initializer) (defgeneric make-sod-instance-initializer @@ -93,9 +88,7 @@ construction process. The default method looks up the slot using `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to actually make the initializer object, and adds it to the appropriate list - in CLASS. - - Unused properties on PSET are diagnosed as errors.")) + in CLASS.")) (export 'make-sod-class-initializer) (defgeneric make-sod-class-initializer @@ -108,9 +101,7 @@ construction process. The default method looks up the slot using `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to actually make the initializer object, and adds it to the appropriate list - in CLASS. - - Unused properties on PSET are diagnosed as errors.")) + in CLASS.")) (export 'make-sod-initializer-using-slot) (defgeneric make-sod-initializer-using-slot @@ -150,9 +141,7 @@ then constructed by `make-instance' passing the arguments as initargs; further behaviour is left to the standard CLOS instance construction protocol; for example, `sod-message' defines an `:after'-method on - `shared-initialize'. - - Unused properties on PSET are diagnosed as errors.")) + `shared-initialize'.")) (export 'make-sod-method) (defgeneric make-sod-method @@ -168,9 +157,7 @@ invokes `make-sod-method-using-message' to make the method object, and then adds the method to the class's list of methods. This split allows the message class to intervene in the class selection process, for - example. - - Unused properties on PSET are diagnosed as errors.")) + example.")) (export 'make-sod-method-using-message) (defgeneric make-sod-method-using-message diff --git a/src/lexer-impl.lisp b/src/lexer-impl.lisp index f474590..6fc6fcc 100644 --- a/src/lexer-impl.lisp +++ b/src/lexer-impl.lisp @@ -52,6 +52,41 @@ (format stream "`~C'" char)) (t (format stream "<~(~:C~)>" char)))) +(defun skip-until (scanner token-types &key keep-end) + "This is the implementation of the `skip-until' parser." + (do ((consumedp nil t)) + ((member (token-type scanner) token-types) + (unless keep-end (scanner-step scanner)) + (values nil t (or keep-end consumedp))) + (when (scanner-at-eof-p scanner) + (return (values token-types nil consumedp))) + (scanner-step scanner))) + +(defun parse-error-recover (scanner parser recover) + "This is the implementation of the `error' parser." + (multiple-value-bind (result win consumedp) (funcall parser) + (cond ((or win (and (not consumedp) (scanner-at-eof-p scanner))) + ;; If we succeeded then there's nothing for us to do here. On the + ;; other hand, if we failed, didn't consume any tokens, and we're + ;; at end-of-file, then there's not much hope of making onward + ;; progress, so in this case we propagate the failure rather than + ;; trying to recover. And we assume that the continuation will + ;; somehow arrange to report the problem, and avoid inundating the + ;; user with error reports. + (values result win consumedp)) + (t + ;; Now we have to do some kind of sensible error recovery. The + ;; important thing to do here is to make sure that we make some + ;; progress. If we consumed any tokens then we're fine, and we'll + ;; just try the provided recovery strategy. Otherwise, if we're + ;; not at EOF, then we can ensure progress by discarding the + ;; current token. Finally, if we are at EOF then our best bet is + ;; simply to propagate the current failure back to the caller, but + ;; we handled that case above. + (syntax-error scanner result :continuep t) + (unless consumedp (scanner-step scanner)) + (funcall recover))))) + ;;;-------------------------------------------------------------------------- ;;; Token scanning. diff --git a/src/lexer-proto.lisp b/src/lexer-proto.lisp index e72152e..af2e535 100644 --- a/src/lexer-proto.lisp +++ b/src/lexer-proto.lisp @@ -56,6 +56,7 @@ (format nil "~/sod::show-char/" type) (case type (:id (format nil "" value)) + (:int "") (:string "") (:char "") (:eof "") @@ -95,6 +96,36 @@ (scanner-current-char char-scanner)) (and consumedp (file-location char-scanner)))) +(defparse skip-until (:context (context token-scanner-context) + (&key (keep-end nil keep-end-p)) + &rest token-types) + "Discard tokens until we find one listed in TOKEN-TYPES. + + If KEEP-END is true then retain the found token for later; otherwise + discard it. KEEP-END defaults to true if multiple TOKEN-TYPES are given; + otherwise false. If end-of-file is encountered then the indicator list is + simply the list of TOKEN-TYPES; otherwise the result is `nil'." + `(skip-until ,(parser-scanner context) + (list ,@token-types) + :keep-end ,(if keep-end-p keep-end + (> (length token-types) 1)))) + +(defparse error (:context (context token-scanner-context) + (&key) sub &optional (recover t)) + "Try to parse SUB; if it fails then report an error, and parse RECOVER. + + This is the main way to recover from errors and continue parsing. Even + then, it's not especially brilliant. + + If the SUB parser succeeds then just propagate its result: it's like we + were never here. Otherwise, try to recover in a sensible way so we can + continue parsing. The details of this recovery are subject to change, but + the final action is generally to invoke the RECOVER parser and return its + result." + `(parse-error-recover ,(parser-scanner context) + (parser () ,sub) + (parser () ,recover))) + ;;;-------------------------------------------------------------------------- ;;; Lexical analysis utilities. diff --git a/src/module-output.lisp b/src/module-output.lisp new file mode 100644 index 0000000..b093b82 --- /dev/null +++ b/src/module-output.lisp @@ -0,0 +1,183 @@ +;;; -*-lisp-*- +;;; +;;; Output for modules +;;; +;;; (c) 2013 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; SOD is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with SOD; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(cl:in-package #:sod) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(export 'banner) +(defun banner (title output &key (blank-line-p t)) + "Write a banner to the OUTPUT stream, starting a new section called TITLE. + + If BLANK-LINE-P is false, then leave a blank line after the banner. (This + is useful for a final banner at the end of a file.)" + (format output "~&/*----- ~A ~A*/~%" + title + (make-string (- 77 2 5 1 (length title) 1 2) + :initial-element #\-)) + (when blank-line-p + (terpri output))) + +(export 'guard-name) +(defun guard-name (filename) + "Return a sensible inclusion guard name for FILENAME." + (with-output-to-string (guard) + (let* ((pathname (make-pathname :name (pathname-name filename) + :type (pathname-type filename))) + (name (namestring pathname)) + (uscore t)) + (dotimes (i (length name)) + (let ((ch (char name i))) + (cond ((alphanumericp ch) + (write-char (char-upcase ch) guard) + (setf uscore nil)) + ((not uscore) + (write-char #\_ guard) + (setf uscore t)))))))) + +(defun guess-output-file (module type) + "Guess the filename to use for a file TYPE, generated from MODULE. + + Here, TYPE is a filetype string. The result is returned as a pathname." + (merge-pathnames (make-pathname :type type :case :common) + (module-name module))) + +;;;-------------------------------------------------------------------------- +;;; Main output interface. + +(export 'output-module) +(defun output-module (module reason stream) + "Write the MODULE to STREAM, giving the output machinery the REASON. + + This is the top-level interface for producing output." + (let ((sequencer (make-instance 'sequencer)) + (stream (if (typep stream 'position-aware-output-stream) + stream + (make-instance 'position-aware-output-stream + :stream stream + :file (or (stream-pathname stream) + #p""))))) + (hook-output module reason sequencer) + (invoke-sequencer-items sequencer stream))) + +;;;-------------------------------------------------------------------------- +;;; Output implementation. + +(defmethod hook-output progn ((module module) reason sequencer) + + ;; Ask the module's items to sequence themselves. + (dolist (item (module-items module)) + (hook-output item reason sequencer))) + +(defmethod hook-output progn ((frag code-fragment-item) reason sequencer) + + ;; Output fragments when their reasons are called up. + (when (eq reason (code-fragment-reason frag)) + (dolist (constraint (code-fragment-constraints frag)) + (add-sequencer-constraint sequencer constraint)) + (add-sequencer-item-function sequencer (code-fragment-name frag) + (lambda (stream) + (write (code-fragment frag) + :stream stream + :pretty nil + :escape nil))))) + +(defmethod hook-output progn ((module module) (reason (eql :h)) sequencer) + (sequence-output (stream sequencer) + + :constraint + (:prologue + (:guard :start) + (:typedefs :start) :typedefs (:typedefs :end) + (:includes :start) :includes (:includes :end) + (:classes :start) :classes (:classes :end) + (:guard :end) + :epilogue) + + (:prologue + (format stream "~ +/* -*-c-*- + * + * Header file generated by SOD for ~A + */~2%" + (namestring (module-name module)))) + + ((:guard :start) + (format stream "~ +#ifndef ~A +#define ~:*~A + +#ifdef __cplusplus + extern \"C\" { +#endif~2%" + (or (get-property (module-pset module) :guard :id) + (guard-name (or (stream-pathname stream) + (guess-output-file module "H")))))) + ((:guard :end) + (banner "That's all, folks" stream) + (format stream "~ +#ifdef __cplusplus + } +#endif + +#endif~%")) + + ((:typedefs :start) + (banner "Forward type declarations" stream)) + ((:typedefs :end) + (terpri stream)) + + ((:includes :start) + (banner "External header files" stream)) + ((:includes :end) + (terpri stream)))) + +(defmethod hook-output progn ((module module) (reason (eql :c)) sequencer) + (sequence-output (stream sequencer) + + :constraint + (:prologue + (:includes :start) :includes (:includes :end) + (:classes :start) (:classes :end) + :epilogue) + + (:prologue + (format stream "~ +/* -*-c-*- + * + * Implementation file generated by SOD for ~A + */~2%" + (namestring (module-name module)))) + + (:epilogue + (banner "That's all, folks" stream :blank-line-p nil)) + + ((:includes :start) + (banner "External header files" stream)) + ((:includes :end) + (terpri stream)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 6fb6be8..5d26760 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -32,9 +32,9 @@ ;;; 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,9 +49,12 @@ ;;; 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) @@ -92,19 +95,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 +145,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 +162,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))) @@ -180,14 +189,12 @@ (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 ::= @@ -226,7 +233,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 +245,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 +296,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 +312,19 @@ sub-pset #'make-sod-instance-initializer))))) - (parse (and #\{ - (skip-many () - (seq ((sub-pset (? (parse-property-set))) - (nil (parse-raw-class-item sub-pset))))) - #\})))))) - -(define-pluggable-parser module class (scanner) + (parse (seq (#\{ + (nil (skip-many () + (seq ((sub-pset (parse-property-set scanner)) + (nil (error () + (parse-raw-class-item sub-pset)))) + (check-unused-properties sub-pset)))) + #\}) + (finalize-sod-class class) + (add-to-module *module* class))))))) + +(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 +336,4 @@ scanner pset name supers))))))))))) - - - - (parse (seq ("class" - (name :id) - (supers (? (seq (#\: (supers (list (:min 1) :id #\,))) - supers))) - #\{ - - ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/module-proto.lisp b/src/module-proto.lisp index 93b4f68..28af7bd 100644 --- a/src/module-proto.lisp +++ b/src/module-proto.lisp @@ -125,7 +125,7 @@ (:documentation "Add ITEM to the MODULE's list of accumulated items. - The module items participate in the `module-import' and `add-output-hooks' + The module items participate in the `module-import' and `hook-output' protocols.")) (export 'finalize-module) diff --git a/src/parser/parser-proto.lisp b/src/parser/parser-proto.lisp index f60e425..4242dfe 100644 --- a/src/parser/parser-proto.lisp +++ b/src/parser/parser-proto.lisp @@ -124,10 +124,6 @@ body FORMs. The BVL is a destructuring lambda-list to be applied to the tail of the form. The body forms are enclosed in a block called NAME. - Within the FORMs, a function `expand' is available: it takes a parser - specifier as its argument and returns its expansion in the parser's - context. - If the :context key is provided, then the parser form is specialized on a particular class of parser contexts SPEC; specialized expanders take priority over less specialized or unspecialized expanders -- so you can @@ -457,8 +453,7 @@ (,func (lambda (,new) (declare (ignorable ,new)) (setf ,accvar ,update)) - (lambda () - ,final) + (lambda () ,final) (parser () ,parser) ,@(and sepp (list `(parser () ,sep))) ,@(and minp `(:min ,min)) diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp index 0bc4680..ff59551 100644 --- a/src/pset-parse.lisp +++ b/src/pset-parse.lisp @@ -130,13 +130,15 @@ (export 'parse-property-set) (defun parse-property-set (scanner) "Parse an optional property set from the SCANNER and return it." - ;; property-set ::= `[' property-list `]' + ;; property-set ::= [`[' property-list `]'] (with-parser-context (token-scanner-context :scanner scanner) - (parse (seq (#\[ - (pset (many (pset (make-property-set) pset) - (parse-property scanner pset) - #\,)) - #\]) - pset)))) + (parse (? (seq (#\[ + (pset (many (pset (make-property-set) pset) + (error () + (parse-property scanner pset) + (skip-until () #\, #\])) + #\,)) + #\]) + pset))))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index aafa306..91668ed 100644 --- a/src/pset-proto.lisp +++ b/src/pset-proto.lisp @@ -38,27 +38,14 @@ (symbol name) (string (intern (frob-identifier name) :keyword)))) -(export 'property-type) -(defgeneric property-type (value) - (:documentation "Guess a sensible property type to use for VALUE.") - (:method ((value symbol)) :symbol) - (:method ((value integer)) :int) - (:method ((value string)) :string) - (:method ((value character)) :char) - (:method (value) :other)) - -(export '(property propertyp make-property - p-name p-value p-type p-key p-seenp)) +(export '(property propertyp p-name p-value p-type p-key p-seenp)) (defstruct (property (:predicate propertyp) (:conc-name p-) - (:constructor make-property - (name value - &key (type (property-type value)) - ((:location %loc)) - seenp - &aux (key (property-key name)) - (location (file-location %loc))))) + (:constructor %make-property + (name value + &key type location seenp + &aux (key (property-key name))))) "A simple structure for holding a property in a property set. The main useful feature is the ability to tick off properties which have @@ -75,6 +62,27 @@ (key nil :type symbol) (seenp nil :type boolean)) +(export 'decode-property) +(defgeneric decode-property (raw) + (:documentation "Decode a RAW value into a TYPE, VALUE pair.") + (:method ((raw symbol)) (values :symbol raw)) + (:method ((raw integer)) (values :int raw)) + (:method ((raw string)) (values :string raw)) + (:method ((raw character)) (values :char raw)) + (:method ((raw property)) (values (p-type raw) (p-value raw))) + (:method ((raw cons)) (values (car raw) (cdr raw)))) + +(export 'make-property) +(defun make-property (name raw-value &key type location seenp) + (multiple-value-bind (type value) + (if type + (values type raw-value) + (decode-property raw-value)) + (%make-property name value + :type type + :location (file-location location) + :seenp seenp))) + (defun string-to-symbol (string &key (package *package*) (swap-case t) (swap-hyphen t)) "Convert STRING to a symbol in PACKAGE. @@ -186,9 +194,9 @@ (with-gensyms (next win key value) `(with-hash-table-iterator (,next (%pset-hash ,pset)) (macrolet ((,name () - (multiple-value-bind (,win ,key ,value) (,next) - (declare (ignore ,key)) - (and ,win ,value)))) + `(multiple-value-bind (,',win ,',key ,',value) (,',next) + (declare (ignore ,',key)) + (and ,',win ,',value)))) ,@body)))) ;;;-------------------------------------------------------------------------- @@ -196,7 +204,7 @@ (export 'store-property) (defun store-property - (pset name value &key (type (property-type value)) location) + (pset name value &key type location) "Store a property in PSET." (pset-store pset (make-property name value :type type :location location))) @@ -233,8 +241,7 @@ (p-location prop))))))) (export 'add-property) -(defun add-property - (pset name value &key (type (property-type value)) location) +(defun add-property (pset name value &key type location) "Add a property to PSET. If a property with the same NAME already exists, report an error." @@ -257,7 +264,7 @@ An attempt is made to guess property types from the Lisp types of the values. This isn't always successful but it's not too bad. The alternative is manufacturing a `property-value' object by hand and - stuffing into the set." + stuffing it into the set." (property-set plist)) diff --git a/src/pset-test.lisp b/src/pset-test.lisp new file mode 100644 index 0000000..e10f7ab --- /dev/null +++ b/src/pset-test.lisp @@ -0,0 +1,106 @@ +;;; -*-lisp-*- +;;; +;;; Test the property set implementation +;;; +;;; (c) 2013 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; the Free Software Foundation; either version 2 of the License, or +;;; (at your option) any later version. +;;; +;;; SOD is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with SOD; if not, write to the Free Software Foundation, +;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +(cl:in-package #:sod-test) + +;;;-------------------------------------------------------------------------- +;;; Here we go. + +(defclass pset-test (test-case) ()) +(add-test *sod-test-suite* (get-suite pset-test)) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defun pset-equal-p (pset-a pset-b) + (do ((i 0 (1+ i)) + (p (or pset-a (make-property-set)) q) + (q (or pset-b (make-property-set)) p)) + ((>= i 2) t) + (with-pset-iterator (next p) + (loop (let ((prop (next))) + (when (null prop) (return)) + (let ((other (pset-get q (p-key prop)))) + (unless (and other + (equal (p-name prop) (p-name other)) + (eq (p-type prop) (p-type other)) + (equal (p-value prop) (p-value other))) + (return-from pset-equal-p nil)))))))) + +(defun assert-pset-equal (pset-a pset-b) + (unless (pset-equal-p pset-a pset-b) + (failure "Assert equal property sets: ~A ~_and ~A" pset-a pset-b))) + +;;;-------------------------------------------------------------------------- +;;; Parser tests. + +(defun check-pset-parse (string pset) + (let* ((char-scanner (make-string-scanner string)) + (scanner (make-instance 'sod-token-scanner + :char-scanner char-scanner + :filename "")) + (errors nil)) + (with-parser-context (token-scanner-context :scanner scanner) + (multiple-value-bind (result winp consumedp) + (handler-bind ((error (lambda (cond) + (declare (ignore cond)) + (setf errors t) + (if (find-restart 'continue) + (invoke-restart 'continue) + :decline)))) + (parse-property-set scanner)) + (declare (ignore consumedp)) + (when errors (setf winp nil)) + (cond ((null pset) + (assert-false winp)) + (t + (assert-true winp) + (unless (eq pset t) + (assert-pset-equal result pset)))))))) + +(def-test-method parse-empty ((test pset-test) :run nil) + (check-pset-parse "anything" (make-property-set))) + +(def-test-method parse-simple ((test pset-test) :run nil) + (check-pset-parse "[ thing = 69 ]" + (make-property-set "thing" 69))) + +(def-test-method parse-wrong ((test pset-test) :run nil) + (check-pset-parse "[ broken = (1 + ]" nil)) + +(def-test-method parse-arith ((test pset-test) :run nil) + (check-pset-parse (concatenate 'string "[ " + "one = 13*5 - 16*4, " + "two = \"spong\", " + "three = 'c', " + "four = something_different" + "]") + (make-property-set "one" 1 + "two" "spong" + "three" #\c + "four" (cons :id + "something_different")))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/sod.asd b/src/sod.asd index 33b54c6..0b7f6a7 100644 --- a/src/sod.asd +++ b/src/sod.asd @@ -124,9 +124,9 @@ ("module-proto" "pset-proto" "c-types-class-impl" "builtin")) (:file "builtin" :depends-on ("module-proto" "pset-proto" "classes" "c-types-impl" "c-types-class-impl")) - #+no - (:file "module-parse" :depends-on ("module-impl" - "lexer-proto" "fragment-parse")) + (:file "module-parse" :depends-on + ("module-impl" "lexer-proto" "fragment-parse")) + (:file "module-output" :depends-on ("module-impl" "output-proto")) ;; Output. (:file "output-proto" :depends-on ("package")) -- 2.11.0