;;;--------------------------------------------------------------------------
;;; 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"<unnamed>")))))
- (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 --------------------------------------------------
;;;--------------------------------------------------------------------------
;;; 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 "<none>")))
- (with-parser-context (token-scanner-context :scanner scanner)
- (define-module ("<temporary>" :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 "<none>")))
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (define-module ("<temporary>" :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 --------------------------------------------------
: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.
(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
(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)
: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)
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)
`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))
:superclasses superclasses
:location (file-location location)
:pset pset)))
- (check-unused-properties pset)
class)))
(export 'guess-metaclass)
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
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
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
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
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
(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.
(format nil "~/sod::show-char/" type)
(case type
(:id (format nil "<identifier~@[ `~A'~]>" value))
+ (:int "<integer-literal>")
(:string "<string-literal>")
(:char "<character-literal>")
(:eof "<end-of-file>")
(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.
--- /dev/null
+;;; -*-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"<unnamed>")))))
+ (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 --------------------------------------------------
;;; 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)
;;; 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)
: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
;;; 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"))
;;;--------------------------------------------------------------------------
;;; 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)))
(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 ::=
(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
(make-sod-instance-initializer
class nick (cdr ds)
(car init) (cdr init)
- nil scanner))))
+ sub-pset scanner))))
#\;)))
(parse-initializer-item (sub-pset constructor)
;; 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
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)
scanner
pset name supers)))))))))))
-
-
-
- (parse (seq ("class"
- (name :id)
- (supers (? (seq (#\: (supers (list (:min 1) :id #\,)))
- supers)))
- #\{
-
-
;;;----- That's all, folks --------------------------------------------------
(: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)
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
(,func (lambda (,new)
(declare (ignorable ,new))
(setf ,accvar ,update))
- (lambda ()
- ,final)
+ (lambda () ,final)
(parser () ,parser)
,@(and sepp (list `(parser () ,sep)))
,@(and minp `(:min ,min))
(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 --------------------------------------------------
(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
(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.
(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))))
;;;--------------------------------------------------------------------------
(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)))
(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."
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))
--- /dev/null
+;;; -*-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 "<none>"))
+ (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 --------------------------------------------------
("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"))
~mdw / sod / commitdiff