The code is a complete disaster area right now.
(setq skel-alist
(append
'((author . "Straylight/Edgeware")
- (full-title . "the Simple Object Definition system")
+ (full-title . "the Sensble Object Design, an object system for C")
(program . "SOD")
(licence-text . skelrc-gpl))
skel-alist))
+++ /dev/null
-* Stuff from the ABI spec
-
-** Notation
-
- * sizeof(O) :: size of an object O
- * align(O) :: alignment of the object O
- * offset(C) :: offset of the component C within O
- * dsize(O) :: data size of the object O (without tail padding)
- * nvsize(O) :: the /non-virtual/ size of the object O (i.e.,
- without virtual bases)
- * nvalign(O) :: the non-virtual alignment of the object O
-
-** Other concepts
-
- * POD for the purpose of layout ::
-
-
-* Order of stuff in output files
-
-** Header
-
- * Multiple inclusion and C++ guards
- * Forward declarations of structs and typedef names.
- * User code
- * Structure definitions
- * Macros
- * Function declarations for methods
-
-** Implementation
-
- * User code
- * Method and table definitions
-
-* COMMENT
-
-# Local variables:
-# mode: org
-# End:
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Builtin module provides basic definitions
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Output of class instances.
-
-(defun output-imprint-function (class stream)
- (let ((ilayout (sod-class-ilayout class)))
- (format stream "~&~:
-/* Imprint raw memory with instance structure. */
-static void *~A__imprint(void *p)
-{
- struct ~A *sod__obj = p;
-
- ~:{sod__obj.~A.~A._vt = &~A;~:^~% ~}
- return (p);
-}~2%"
- class
- (ilayout-struct-tag class)
- (mapcar (lambda (ichain)
- (let* ((head (ichain-head ichain))
- (tail (ichain-tail ichain)))
- (list (sod-class-nickname head)
- (sod-class-nickname tail)
- (vtable-name class head))))
- (ilayout-ichains ilayout)))))
-
-(defun output-init-function (class stream)
- ;; FIXME this needs a metaobject protocol
- (let ((ilayout (sod-class-ilayout class)))
- (format stream "~&~:
-static void *~A__init(void *p)
-{
- struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
- class
- (ilayout-struct-tag class))
- (dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj.~A.~A"
- (sod-class-nickname (ichain-head ichain))
- (sod-class-nickname (ichain-tail ichain)))))
- (dolist (item (ichain-body ichain))
- (etypecase item
- (vtable-pointer
- nil)
- (islots
- (let ((isl (format nil "~A.~A"
- ich
- (sod-class-nickname (islots-class item)))))
- (dolist (slot (islots-slots item))
- (let ((dslot (effective-slot-direct-slot slot))
- (init (effective-slot-initializer slot)))
- (when init
- (format stream " ~A =" isl)
- (ecase (sod-initializer-value-kind init)
- (:simple (write (sod-initializer-value-form init)
- :stream stream
- :pretty nil :escape nil)
- (format stream ";~%"))
- (:compound (format stream " (~A) {"
- (sod-slot-type dslot))
- (write (sod-initializer-value-form init)
- :stream stream
- :pretty nil :escape nil)
- (format stream "};~%"))))))))))))
- (format stream "~&~:
- return (p);
-}~2%")))
-
-(defun output-supers-vector (class stream)
- (let ((supers (sod-class-direct-superclasses class)))
- (when supers
- (format stream "~&~:
-/* Direct superclasses. */
-static const SodClass *const ~A__supers[] = {
- ~{~A__class~^,~% ~}
-};~2%"
- class supers))))
-
-(defun output-cpl-vector (class stream)
- (format stream "~&~:
-/* Class precedence list. */
-static const SodClass *const ~A__cpl[] = {
- ~{~A__class~^,~% ~}
-};~2%"
- class (sod-class-precedence-list class)))
-
-(defun output-chains-vector (class stream)
- (let ((chains (sod-class-chains class)))
- (format stream "~&~:
-/* Chain structure. */
-~1@*~:{static const SodClass *const ~A__chain_~A[] = {
- ~{~A__class~^,~% ~}
-};~:^~2%~}
-
-~0@*static const struct sod_chain ~A__chains[] = {
-~:{ { ~3@*~A,
- ~0@*&~A__chain_~A,
- ~4@*offsetof(struct ~A, ~A),
- (const struct sod_vtable *)&~A,
- sizeof(struct ~A) }~:^,~%~}
-};~2%"
- class ;0
- (mapcar (lambda (chain) ;1
- (let* ((head (sod-class-chain-head (car chain)))
- (chain-nick (sod-class-nickname head)))
- (list class chain-nick ;0 1
- (reverse chain) ;2
- (length chain) ;3
- (ilayout-struct-tag class) chain-nick ;4 5
- (vtable-name class head) ;6
- (ichain-struct-tag class head)))) ;7
- chains))))
-
-(defclass sod-class-slot (sod-slot)
- ((initializer-function :initarg :initializer-function
- :type (or symbol function)
- :reader sod-slot-initializer-function)
- (prepare-function :initarg :prepare-function :type (or symbol function)
- :reader sod-slot-prepare-function))
- (:documentation
- "Special class for slots defined on SodClass.
-
- These slots need class-specific initialization. It's easier to keep all
- of the information (name, type, and how to initialize them) about these
- slots in one place, so that's what we do here."))
-
-(defclass sod-magic-class-initializer (sod-class-initializer)
- ((initializer-function :initarg :initializer-function
- :type (or symbol function)
- :reader sod-initializer-function)
- (prepare-function :initarg :prepare-function
- :type (or symbol function)
- :reader sod-initializer-prepare-function)))
-
-(defmethod shared-initialize :after
- ((slot sod-class-slot) slot-names &key pset)
- (declare (ignore slot-names))
- (default-slot (slot 'initializer-function)
- (get-property pset :initializer-function t nil))
- (default-slot (slot 'prepare-function)
- (get-property pset :prepare-function t nil)))
-
-(defclass sod-class-effective-slot (effective-slot)
- ((initializer-function :initarg :initializer-function
- :type (or symbol function)
- :reader effective-slot-initializer-function)
- (prepare-function :initarg :prepare-function :type (or symbol function)
- :reader effective-slot-prepare-function))
- (:documentation
- "Special class for slots defined on SodClass.
-
- This class ignores any explicit initializers and computes initializer
- values using the slot's INIT-FUNC slot and a magical protocol during
- metaclass instance construction."))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
- (make-instance 'sod-class-effective-slot
- :class class :slot slot
- :initializer-function (sod-slot-initializer-function slot)
- :prepare-function (sod-slot-prepare-function slot)
- :initializer (find-slot-initializer class slot)))
-
-;;;--------------------------------------------------------------------------
-;;; Class slots table.
-
-(defparameter *sod-class-slots*
- `(
-
- ;; Basic informtion.
- ("name" ,(c-type const-string)
- :initializer-function
- ,(lambda (class)
- (prin1-to-string (sod-class-name class))))
- ("nick" ,(c-type const-string)
- :initializer-function
- ,(lambda (class)
- (prin1-to-string (sod-class-nickname class))))
-
- ;; Instance allocation and initialization.
- ("instsz" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "sizeof(struct ~A)"
- (ilayout-struct-tag class))))
- ("imprint" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
- :prepare-function output-imprint-function
- :initializer-function
- ,(lambda (class)
- (format nil "~A__imprint" class)))
- ("init" ,(c-type (* (fun (* void) ("/*p*/" (* void)))))
- :prepare-function output-init-function
- :initializer-function
- ,(lambda (class)
- (format nil "~A__init" class)))
-
- ;; Superclass structure.
- ("n_supers" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-direct-superclasses class))))
- ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function output-supers-vector
- :initializer-function
- ,(lambda (class)
- (if (sod-class-direct-superclasses class)
- (format nil "~A__supers" class)
- 0)))
- ("n_cpl" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-precedence-list class))))
- ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function output-cpl-vector
- :initializer-function
- ,(lambda (class)
- (format nil "~A__cpl" class)))
-
- ;; Chain structure.
- ("link" ,(c-type (* (class "SodClass" :const)))
- :initializer-function
- ,(lambda (class)
- (let ((link (sod-class-chain-link class)))
- (if link
- (format nil "~A__class" link)
- 0))))
- ("head" ,(c-type (* (class "SodClass" :const)))
- :initializer-function
- ,(lambda (class)
- (format nil "~A__class" (sod-class-chain-head class))))
- ("level" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (position class (reverse (sod-class-chain class)))))
- ("n_chains" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-chains class))))
- ("chains" ,(c-type (* (struct "sod_chain" :const)))
- :prepare-function output-chains-vector
- :initializer-function
- ,(lambda (class)
- (format nil "~A__chains" class)))
-
- ;; Class-specific layout.
- ("off_islots" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "offsetof(struct ~A, ~A)"
- (ichain-struct-tag class
- (sod-class-chain-head class))
- (sod-class-nickname class))))
- ("islotsz" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "sizeof(struct ~A)"
- (islots-struct-tag class))))))
-
-;;;--------------------------------------------------------------------------
-;;; Bootstrapping the class graph.
-
-(defun bootstrap-classes (module)
- (let* ((sod-object (make-sod-class "SodObject" nil
- (make-property-set :nick 'obj)))
- (sod-class (make-sod-class "SodClass" (list sod-object)
- (make-property-set :nick 'cls)))
- (classes (list sod-object sod-class)))
-
- ;; Sort out the recursion.
- (setf (slot-value sod-class 'chain-link) sod-object)
- (dolist (class classes)
- (setf (slot-value class 'metaclass) sod-class))
-
- ;; Predeclare the class types.
- (dolist (class classes)
- (make-class-type (sod-class-name class)))
-
- ;; Attach the class slots.
- (loop for (name type . plist) in *sod-class-slots*
- do (make-sod-slot sod-class name type
- (apply #'make-property-set
- :lisp-class 'sod-class-slot
- plist)))
-
- ;; These classes are too closely intertwined. We must partially finalize
- ;; them together by hand. This is cloned from FINALIZE-SOD-CLASS.
- (dolist (class classes)
- (with-slots (class-precedence-list chain-head chain chains) class
- (setf class-precedence-list (compute-cpl class))
- (setf (values chain-head chain chains) (compute-chains class))))
-
- ;; Done.
- (dolist (class classes)
- (finalize-sod-class class)
- (add-to-module module class))))
-
-(defun make-builtin-module ()
- (let ((module (make-instance 'module
- :name (make-pathname :name "SOD-BASE"
- :type "SOD"
- :case :common)
- :state nil))
- (*type-map* (make-hash-table :test #'equal)))
- (dolist (name '("va_list" "size_t" "ptrdiff_t"))
- (add-to-module module (make-instance 'type-item :name name)))
- (bootstrap-classes module)
- module))
-
-(defun reset-builtin-module ()
- (setf *builtin-module* (make-builtin-module))
- (module-import *builtin-module*))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(define-sod-class "AbstractStack" ("SodObject")
- :nick 'abstk
- (message "emptyp" (fun int))
- (message "push" (fun void ("item" (* void))))
- (message "pop" (fun (* void)))
- (method "abstk" "pop" (fun void) #{
- assert(!me->_vt.emptyp());
- }
- :role :before))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Equipment for building classes and friends
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Finding things by name
-
-(defun find-superclass-by-nick (class nick)
- "Returns the superclass of CLASS with nickname NICK, or signals an error."
-
- ;; Slightly tricky. The class almost certainly hasn't been finalized, so
- ;; trundle through its superclasses and hope for the best.
- (if (string= nick (sod-class-nickname class))
- class
- (or (some (lambda (super)
- (find nick (sod-class-precedence-list super)
- :key #'sod-class-nickname
- :test #'string=))
- (sod-class-direct-superclasses class))
- (error "No superclass of `~A' with nickname `~A'" class nick))))
-
-(flet ((find-item-by-name (what class list name key)
- (or (find name list :key key :test #'string=)
- (error "No ~A in class `~A' with name `~A'" what class name))))
-
- (defun find-instance-slot-by-name (class super-nick slot-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-class-slot-by-name (class super-nick slot-name)
- (let* ((meta (sod-class-metaclass class))
- (super (find-superclass-by-nick meta super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-message-by-name (class super-nick message-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "message" super (sod-class-messages super)
- message-name #'sod-message-name))))
-
-;;;--------------------------------------------------------------------------
-;;; Class construction.
-
-(defun make-sod-class (name superclasses pset &optional location)
- "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
-
- This is the main constructor function for classes. The protocol works as
- follows. The :LISP-CLASS property in PSET is checked: if it exists, it
- must be a symbol naming a (CLOS) class, which is used in place of
- SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further
- behaviour is left to the standard CLOS instance construction protocol; for
- example, SOD-CLASS defines an :AFTER-method on 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."
-
- (with-default-error-location (location)
- (let ((class (make-instance (get-property pset :lisp-class :symbol
- 'sod-class)
- :name name
- :superclasses superclasses
- :location (file-location location)
- :pset pset)))
- (check-unused-properties pset)
- class)))
-
-(defgeneric guess-metaclass (class)
- (:documentation
- "Determine a suitable metaclass for the CLASS.
-
- The default behaviour is to choose the most specific metaclass of any of
- the direct superclasses of CLASS, or to signal an error if that failed."))
-
-(defmethod guess-metaclass ((class sod-class))
- "Default metaclass-guessing function for classes.
-
- Return the most specific metaclass of any of the CLASS's direct
- superclasses."
- (do ((supers (sod-class-direct-superclasses class) (cdr supers))
- (meta nil (let ((candidate (sod-class-metaclass (car supers))))
- (cond ((null meta) candidate)
- ((sod-subclass-p meta candidate) meta)
- ((sod-subclass-p candidate meta) candidate)
- (t (error "Unable to choose metaclass for `~A'"
- class))))))
- ((endp supers) meta)))
-
-(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
- "Specific behaviour for SOD class initialization.
-
- Properties inspected are as follows:
-
- * :METACLASS names the metaclass to use. If unspecified, NIL is stored,
- and (unless you intervene later) GUESS-METACLASS will be called by
- FINALIZE-SOD-CLASS to find a suitable default.
-
- * :NICK provides a nickname for the class. If unspecified, a default
- (the class's name, forced to lowercase) will be chosen in
- FINALIZE-SOD-CLASS.
-
- * :LINK names the chained superclass. If unspecified, this class will
- be left at the head of its chain."
-
- ;; If no nickname, copy the class name. It won't be pretty, though.
- (default-slot (class 'nickname)
- (get-property pset :nick :id (string-downcase (slot-value class 'name))))
-
- ;; If no metaclass, guess one in a (Lisp) class-specific way.
- (default-slot (class 'metaclass)
- (multiple-value-bind (name floc) (get-property pset :metaclass :id)
- (if floc
- (find-sod-class name floc)
- (guess-metaclass class))))
-
- ;; If no chain-link, then start a new chain here.
- (default-slot (class 'chain-link)
- (multiple-value-bind (name floc) (get-property pset :link :id)
- (if floc
- (find-sod-class name floc)
- nil))))
-
-;;;--------------------------------------------------------------------------
-;;; Slot construction.
-
-(defgeneric make-sod-slot (class name type pset &optional location)
- (:documentation
- "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
-
- This is the main constructor function for slots. This is a generic
- function primarily so that the CLASS can intervene in the construction
- process. The default method uses the :LISP-CLASS property (defaulting 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."))
-
-(defmethod make-sod-slot
- ((class sod-class) name type pset &optional location)
- (with-default-error-location (location)
- (let ((slot (make-instance (get-property pset :lisp-class :symbol
- 'sod-slot)
- :class class
- :name name
- :type type
- :location (file-location location)
- :pset pset)))
- (with-slots (slots) class
- (setf slots (append slots (list slot))))
- (check-unused-properties pset))))
-
-(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
- "This method exists so that it isn't an error to provide a :PSET initarg
- to (make-instance 'sod-slot ...). It does nothing."
- (declare (ignore slot-names pset))
- nil)
-
-;;;--------------------------------------------------------------------------
-;;; Slot initializer construction.
-
-(defgeneric make-sod-instance-initializer
- (class nick name value-kind value-form pset &optional location)
- (:documentation
- "Construct and attach an instance slot initializer, to CLASS.
-
- This is the main constructor function for instance initializers. This is
- a generic function primarily so that the CLASS can intervene in the
- 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."))
-
-(defgeneric make-sod-class-initializer
- (class nick name value-kind value-form pset &optional location)
- (:documentation
- "Construct and attach a class slot initializer, to CLASS.
-
- This is the main constructor function for class initializers. This is a
- generic function primarily so that the CLASS can intervene in the
- 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."))
-
-(defgeneric make-sod-initializer-using-slot
- (class slot init-class value-kind value-form pset location)
- (:documentation
- "Common construction protocol for slot initializers.
-
- This generic function does the common work for constructing instance and
- class initializers. It can usefully be specialized according to both the
- class and slot types. The default method uses the :LISP-CLASS property
- (defaulting to INIT-CLASS) 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-INITIALIZER defines
- an :AFTER-method on SHARED-INITIALIZE.
-
- Diagnosing unused properties is left for the caller (usually
- MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do. The
- caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if
- appropriate.
-
- You are not expected to call this generic function directly; it's more
- useful as a place to hang methods for custom initializer classes."))
-
-(defmethod make-sod-instance-initializer
- ((class sod-class) nick name value-kind value-form pset
- &optional location)
- (with-default-error-location (location)
- (let* ((slot (find-instance-slot-by-name class nick name))
- (initializer (make-sod-initializer-using-slot
- class slot 'sod-instance-initializer
- value-kind value-form pset
- (file-location location))))
- (with-slots (instance-initializers) class
- (setf instance-initializers (append instance-initializers
- (list initializer))))
- (check-unused-properties pset))))
-
-(defmethod make-sod-class-initializer
- ((class sod-class) nick name value-kind value-form pset
- &optional location)
- (with-default-error-location (location)
- (let* ((slot (find-class-slot-by-name class nick name))
- (initializer (make-sod-initializer-using-slot
- class slot 'sod-class-initializer
- 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))))
-
-(defmethod make-sod-initializer-using-slot
- ((class sod-class) (slot sod-slot)
- init-class value-kind value-form pset location)
- (make-instance (get-property pset :lisp-class :symbol init-class)
- :class class
- :slot slot
- :value-kind value-kind
- :value-form value-form
- :location location
- :pset pset))
-
-(defmethod shared-initialize :after
- ((init sod-initializer) slot-names &key pset)
- "This method exists so that it isn't an error to provide a :PSET initarg
- to (make-instance 'sod-initializer ...). It does nothing."
- (declare (ignore slot-names pset))
- nil)
-
-;;;--------------------------------------------------------------------------
-;;; Message construction.
-
-(defgeneric make-sod-message (class name type pset &optional location)
- (:documentation
- "Construct and attach a new message with given NAME and TYPE, to CLASS.
-
- This is the main constructor function for messages. This is a generic
- function primarily so that the CLASS can intervene in the construction
- process. The default method uses the :LISP-CLASS property (defaulting to
- SOD-MESSAGE) to choose a (CLOS) class to instantiate. The message 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-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE.
-
- Unused properties on PSET are diagnosed as errors."))
-
-(defgeneric check-message-type (message type)
- (:documentation
- "Check that TYPE is a suitable type for MESSAGE. Signal errors if not.
-
- This is separated out of SHARED-INITIALIZE, where it's called, so that it
- can be overridden conveniently by subclasses."))
-
-(defmethod make-sod-message
- ((class sod-class) name type pset &optional location)
- (with-default-error-location (location)
- (let ((message (make-instance (get-property pset :lisp-class :symbol
- 'standard-message)
- :class class
- :name name
- :type type
- :location (file-location location)
- :pset pset)))
- (with-slots (messages) class
- (setf messages (append messages (list message))))
- (check-unused-properties pset))))
-
-(defmethod check-message-type ((message sod-message) (type c-function-type))
- nil)
-(defmethod check-message-type ((message sod-message) (type c-type))
- (error "Messages must have function type, not ~A" type))
-
-(defmethod shared-initialize :after
- ((message sod-message) slot-names &key pset)
- (declare (ignore slot-names pset))
- (with-slots (type) message
- (check-message-type message type)))
-
-;;;--------------------------------------------------------------------------
-;;; Method construction.
-
-(defgeneric make-sod-method
- (class nick name type body pset &optional location)
- (:documentation
- "Construct and attach a new method to CLASS.
-
- This is the main constructor function for methods. This is a generic
- function primarily so that the CLASS can intervene in the message lookup
- process, though this is actually a fairly unlikely occurrence.
-
- The default method looks up the message using FIND-MESSAGE-BY-NAME,
- 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."))
-
-(defgeneric make-sod-method-using-message
- (message class type body pset location)
- (:documentation
- "Main construction subroutine for method construction.
-
- This is a generic function so that it can be specialized according to both
- a class and -- more particularly -- a message. The default method uses
- the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS)
- to choose a (CLOS) class to instantiate. The method 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-METHOD defines an :AFTER-method on SHARED-INITIALIZE.
-
- Diagnosing unused properties is left for the caller (usually
- MAKE-SOD-METHOD) to do. The caller is also expected to have set
- WITH-DEFAULT-ERROR-LOCATION if appropriate.
-
- You are not expected to call this generic function directly; it's more
- useful as a place to hang methods for custom initializer classes."))
-
-(defgeneric sod-message-method-class (message class pset)
- (:documentation
- "Return the preferred class for methods on MESSAGE.
-
- The message can inspect the PSET to decide on a particular message. A
- :LISP-CLASS property will usually override this decision: it's then the
- programmer's responsibility to ensure that the selected method class is
- appropriate."))
-
-(defgeneric check-method-type (method message type)
- (:documentation
- "Check that TYPE is a suitable type for METHOD. Signal errors if not.
-
- This is separated out of SHARED-INITIALIZE, where it's called, so that it
- can be overridden conveniently by subclasses."))
-
-(defmethod make-sod-method
- ((class sod-class) nick name type body pset &optional location)
- (with-default-error-location (location)
- (let* ((message (find-message-by-name class nick name))
- (method (make-sod-method-using-message message class
- type body pset
- (file-location location))))
- (with-slots (methods) class
- (setf methods (append methods (list method)))))
- (check-unused-properties pset)))
-
-(defmethod make-sod-method-using-message
- ((message sod-message) (class sod-class) type body pset location)
- (make-instance (or (get-property pset :lisp-class :symbol)
- (sod-message-method-class message class pset))
- :message message
- :class class
- :type type
- :body body
- :location location
- :pset pset))
-
-(defmethod sod-message-method-class
- ((message sod-message) (class sod-class) pset)
- (declare (ignore pset))
- 'sod-method)
-
-(defmethod check-method-type
- ((method sod-method) (message sod-message) (type c-type))
- (error "Methods must have function type, not ~A" type))
-
-(defun argument-lists-compatible-p (message-args method-args)
- "Compare argument lists for compatibility.
-
- Return true if METHOD-ARGS is a suitable method argument list
- corresponding to the message argument list MESSAGE-ARGS. This is the case
- if the lists are the same length, each message argument has a
- corresponding method argument with the same type, and if the message
- arguments end in an ellpisis, the method arguments must end with a
- `va_list' argument. (We can't pass actual variable argument lists around,
- except as `va_list' objects, which are devilish inconvenient things and
- require much hacking. See the method combination machinery for details.)"
-
- (and (= (length message-args) (length method-args))
- (every (lambda (message-arg method-arg)
- (if (eq message-arg :ellipsis)
- (eq method-arg (c-type va-list))
- (c-type-equal-p (argument-type message-arg)
- (argument-type method-arg))))
- message-args method-args)))
-
-(defmethod check-method-type
- ((method sod-method) (message sod-message) (type c-function-type))
- (with-slots ((msgtype type)) message
- (unless (c-type-equal-p (c-type-subtype msgtype)
- (c-type-subtype type))
- (error "Method return type ~A doesn't match message ~A"
- (c-type-subtype msgtype) (c-type-subtype type)))
- (unless (argument-lists-compatible-p (c-function-arguments msgtype)
- (c-function-arguments type))
- (error "Method arguments ~A don't match message ~A" type msgtype))))
-
-(defmethod shared-initialize :after
- ((method sod-method) slot-names &key pset)
- (declare (ignore slot-names pset))
-
- ;; Check that the arguments are named if we have a method body.
- (with-slots (body type) method
- (unless (or (not body)
- (every #'argument-name (c-function-arguments type)))
- (error "Abstract declarators not permitted in method definitions")))
-
- ;; Check the method type.
- (with-slots (message type) method
- (check-method-type method message type)))
-
-;;;--------------------------------------------------------------------------
-;;; Builder macros.
-
-(defmacro define-sod-class (name (&rest superclasses) &body body)
- (let ((plist nil)
- (classvar (gensym "CLASS")))
- (loop
- (when (or (null body)
- (not (keywordp (car body))))
- (return))
- (push (pop body) plist)
- (push (pop body) plist))
- `(let ((,classvar (make-sod-class ,name
- (mapcar #'find-sod-class
- (list ,@superclasses))
- (make-property-set
- ,@(nreverse plist)))))
- (macrolet ((message (name type &rest plist)
- `(make-sod-message ,',classvar ,name (c-type ,type)
- (make-property-set ,@plist)))
- (method (nick name type body &rest plist)
- `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
- ,body (make-property-set ,@plist)))
- (slot (name type &rest plist)
- `(make-sod-slot ,',classvar ,name (c-type ,type)
- (make-property-set ,@plist)))
- (instance-initializer
- (nick name value-kind value-form &rest plist)
- `(make-sod-instance-initializer ,',classvar ,nick ,name
- ,value-kind ,value-form
- (make-property-set
- ,@plist)))
- (class-initializer
- (nick name value-kind value-form &rest plist)
- `(make-sod-class-initializer ,',classvar ,nick ,name
- ,value-kind ,value-form
- (make-property-set
- ,@plist))))
- ,@body
- (finalize-sod-class ,classvar)
- (add-to-module *module* ,classvar)))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Class finalization
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Class finalization.
-
-;; Protocol.
-
-(defgeneric compute-chains (class)
- (:documentation
- "Compute the layout chains for CLASS.
-
- Returns the following three values.
-
- * the head of the class's primary chain;
-
- * the class's primary chain as a list, most- to least-specific; and
-
- * the complete collection of chains, as a list of lists, each most- to
- least-specific, with the primary chain first.
-
- These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
-
- If the chains are ill-formed (i.e., not distinct) then an error is
- signalled."))
-
-(defgeneric check-sod-class (class)
- (:documentation
- "Check the CLASS for validity.
-
- This is done as part of class finalization. The checks performed are as
- follows.
-
- * The class name and nickname, and the names of messages, obey the
- rules (see VALID-NAME-P).
-
- * The messages and slots have distinct names.
-
- * The classes in the class-precedence-list have distinct nicknames.
-
- * The chain-link is actually a proper (though not necessarily direct)
- superclass.
-
- * The chosen metaclass is actually a subclass of all of the
- superclasses' metaclasses.
-
- Returns true if all is well; false (and signals errors) if anything was
- wrong."))
-
-(defgeneric finalize-sod-class (class)
- (:documentation
- "Computes all of the gory details about a class.
-
- Once one has stopped inserting methods and slots and so on into a class,
- one needs to finalize it to determine the layout structure and the class
- precedence list and so on. More precisely that gets done is this:
-
- * Related classes (i.e., direct superclasses and the metaclass) are
- finalized if they haven't been already.
-
- * If you've been naughty and failed to store a list of slots or
- whatever, then an empty list is inserted.
-
- * The class precedence list is computed and stored.
-
- * The class is checked for compiance with the well-formedness rules.
-
- * The layout chains are computed.
-
- Other stuff will need to happen later, but it's not been done yet. In
- particular:
-
- * Actually computing the layout of the instance and the virtual tables.
-
- * Combining the applicable methods into effective methods.
-
- FIXME this needs doing."))
-
-;; Implementation.
-
-(defun sod-subclass-p (class-a class-b)
- "Return whether CLASS-A is a descendent of CLASS-B."
- (member class-b (sod-class-precedence-list class-a)))
-
-(defun valid-name-p (name)
- "Checks whether NAME is a valid name.
-
- The rules are:
-
- * the name must be a string
- * which is nonempty
- * whose first character is alphabetic
- * all of whose characters are alphanumeric or underscores
- * and which doesn't contain two consecutive underscores."
-
- (and (stringp name)
- (plusp (length name))
- (alpha-char-p (char name 0))
- (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
- (not (search "__" name))))
-
-(defmethod compute-chains ((class sod-class))
- (with-default-error-location (class)
- (with-slots (chain-link class-precedence-list) class
- (let* ((head (if chain-link
- (sod-class-chain-head chain-link)
- class))
- (chain (cons class (and chain-link
- (sod-class-chain chain-link))))
- (table (make-hash-table)))
-
- ;; Check the chains. We work through each superclass, maintaining a
- ;; hash table keyed by class. If we encounter a class C which links
- ;; to L, then we store C as L's value; if L already has a value then
- ;; we've found an error. By the end of all of this, the classes
- ;; which don't have an entry are the chain tails.
- (dolist (super class-precedence-list)
- (let ((link (sod-class-chain-link super)))
- (when link
- (when (gethash link table)
- (error "Conflicting chains in class ~A: ~
- (~A and ~A both link to ~A)"
- class super (gethash link table) link))
- (setf (gethash link table) super))))
-
- ;; Done.
- (values head chain
- (cons chain
- (mapcar #'sod-class-chain
- (remove-if (lambda (super)
- (gethash super table))
- (cdr class-precedence-list)))))))))
-
-(defmethod check-sod-class ((class sod-class))
- (with-default-error-location (class)
-
- ;; Check the names of things are valid.
- (with-slots (name nickname messages) class
- (unless (valid-name-p name)
- (error "Invalid class name `~A'" class))
- (unless (valid-name-p nickname)
- (error "Invalid class nickname `~A' on class `~A'" nickname class))
- (dolist (message messages)
- (unless (valid-name-p (sod-message-name message))
- (error "Invalid message name `~A' on class `~A'"
- (sod-message-name message) class))))
-
- ;; Check that the slots and messages have distinct names.
- (with-slots (slots messages class-precedence-list) class
- (flet ((check-list (list what namefunc)
- (let ((table (make-hash-table :test #'equal)))
- (dolist (item list)
- (let ((name (funcall namefunc item)))
- (if (gethash name table)
- (error "Duplicate ~A name `~A' on class `~A'"
- what name class)
- (setf (gethash name table) item)))))))
- (check-list slots "slot" #'sod-slot-name)
- (check-list messages "message" #'sod-message-name)
- (check-list class-precedence-list "nickname" #'sod-class-name)))
-
- ;; Check that the CHAIN-TO class is actually a proper superclass. (This
- ;; eliminates hairy things like a class being its own link.)
- (with-slots (class-precedence-list chain-link) class
- (unless (or (not chain-link)
- (member chain-link (cdr class-precedence-list)))
- (error "In `~A~, chain-to class `~A' is not a proper superclass"
- class chain-link)))
-
- ;; Check for circularity in the superclass graph. Since the superclasses
- ;; should already be acyclic, it suffices to check that our class is not
- ;; a superclass of any of its own direct superclasses.
- (let ((circle (find-if (lambda (super)
- (sod-subclass-p super class))
- (sod-class-direct-superclasses class))))
- (when circle
- (error "Circularity: ~A is already a superclass of ~A"
- class circle)))
-
- ;; Check that the class has a unique root superclass.
- (find-root-superclass class)
-
- ;; Check that the metaclass is a subclass of each direct superclass's
- ;; metaclass.
- (with-slots (metaclass direct-superclasses) class
- (dolist (super direct-superclasses)
- (unless (sod-subclass-p metaclass (sod-class-metaclass super))
- (error "Incompatible metaclass for `~A': ~
- `~A' isn't a subclass of `~A' (of `~A')"
- class metaclass (sod-class-metaclass super) super))))))
-
-(defmethod finalize-sod-class ((class sod-class))
-
- ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
- ;; clone of the CPL and chain establishment code. If the interface changes
- ;; then BOOTSTRAP-CLASSES will need to be changed too.
-
- (with-default-error-location (class)
- (ecase (sod-class-state class)
- ((nil)
-
- ;; If this fails, mark the class as a loss.
- (setf (sod-class-state class) :broken)
-
- ;; Finalize all of the superclasses. There's some special pleading
- ;; here to make bootstrapping work: we don't try to finalize the
- ;; metaclass if we're a root class (no direct superclasses -- because
- ;; in that case the metaclass will have to be a subclass of us!), or
- ;; if it's equal to us. This is enough to tie the knot at the top of
- ;; the class graph.
- (with-slots (name direct-superclasses metaclass) class
- (dolist (super direct-superclasses)
- (finalize-sod-class super))
- (unless (or (null direct-superclasses)
- (eq class metaclass))
- (finalize-sod-class metaclass)))
-
- ;; Stash the class's type.
- (setf (sod-class-type class)
- (make-class-type (sod-class-name class)))
-
- ;; Clobber the lists of items if they've not been set.
- (dolist (slot '(slots instance-initializers class-initializers
- messages methods))
- (unless (slot-boundp class slot)
- (setf (slot-value class slot) nil)))
-
- ;; If the CPL hasn't been done yet, compute it.
- (with-slots (class-precedence-list) class
- (unless (slot-boundp class 'class-precedence-list)
- (setf class-precedence-list (compute-cpl class))))
-
- ;; If no metaclass has been established, then choose one.
- (with-slots (metaclass) class
- (unless (and (slot-boundp class 'metaclass) metaclass)
- (setf metaclass (guess-metaclass class))))
-
- ;; If no nickname has been set, choose a default. This might cause
- ;; conflicts, but, well, the user should have chosen an explicit
- ;; nickname.
- (with-slots (name nickname) class
- (unless (and (slot-boundp class 'nickname) nickname)
- (setf nickname (string-downcase name))))
-
- ;; Check that the class is fairly sane.
- (check-sod-class class)
-
- ;; Determine the class's layout.
- (with-slots (chain-head chain chains) class
- (setf (values chain-head chain chains) (compute-chains class)))
-
- (with-slots (ilayout effective-methods vtables) class
- (setf ilayout (compute-ilayout class))
- (setf effective-methods (compute-effective-methods class))
- (setf vtables (compute-vtables class)))
-
- ;; Done.
- (setf (sod-class-state class) :finalized)
- t)
-
- (:broken
- nil)
-
- (:finalized
- t))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Layout for instances and vtables
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Effective slot objects.
-
-(defclass effective-slot ()
- ((class :initarg :class :type sod-slot :reader effective-slot-class)
- (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
- (initializer :initarg :initializer :type (or sod-initializer null)
- :reader effective-slot-initializer))
- (:documentation
- "Describes a slot and how it's meant to be initialized.
-
- Effective slot objects are usually attached to layouts."))
-
-(defgeneric find-slot-initializer (class slot)
- (:documentation
- "Return the most specific initializer for SLOT, starting from CLASS."))
-
-(defgeneric compute-effective-slot (class slot)
- (:documentation
- "Construct an effective slot from the supplied direct slot.
-
- SLOT is a direct slot defined on CLASS or one of its superclasses.
- (Metaclass initializers are handled using a different mechanism.)"))
-
-(defmethod print-object ((slot effective-slot) stream)
- (maybe-print-unreadable-object (slot stream :type t)
- (format stream "~A~@[ = ~@_~A~]"
- (effective-slot-direct-slot slot)
- (effective-slot-initializer slot))))
-
-(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
- (some (lambda (super)
- (find slot
- (sod-class-instance-initializers super)
- :key #'sod-initializer-slot))
- (sod-class-precedence-list class)))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
- (make-instance 'effective-slot
- :slot slot
- :class class
- :initializer (find-slot-initializer class slot)))
-
-;;;--------------------------------------------------------------------------
-;;; Instance layout objects.
-
-;;; islots
-
-(defclass islots ()
- ((class :initarg :class :type sod-class :reader islots-class)
- (subclass :initarg :subclass :type sod-class :reader islots-subclass)
- (slots :initarg :slots :type list :reader islots-slots))
- (:documentation
- "The collection of effective SLOTS defined by an instance of CLASS."))
-
-(defmethod print-object ((islots islots) stream)
- (print-unreadable-object (islots stream :type t)
- (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
- (islots-subclass islots)
- (islots-class islots)
- (islots-slots islots))))
-
-(defgeneric compute-islots (class subclass)
- (:documentation
- "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS.
-
- Initializers for the slots should be taken from the most specific
- superclass of SUBCLASS."))
-
-;;; vtable-pointer
-
-(defclass vtable-pointer ()
- ((class :initarg :class :type sod-class :reader vtable-pointer-class)
- (chain-head :initarg :chain-head :type sod-class
- :reader vtable-pointer-chain-head)
- (chain-tail :initarg :chain-tail :type sod-class
- :reader vtable-pointer-chain-tail))
- (:documentation
- "A pointer to the vtable for CLASS corresponding to a particular CHAIN."))
-
-(defmethod print-object ((vtp vtable-pointer) stream)
- (print-unreadable-object (vtp stream :type t)
- (format stream "~A:~A"
- (vtable-pointer-class vtp)
- (sod-class-nickname (vtable-pointer-chain-head vtp)))))
-
-;;; ichain
-
-(defclass ichain ()
- ((class :initarg :class :type sod-class :reader ichain-class)
- (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
- (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
- (body :initarg :body :type list :reader ichain-body))
- (:documentation
- "All of the instance layout for CLASS corresponding to a particular CHAIN.
-
- The BODY is a list of things to include in the finished structure. By
- default, it contains a VTABLE-POINTER and ISLOTS for each class in the
- chain."))
-
-(defmethod print-object ((ichain ichain) stream)
- (print-unreadable-object (ichain stream :type t)
- (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
- (ichain-class ichain)
- (sod-class-nickname (ichain-head ichain))
- (ichain-body ichain))))
-
-(defgeneric compute-ichain (class chain)
- (:documentation
- "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
-
- The CHAIN is a list of classes, with the least specific first -- so the
- chain head is the first element."))
-
-;;; ilayout
-
-(defclass ilayout ()
- ((class :initarg :class :type sod-class :reader ilayout-class)
- (ichains :initarg :ichains :type list :reader ilayout-ichains))
- (:documentation
- "All of the instance layout for a CLASS.
-
- Consists of an ICHAIN for each distinct chain."))
-
-(defmethod print-object ((ilayout ilayout) stream)
- (print-unreadable-object (ilayout stream :type t)
- (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
- (ilayout-class ilayout)
- (ilayout-ichains ilayout))))
-
-(defgeneric compute-ilayout (class)
- (:documentation
- "Compute and return an instance layout for CLASS."))
-
-;;; Standard implementation.
-
-(defmethod compute-islots ((class sod-class) (subclass sod-class))
- (make-instance 'islots
- :class class
- :subclass subclass
- :slots (mapcar (lambda (slot)
- (compute-effective-slot subclass slot))
- (sod-class-slots class))))
-
-(defmethod compute-ichain ((class sod-class) chain)
- (let* ((chain-head (car chain))
- (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
- :key #'sod-class-chain-head))
- (vtable-pointer (make-instance 'vtable-pointer
- :class class
- :chain-head chain-head
- :chain-tail chain-tail))
- (islots (remove-if-not #'islots-slots
- (mapcar (lambda (super)
- (compute-islots super class))
- chain))))
- (make-instance 'ichain
- :class class
- :chain-head chain-head
- :chain-tail chain-tail
- :body (cons vtable-pointer islots))))
-
-(defmethod compute-ilayout ((class sod-class))
- (make-instance 'ilayout
- :class class
- :ichains (mapcar (lambda (chain)
- (compute-ichain class
- (reverse chain)))
- (sod-class-chains class))))
-
-;;;--------------------------------------------------------------------------
-;;; Effective methods.
-
-(defclass effective-method ()
- ((message :initarg :message :type sod-message
- :reader effective-method-message)
- (class :initarg :class :type sod-class :reader effective-method-class))
- (:documentation
- "The effective method invoked by sending MESSAGE to an instance of CLASS.
-
- This is not a useful class by itself. Message classes are expected to
- define their own effective-method classes.
-
- An effective method class must accept a :DIRECT-METHODS initarg, which
- will be a list of applicable methods sorted in most-to-least specific
- order."))
-
-(defmethod print-object ((method effective-method) stream)
- (maybe-print-unreadable-object (method stream :type t)
- (format stream "~A ~A"
- (effective-method-message method)
- (effective-method-class method))))
-
-(defgeneric message-effective-method-class (message)
- (:documentation
- "Return the effective method class for the given MESSAGE."))
-
-(defgeneric compute-sod-effective-method (message class)
- (:documentation
- "Return the effective method when a CLASS instance receives MESSAGE.
-
- The default method constructs an instance of the message's chosen
- MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the
- list of applicable methods as initargs to MAKE-INSTANCE."))
-
-(defmethod compute-sod-effective-method
- ((message sod-message) (class sod-class))
- (let ((direct-methods (mappend (lambda (super)
- (remove message
- (sod-class-methods super)
- :key #'sod-method-message
- :test-not #'eql))
- (sod-class-precedence-list class))))
- (make-instance (message-effective-method-class message)
- :message message
- :class class
- :direct-methods direct-methods)))
-
-;;;--------------------------------------------------------------------------
-;;; Vtable layout.
-
-;;; method-entry
-
-(defclass method-entry ()
- ((method :initarg :method :type effective-method
- :reader method-entry-effective-method)
- (chain-head :initarg :chain-head :type sod-class
- :reader method-entry-chain-head)
- (chain-tail :initarg :chain-tail :type sod-class
- :reader method-entry-chain-tail))
- (:documentation
- "An entry point into an effective method.
-
- Calls to an effective method via different vtable chains will have their
- `me' pointers pointing to different ichains within the instance layout.
- Rather than (necessarily) duplicating the entire effective method for each
- chain, we insert an entry veneer (the method entry) to fix up the pointer.
- Exactly how it does this is up to the effective method -- and duplication
- under some circumstances is probably a reasonable approach -- e.g., if the
- effective method is just going to call a direct method immediately."))
-
-(defmethod print-object ((entry method-entry) stream)
- (maybe-print-unreadable-object (entry stream :type t)
- (format stream "~A:~A"
- (method-entry-effective-method entry)
- (sod-class-nickname (method-entry-chain-head entry)))))
-
-(defgeneric make-method-entry (effective-method chain-head chain-tail)
- (:documentation
- "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
-
- There is no default method for this function. (Maybe when the
- effective-method/method-entry output protocol has settled down I'll know
- what a sensible default action would be.)"))
-
-;;; vtmsgs
-
-(defclass vtmsgs ()
- ((class :initarg :class :type sod-class :reader vtmsgs-class)
- (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
- (chain-head :initarg :chain-head :type sod-class
- :reader vtmsgs-chain-head)
- (chain-tail :initarg :chain-tail :type sod-class
- :reader vtmsgs-chain-tail)
- (entries :initarg :entries :type list :reader vtmsgs-entries))
- (:documentation
- "The message dispatch table for a particular CLASS.
-
- The BODY contains a list of effective method entry objects for the
- messages defined on CLASS, customized for calling from the chain headed by
- CHAIN-HEAD."))
-
-(defmethod print-object ((vtmsgs vtmsgs) stream)
- (print-unreadable-object (vtmsgs stream :type t)
- (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
- (vtmsgs-subclass vtmsgs)
- (vtmsgs-class vtmsgs)
- (vtmsgs-entries vtmsgs))))
-
-(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
- (:documentation
- "Return a VTMSGS object containing method entries for CLASS.
-
- The CHAIN-HEAD describes which chain the method entries should be
- constructed for.
-
- The default method simply calls MAKE-METHOD-ENTRY for each of the methods
- and wraps a VTMSGS object around them. This ought to be enough for almost
- all purposes."))
-
-;;; class-pointer
-
-(defclass class-pointer ()
- ((class :initarg :class :type sod-class :reader class-pointer-class)
- (chain-head :initarg :chain-head :type sod-class
- :reader class-pointer-chain-head)
- (metaclass :initarg :metaclass :type sod-class
- :reader class-pointer-metaclass)
- (meta-chain-head :initarg :meta-chain-head :type sod-class
- :reader class-pointer-meta-chain-head))
- (:documentation
- "Represents a pointer to a class object for the instance's class.
-
- A class instance can have multiple chains. It may be useful to find any
- of those chains from an instance of the class. Therefore the vtable
- stores a pointer to each separate chain of the class instance."))
-
-(defmethod print-object ((cptr class-pointer) stream)
- (print-unreadable-object (cptr stream :type t)
- (format stream "~A:~A"
- (class-pointer-metaclass cptr)
- (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
-
-(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
- (:documentation
- "Return a class pointer to a metaclass chain."))
-
-;;; base-offset
-
-(defclass base-offset ()
- ((class :initarg :class :type sod-class :reader base-offset-class)
- (chain-head :initarg :chain-head :type sod-class
- :reader base-offset-chain-head))
- (:documentation
- "The offset of this chain to the ilayout base.
-
- There's only one of these per vtable."))
-
-(defmethod print-object ((boff base-offset) stream)
- (print-unreadable-object (boff stream :type t)
- (format stream "~A:~A"
- (base-offset-class boff)
- (sod-class-nickname (base-offset-chain-head boff)))))
-
-(defgeneric make-base-offset (class chain-head)
- (:documentation
- "Return the base offset object for CHAIN-HEAD ichain."))
-
-;;; chain-offset
-
-(defclass chain-offset ()
- ((class :initarg :class :type sod-class :reader chain-offset-class)
- (chain-head :initarg :chain-head :type sod-class
- :reader chain-offset-chain-head)
- (target-head :initarg :target-head :type sod-class
- :reader chain-offset-target-head))
- (:documentation
- "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain."))
-
-(defmethod print-object ((choff chain-offset) stream)
- (print-unreadable-object (choff stream :type t)
- (format stream "~A:~A->~A"
- (chain-offset-class choff)
- (sod-class-nickname (chain-offset-chain-head choff))
- (sod-class-nickname (chain-offset-target-head choff)))))
-
-(defgeneric make-chain-offset (class chain-head target-head)
- (:documentation
- "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
-
-;;; vtable
-
-(defclass vtable ()
- ((class :initarg :class :type sod-class :reader vtable-class)
- (chain-head :initarg :chain-head :type sod-class
- :reader vtable-chain-head)
- (chain-tail :initarg :chain-tail :type sod-class
- :reader vtable-chain-tail)
- (body :initarg :body :type list :reader vtable-body))
- (:documentation
- "VTABLEs hold all of the per-chain static information for a class.
-
- There is one vtable for each chain of each class. The vtables for a class
- are prefixes of the corresponding chains of its subclasses.
-
- Vtables contain method entry pointers, pointers to class objects, and
- the offset information used for cross-chain slot access."))
-
-(defmethod print-object ((vtable vtable) stream)
- (print-unreadable-object (vtable stream :type t)
- (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
- (vtable-class vtable)
- (sod-class-nickname (vtable-chain-head vtable))
- (vtable-body vtable))))
-
-(defgeneric compute-vtable (class chain)
- (:documentation
- "Compute the vtable layout for a chain of CLASS.
-
- The CHAIN is a list of classes, with the least specific first."))
-
-(defgeneric compute-vtables (class)
- (:documentation
- "Compute the vtable layouts for CLASS.
-
- Returns a list of VTABLE objects in the order of CLASS's chains."))
-
-;;; Implementation.
-
-(defmethod compute-vtmsgs
- ((class sod-class)
- (subclass sod-class)
- (chain-head sod-class)
- (chain-tail sod-class))
- (flet ((make-entry (message)
- (let ((method (find message
- (sod-class-effective-methods subclass)
- :key #'effective-method-message)))
- (make-method-entry method chain-head chain-tail))))
- (make-instance 'vtmsgs
- :class class
- :subclass subclass
- :chain-head chain-head
- :chain-tail chain-tail
- :entries (mapcar #'make-entry
- (sod-class-messages class)))))
-
-(defmethod make-class-pointer
- ((class sod-class) (chain-head sod-class)
- (metaclass sod-class) (meta-chain-head sod-class))
-
- ;; Slightly tricky. We don't necessarily want a pointer to the metaclass,
- ;; but to its most specific subclass on the given chain. Fortunately, CL
- ;; is good at this game.
- (let* ((meta-chains (sod-class-chains metaclass))
- (meta-chain-tails (mapcar #'car meta-chains))
- (meta-chain-tail (find meta-chain-head meta-chain-tails
- :key #'sod-class-chain-head)))
- (make-instance 'class-pointer
- :class class
- :chain-head chain-head
- :metaclass meta-chain-tail
- :meta-chain-head meta-chain-head)))
-
-(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
- (make-instance 'base-offset
- :class class
- :chain-head chain-head))
-
-(defmethod make-chain-offset
- ((class sod-class) (chain-head sod-class) (target-head sod-class))
- (make-instance 'chain-offset
- :class class
- :chain-head chain-head
- :target-head target-head))
-
-;; Special variables used by COMPUTE-VTABLE.
-(defvar *done-metaclass-chains*)
-(defvar *done-instance-chains*)
-
-(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
- (:documentation
- "Emit vtable items for a superclass of CLASS.
-
- This function is called for each superclass SUPER of CLASS reached on the
- chain headed by CHAIN-HEAD. The function should call EMIT for each
- vtable item it wants to write.
-
- The right way to check to see whether items have already been emitted
- (e.g., has an offset to some other chain been emitted?) is as follows:
-
- * In a method on COMPUTE-VTABLE, bind a special variable to an empty
- list or hash table.
-
- * In a method on this function, check the variable or hash table.
-
- This function is the real business end of COMPUTE-VTABLE."))
-
-(defmethod compute-vtable-items
- ((class sod-class) (super sod-class) (chain-head sod-class)
- (chain-tail sod-class) (emit function))
-
- ;; If this class introduces new metaclass chains, then emit pointers to
- ;; them.
- (let* ((metasuper (sod-class-metaclass super))
- (metasuper-chains (sod-class-chains metasuper))
- (metasuper-chain-heads (mapcar (lambda (chain)
- (sod-class-chain-head (car chain)))
- metasuper-chains)))
- (dolist (metasuper-chain-head metasuper-chain-heads)
- (unless (member metasuper-chain-head *done-metaclass-chains*)
- (funcall emit (make-class-pointer class
- chain-head
- metasuper
- metasuper-chain-head))
- (push metasuper-chain-head *done-metaclass-chains*))))
-
- ;; If there are new instance chains, then emit offsets to them.
- (let* ((chains (sod-class-chains super))
- (chain-heads (mapcar (lambda (chain)
- (sod-class-chain-head (car chain)))
- chains)))
- (dolist (head chain-heads)
- (unless (member head *done-instance-chains*)
- (funcall emit (make-chain-offset class chain-head head))
- (push head *done-instance-chains*))))
-
- ;; Finally, if there are interesting methods, emit those too.
- (when (sod-class-messages super)
- (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
-
-(defun find-root-superclass (class)
- "Returns the `root' superclass of CLASS.
-
- The root superclass is the superclass which itself has no direct
- superclasses. In universes not based on the provided builtin module, the
- root class may not be our beloved SodObject; however, there must be one
- (otherwise the class graph is cyclic, which should be forbidden), and we
- instist that it be unique."
-
- ;; The root superclass must be a chain head since the chains partition the
- ;; superclasses; the root has no superclasses so it can't have a link and
- ;; must therefore be a head. This narrows the field down quite a lot.
- ;;
- ;; Note! This function gets called from CHECK-SOD-CLASS before the class's
- ;; chains have been computed. Therefore we iterate over the direct
- ;; superclass's chains rather than the class's own. This misses a chain
- ;; only in the case where the class is its own chain head. There are two
- ;; subcases: if there are no direct superclasses at all, then the class is
- ;; its own root; otherwise, it clearly can't be the root and the omission
- ;; is harmless.
- (let* ((supers (sod-class-direct-superclasses class))
- (roots (if supers
- (remove-duplicates
- (remove-if #'sod-class-direct-superclasses
- (mappend (lambda (super)
- (mapcar (lambda (chain)
- (sod-class-chain-head
- (car chain)))
- (sod-class-chains super)))
- supers)))
- (list class))))
- (cond ((null roots) (error "Class ~A has no root class!" class))
- ((cdr roots) (error "Class ~A has multiple root classes ~
- ~{~A~#[~; and ~;, ~]~}"
- class roots))
- (t (car roots)))))
-
-(defun find-root-metaclass (class)
- "Returns the `root' metaclass of CLASS.
-
- The root metaclass is the metaclass of the root superclass -- see
- FIND-ROOT-SUPERCLASS."
- (sod-class-metaclass (find-root-superclass class)))
-
-(defmethod compute-vtable ((class sod-class) (chain list))
- (let* ((chain-head (car chain))
- (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
- :key #'sod-class-chain-head))
- (*done-metaclass-chains* nil)
- (*done-instance-chains* (list chain-head))
- (done-superclasses nil)
- (items nil))
- (flet ((emit (item)
- (push item items)))
-
- ;; Find the root chain in the metaclass and write a pointer.
- (let* ((metaclass (sod-class-metaclass class))
- (metaclass-root (find-root-metaclass class))
- (metaclass-root-head (sod-class-chain-head metaclass-root)))
- (emit (make-class-pointer class chain-head metaclass
- metaclass-root-head))
- (push metaclass-root-head *done-metaclass-chains*))
-
- ;; Write an offset to the instance base.
- (emit (make-base-offset class chain-head))
-
- ;; Now walk the chain. As we ascend the chain, scan the class
- ;; precedence list of each class in reverse to ensure that we have
- ;; everything interesting.
- (dolist (super chain)
- (dolist (sub (reverse (sod-class-precedence-list super)))
- (unless (member sub done-superclasses)
- (compute-vtable-items class
- sub
- chain-head
- chain-tail
- #'emit)
- (push sub done-superclasses))))
-
- ;; We're through.
- (make-instance 'vtable
- :class class
- :chain-head chain-head
- :chain-tail chain-tail
- :body (nreverse items)))))
-
-(defgeneric compute-effective-methods (class)
- (:documentation
- "Return a list of all of the effective methods needed for CLASS.
-
- The list needn't be in any particular order."))
-
-(defmethod compute-effective-methods ((class sod-class))
- (mapcan (lambda (super)
- (mapcar (lambda (message)
- (compute-sod-effective-method message class))
- (sod-class-messages super)))
- (sod-class-precedence-list class)))
-
-(defmethod compute-vtables ((class sod-class))
- (mapcar (lambda (chain)
- (compute-vtable class (reverse chain)))
- (sod-class-chains class)))
-
-;;;--------------------------------------------------------------------------
-;;; Names of things.
-
-(defun islots-struct-tag (class)
- (format nil "~A__islots" class))
-
-(defun ichain-struct-tag (class chain-head)
- (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
-
-(defun ichain-union-tag (class chain-head)
- (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
-
-(defun ilayout-struct-tag (class)
- (format nil "~A__ilayout" class))
-
-(defun vtmsgs-struct-tag (class super)
- (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
-
-(defun vtable-struct-tag (class chain-head)
- (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
-
-(defun vtable-name (class chain-head)
- (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Method combinations
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Common behaviour.
-
-(defclass simple-message (basic-message)
- ()
- (:documentation
- "Base class for messages with `simple' method combinations.
-
- A simple method combination is one which has only one method role other
- than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
- We call these `primary' methods, and the programmer designates them by not
- specifying an explicit role.
-
- If the programmer doesn't define any primary methods then the effective
- method is null -- i.e., the method entry pointer shows up as a null
- pointer."))
-
-(defclass simple-effective-method (basic-effective-method)
- ((primary-methods :initarg :primary-methods :initform nil
- :type list :reader effective-method-primary-methods))
- (:documentation
- "Effective method counterpart to SIMPLE-MESSAGE."))
-
-(defgeneric primary-method-class (message)
- (:documentation
- "Return the name of the primary direct method class for MESSAGE."))
-
-(defgeneric simple-method-body (method codegen target)
- (:documentation
- "Generate the body of a simple effective method.
-
- The function is invoked on an effective METHOD, with a CODEGEN to which it
- should emit code delivering the method's value to TARGET."))
-
-(defmethod sod-message-method-class
- ((message standard-message) (class sod-class) pset)
- (if (get-property pset :role :keyword nil)
- (call-next-method)
- (primary-method-class message)))
-
-(defmethod shared-initialize :after
- ((method simple-effective-method) slot-names &key direct-methods)
- (declare (ignore slot-names))
- (categorize (method direct-methods :bind ((role (sod-method-role method))))
- ((primary (null role))
- (before (eq role :before))
- (after (eq role :after))
- (around (eq role :around)))
- (with-slots (primary-methods before-methods after-methods around-methods)
- method
- (setf primary-methods primary
- before-methods before
- after-methods (reverse after)
- around-methods around))))
-
-(defmethod compute-effective-method-entry-functions
- ((method standard-effective-method))
- (if (effective-method-primary-methods method)
- (call-next-method)
- nil))
-
-(defmethod compute-effective-method-body
- ((method simple-effective-method) codegen target)
- (with-slots (message basic-argument-names primary-methods) method
- (basic-effective-method-body codegen target method
- (lambda (target)
- (simple-method-body method
- codegen
- target)))))
-
-;;;--------------------------------------------------------------------------
-;;; Standard method combination.
-
-(defclass standard-message (simple-message)
- ()
- (:documentation
- "Message class for standard method combination.
-
- Standard method combination is a simple method combination where the
- primary methods are invoked as a delegation chain, from most- to
- least-specific."))
-
-(defclass standard-effective-method (simple-effective-method)
- ()
- (:documentation
- "Effective method counterpart to STANDARD-MESSAGE."))
-
-(defmethod primary-method-class ((message standard-message))
- 'delegating-direct-method)
-
-(defmethod message-effective-method-class ((message standard-message))
- 'standard-effective-method)
-
-(defmethod simple-method-body
- ((method standard-effective-method) codegen target)
- (invoke-delegation-chain codegen
- target
- (effective-method-basic-argument-names method)
- (effective-method-primary-methods method)
- nil))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;;--------------------------------------------------------------------------
-;;; C types stuff.
-
-(cl:defpackage #:c-types
- (:use #:common-lisp
- #+sbcl #:sb-mop
- #+(or cmu clisp) #:mop
- #+ecl #:clos)
- (:export #:c-type
- #:c-declarator-priority #:maybe-parenthesize
- #:pprint-c-type
- #:c-type-subtype #:compount-type-declaration
- #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
- #:simple-c-type #:c-type-name
- #:c-pointer-type
- #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
- #:tagged-c-type-kind
- #:c-array-type #:c-array-dimensions
- #:make-argument #:argument-name #:argument-type
- #:c-function-type #:c-function-arguments
-
- #:define-c-type-syntax #:c-type-alias #:defctype
- #:print-c-type
- #:qualifier #:declare-qualifier
- #:define-simple-c-type
-
- #:const #:volatile #:static #:restrict
- #:char #:unsigned-char #:uchar #:signed-char #:schar
- #:int #:signed #:signed-int #:sint
- #:unsigned #:unsigned-int #:uint
- #:short #:signed-short #:short-int #:signed-short-int #:sshort
- #:unsigned-short #:unsigned-short-int #:ushort
- #:long #:signed-long #:long-int #:signed-long-int #:slong
- #:unsigned-long #:unsigned-long-int #:ulong
- #:float #:double #:long-double
- #:pointer #:ptr
- #:[] #:vec
- #:fun #:func #:fn))
-
-
-;;;--------------------------------------------------------------------------
-;;; Convenient syntax for C types.
-
-;; Basic machinery.
-
-;; Qualifiers. They have hairy syntax and need to be implemented by hand.
-
-;; Simple types.
-
-;; Pointers.
-
-;; Tagged types.
-
-;; Arrays.
-
-;; Functions.
-
-
-(progn
- (defconstant q-byte (byte 3 0))
- (defconstant q-const 1)
- (defconstant q-volatile 2)
- (defconstant q-restrict 4)
-
- (defconstant z-byte (byte 3 3))
- (defconstant z-unspec 0)
- (defconstant z-short 1)
- (defconstant z-long 2)
- (defconstant z-long-long 3)
- (defconstant z-double 4)
- (defconstant z-long-double 5)
-
- (defconstant s-byte (byte 2 6))
- (defconstant s-unspec 0)
- (defconstant s-signed 1)
- (defconstant s-unsigned 2)
-
- (defconstant t-byte (byte 3 8))
- (defconstant t-unspec 0)
- (defconstant t-int 1)
- (defconstant t-char 2)
- (defconstant t-float 3)
- (defconstant t-user 4))
-
-(defun make-type-flags (size sign type &rest quals)
- (let ((flags 0))
- (dolist (qual quals)
- (setf flags (logior flags qual)))
- (setf (ldb z-byte flags) size
- (ldb s-byte flags) sign
- (ldb t-byte flags) type)
- flags))
-
-
-(defun expand-c-type (spec)
- "Parse SPEC as a C type and return the result.
-
- The SPEC can be one of the following.
-
- * A C-TYPE object, which is returned immediately.
-
- * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
- function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
- or some other means is invoked on the ARGUMENTS, and the result is
- returned.
-
- * A symbol, which is treated the same way as a singleton list would be."
-
- (flet ((interp (sym)
- (or (get sym 'c-type)
- (error "Unknown C type operator ~S." sym))))
- (etypecase spec
- (c-type spec)
- (symbol (funcall (interp spec)))
- (list (apply (interp (car spec)) (cdr spec))))))
-
-(defmacro c-type (spec)
- "Evaluates to the type that EXPAND-C-TYPE would return.
-
- Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
- later it will do something more clever."
- `(expand-c-type ',spec))
-
-;; S-expression machinery. Qualifiers have hairy syntax and need to be
-;; implemented by hand.
-
-(defun qualifier (qual &rest args)
- "Parse a qualified C type.
-
- The ARGS consist of a number of qualifiers and exactly one C-type
- S-expression. The result is a qualified version of this type, with the
- given qualifiers attached."
- (if (null args)
- qual
- (let* ((things (mapcar #'expand-c-type args))
- (quals (delete-duplicates
- (sort (cons qual (remove-if-not #'keywordp things))
- #'string<)))
- (types (remove-if-not (lambda (thing) (typep thing 'c-type))
- things)))
- (when (or (null types)
- (not (null (cdr types))))
- (error "Only one proper type expected in ~S." args))
- (qualify-type (car types) quals))))
-(setf (get 'qualifier 'c-type) #'qualifier)
-
-(defun declare-qualifier (qual)
- "Defines QUAL as being a type qualifier.
-
- When used as a C-type operator, it applies that qualifier to the type that
- is its argument."
- (let ((kw (intern (string qual) :keyword)))
- (setf (get qual 'c-type)
- (lambda (&rest args)
- (apply #'qualifier kw args)))))
-
-;; Define some initial qualifiers.
-(dolist (qual '(const volatile restrict))
- (declare-qualifier qual))
-
-
-(define-c-type-syntax simple-c-type (name)
- "Constructs a simple C type called NAME (a string or symbol)."
- (make-simple-type (c-name-case name)))
-
-(defmethod print-c-type :around
- (stream (type qualifiable-c-type) &optional colon atsign)
- (if (c-type-qualifiers type)
- (pprint-logical-block (stream nil :prefix "(" :suffix ")")
- (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
- (c-type-qualifiers type))
- (call-next-method stream type colon atsign))
- (call-next-method)))
-;; S-expression syntax.
-
-
-(define-c-type-syntax enum (tag)
- "Construct an enumeration type named TAG."
- (make-instance 'c-enum-type :tag (c-name-case tag)))
-(define-c-type-syntax struct (tag)
- "Construct a structure type named TAG."
- (make-instance 'c-struct-type :tag (c-name-case tag)))
-(define-c-type-syntax union (tag)
- "Construct a union type named TAG."
- (make-instance 'c-union-type :tag (c-name-case tag)))
-
-(defgeneric make-me-argument (message class)
- (:documentation
- "Return an ARGUMENT object for the `me' argument to MESSAGE, as
- specialized to CLASS."))
-
-(defmethod make-me-argument
- ((message basic-message) (class sod-class))
- (make-argument "me" (make-instance 'c-pointer-type
- :subtype (sod-class-type class))))
--- /dev/null
+%%% -*-latex-*-
+%%%
+%%% Description of the internal class structure and protocol
+%%%
+%%% (c) 2009 Straylight/Edgeware
+%%%
+
+%%%----- Licensing notice ---------------------------------------------------
+%%%
+%%% This file is part of the Simple Object Definition system.
+%%%
+%%% 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.
+
+\chapter{Protocol overview} \label{ch:proto}
+
+This chapter provides an overview of the Sod translator's internal object
+model. It describes most of the important classes and generic functions, how
+they are used to build a model of a Sod module and produce output code, and
+how an extension might modify the translator's behaviour.
+
+I assume familiarity with the Common Lisp Object System (CLOS). Familiarity
+with the CLOS Metaobject Protocol isn't necessary but may be instructive.
+
+%%%--------------------------------------------------------------------------
+\section{A tour through the translator}
+
+At the very highest level, the Sod translator works in two phases: it
+\emph{parses} source files into an internal representation, and then it
+\emph{generates} output files from the internal representation.
+
+The function @|read-module| is given a pathname for a file: it opens the
+file, parses the program text, and returns a @|module| instance describing
+the classes and other items found.
+
+At the other end, the main output function is @|output-module|, which is
+given a module, an output stream and a
+
+
+%%%--------------------------------------------------------------------------
+\section{Specification conventions} \label{sec:proto.conventions}
+
+Throughout this specification, the phrase `it is an error' indicates that a
+particular circumstance is erroneous and results in unspecified and possibly
+incorrect behaviour. In particular, the situation need not be immediately
+diagnosed, and the consequences may be far-reaching.
+
+The following conventions apply throughout this specification.
+
+\begin{itemize}
+
+\item If a specification describes an argument as having a particular type or
+ syntax, then it is an error to provide an argument not having that
+ particular type or syntax.
+
+\item If a specification describes a function then that function might be
+ implemented as a generic function; it is an error to attempt to (re)define
+ it as a generic function, or to attempt to add methods to it. A function
+ specified as being a generic function will certainly be so; if user methods
+ are permitted on the generic function then this will be specified.
+
+\item Where a class precedence list is specified, either explicitly or
+ implicitly by a class hierarchy, the implementation may include additional
+ superclasses not specified here. Such additional superclasses will not
+ affect the order of specified classes in the class precedence lists either
+ of specified classes themselves or of user-defined subclasses of specified
+ classes.
+
+\item Unless otherwise specified, generic functions use the standard method
+ combination.
+
+\item The specifications for methods are frequently brief; they should be
+ read in conjunction with and in the context of the specification for the
+ generic function and specializing classes, if any.
+
+\item An object $o$ is a \emph{direct instance} of a class $c$ if @|(eq
+ (class-of $o$) $c$)|; $o$ is an \emph{instance} of $c$ if it is a direct
+ instance of any subclass of $c$.
+
+\item If a class is specified as being \emph{abstract} then it is an error to
+ construct direct instances of it, e.g., using @|make-instance|.
+
+\item If an object is specified as being \emph{immutable} then it is an error
+ to mutate it, e.g., using @|(setf (slot-value \ldots) \ldots)|. Programs
+ may rely on immutable objects retaining their state.
+
+\item A value is \emph{fresh} if it is guaranteed to be not @|eql| to any
+ previously existing value.
+
+\item Unless otherwise specified, it is an error to change the class of an
+ instance of any class described here; and it is an error to change the
+ class of an object to a class described here.
+
+\end{itemize}
+
+\subsection{Format of the entries} \label{sec:proto.conventions.format}
+
+Most symbols defined by the protocol have their own entries. An entry begins
+with a header line, showing a synopsis of the symbol on the left, and the
+category (function, class, macro, etc.) on the right.
+
+\begin{describe}{fun}{example-function @<required>
+ \&optional @<optional>
+ \&rest @<rest>
+ \&key :keyword}
+ The synopsis for a function, generic function or method describes the
+ function's lambda-list using the usual syntax. Note that keyword arguments
+ are shown by naming their keywords; in the description, the value passed
+ for the keyword argument @|keyword| is shown as @<keyword>.
+
+ For a method, specializers are shown using the usual @|defmethod| syntax,
+ e.g.,
+ \begin{quote}
+ some-generic-function ((@<specialized> list) @<unspecialized>)
+ \end{quote}
+\end{describe}
+
+\begin{describe}{mac}{example-macro
+ ( @{ @<symbol> @! (@<symbol> @<form>) @}^* ) \\ \push
+ @[[ @<declaration>^* @! @<documentation-string> @]] \\
+ @<body-form>^*}
+ The synopsis for a macro describes the acceptable syntax using the
+ following notation.
+ \begin{itemize}
+ \item Literal symbols, e.g., keywords and parenthesis, are shown in
+ @|monospace|.
+ \item Metasyntactic variables are shown in @<italics>.
+ \item Items are grouped together by braces `@{ $\dots$ @}'. The notation
+ `@{ $\dots$ @}^*' indicates that the enclosed items may be repeated zero
+ or more times; `@{ $\dots$ @}^+' indicates that the enclosed items may be
+ repeated one or more times. This notation may be applied to a single
+ item without the braces.
+ \item Optional items are shown enclosed in brackets `@[ $\dots$ @]'.
+ \item Alternatives are separated by vertical bars `@!'; the vertical bar
+ has low precedence, so alternatives extend as far as possible between
+ bars and up to the enclosing brackets if any.
+ \item A sequence of alternatives enclosed in double-brackets `@[[ $\ldots$
+ @]]' indicates that the alternatives may occur in any order, but each may
+ appear at most once unless marked by a star.
+ \end{itemize}
+ For example, the notation at the head of this example describes syntax
+ for @|let|.
+\end{describe}
+
+
+\begin{describe}{cls}{example-class (direct-super other-direct-super) \&key
+ :initarg}
+ The synopsis for a class lists the class's direct superclasses, and the
+ acceptable initargs in the form of a lambda-list. The initargs may be
+ passed to @|make-instance| when constructing an instance of the class or a
+ subclass of it. If instances of the class may be reinitialized, or if
+ objects can be changed to be instances of the class, then these initargs
+ may also be passed to @|reinitialize-instance| and/or @|change-class| as
+ applicable; the class description will state explicitly when these
+ operations are allowed.
+\end{describe}
+
+%%%--------------------------------------------------------------------------
+\section{C type representation} \label{sec:proto.c-types}
+
+\subsection{Overview} \label{sec:proto.c-types.over}
+
+The Sod translator represents C types in a fairly simple and direct way.
+However, because it spends a fair amount of its time dealing with C types, it
+provides a number of useful operations and macros.
+
+The class hierarchy is shown in~\xref{fig:proto.c-types}.
+
+\begin{figure} \centering
+ \parbox{10pt}{\begin{tabbing}
+ @|c-type| \\ \push
+ @|qualifiable-c-type| \\ \push
+ @|simple-c-type| \\ \push
+ @|c-class-type| \- \\
+ @|tagged-c-type| \\ \push
+ @|c-struct-type| \\
+ @|c-union-type| \\
+ @|c-enum-type| \- \\
+ @|c-pointer-type| \- \\
+ @|c-array-type| \\
+ @|c-function-type|
+ \end{tabbing}}
+ \caption{Classes representing C types}
+\label{fig:proto.c-types}
+\end{figure}
+
+C type objects are immutable unless otherwise specified.
+
+\subsubsection{Constructing C type objects}
+There is a constructor function for each non-abstract class of C type object.
+Note, however, that constructor functions need not generate a fresh type
+object if a previously existing type object is suitable. In this case, we
+say that the objects are \emph{interned}. Some constructor functions are
+specified to return interned objects: programs may rely on receiving the same
+(@|eq|) type object for similar (possibly merely @|equal|) arguments. Where
+not specified, clients may still not rely on receiving fresh objects.
+
+A convenient S-expression notation is provided by the @|c-type| macro. Use
+of this macro is merely an abbreviation for corresponding use of the various
+constructor functions, and therefore interns type objects in the same manner.
+The syntax accepted by the macro can be extended in order to support new
+classes: see @|defctype|, @|c-type-alias| and @|define-c-type-syntax|.
+
+The descriptions of each of the various classes include descriptions of the
+initargs which may be passed to @|make-instance| when constructing a new
+instance of the class. However, the constructor functions and S-expression
+syntax are strongly recommended over direct use of @|make-instance|.
+
+\subsubsection{Printing}
+There are two protocols for printing C types. Unfortunately they have
+similar names.
+\begin{itemize}
+\item The @|print-c-type| function prints a C type value using the
+ S-expression notation. It is mainly useful for diagnostic purposes.
+\item The @|pprint-c-type| function prints a C type as a C-syntax
+ declaration.
+\end{itemize}
+Neither generic function defines a default primary method; subclasses of
+@|c-type| must define their own methods in order to print correctly.
+
+\subsection{The C type root class} \label{sec:proto.c-types.root}
+
+\begin{describe}{cls}{c-type ()}
+ The class @|c-type| marks the root of the built-in C type hierarchy.
+
+ Users may define subclasses of @|c-type|. All non-abstract subclasses must
+ have a primary method defined on @|pprint-c-type|; unless instances of the
+ subclass are interned, a method on @|c-type-equal-p| is also required.
+
+ The class @|c-type| is abstract.
+\end{describe}
+
+\subsection{C type S-expression notation} \label{sec:proto.c-types.sexp}
+
+The S-expression representation of a type is described syntactically as a
+type specifier. Type specifiers fit into two syntactic categories.
+\begin{itemize}
+\item A \emph{symbolic type specifier} consists of a symbol. It has a
+ single, fixed meaning: if @<name> is a symbolic type specifier, then each
+ use of @<name> in a type specifier evaluates to the same (@|eq|) type
+ object, until the @<name> is redefined.
+\item A \emph{type operator} is a symbol; the corresponding specifier is a
+ list whose @|car| is the operator. The remaining items in the list are
+ arguments to the type operator.
+\end{itemize}
+
+\begin{describe}{mac}{c-type @<type-spec> @to @<type>}
+ Evaluates to a C type object, as described by the type specifier
+ @<type-spec>.
+\end{describe}
+
+\begin{describe}{mac}{
+ defctype @{ @<name> @! (@<name>^*) @} @<type-spec> @to @<names>}
+ Defines a new symbolic type specifier @<name>; if a list of @<name>s is
+ given, then all are defined in the same way. The type constructed by using
+ any of the @<name>s is as described by the type specifier @<type-spec>.
+
+ The resulting type object is constructed once, at the time that the macro
+ expansion is evaluated; the same (@|eq|) value is used each time any
+ @<name> is used in a type specifier.
+\end{describe}
+
+\begin{describe}{mac}{c-type-alias @<original> @<alias>^* @to @<aliases>}
+ Defines each @<alias> as being a type operator identical in behaviour to
+ @<original>. If @<original> is later redefined then the behaviour of the
+ @<alias>es changes too.
+\end{describe}
+
+\begin{describe}{mac}{%
+ define-c-type-syntax @<name> @<lambda-list> \\ \push
+ @<form>^* \-\\
+ @to @<name>}
+ Defines the symbol @<name> as a new type operator. When a list of the form
+ @|(@<name> @<argument>^*)| is used as a type specifier, the @<argument>s
+ are bound to fresh variables according to @<lambda-list> (a destructuring
+ lambda-list) and the @<form>s evaluated in order in the resulting lexical
+ environment as an implicit @|progn|. The value should be a Lisp form which
+ will evaluate to the type specified by the arguments.
+
+ The @<form>s may call @|expand-c-type-spec| in order to recursively expand
+ type specifiers among its arguments.
+\end{describe}
+
+\begin{describe}{fun}{expand-c-type-spec @<type-spec> @to @<form>}
+ Returns the Lisp form that @|(c-type @<type-spec>)| would expand into.
+\end{describe}
+
+\begin{describe}{gf}{%
+ print-c-type @<stream> @<type> \&optional @<colon> @<atsign>}
+ Print the C type object @<type> to @<stream> in S-expression form. The
+ @<colon> and @<atsign> arguments may be interpreted in any way which seems
+ appropriate: they are provided so that @|print-c-type| may be called via
+ @|format|'s @|\char`\~/\dots/| command; they are not set when
+ @|print-c-type| is called by Sod functions.
+
+ There should be a method defined for every C type class; there is no
+ default method.
+\end{describe}
+
+\subsection{Comparing C types} \label{sec:proto.c-types.cmp}
+
+It is necessary to compare C types for equality, for example when checking
+argument lists for methods. This is done by @|c-type-equal-p|.
+
+\begin{describe}{gf}{c-type-equal-p @<type>_1 @<type>_2 @to @<boolean>}
+ The generic function @|c-type-equal-p| compares two C types @<type>_1 and
+ @<type>_2 for equality; it returns true if the two types are equal and
+ false if they are not.
+
+ Two types are equal if they are structurally similar, where this property
+ is defined by methods for each individual class; see the descriptions of
+ the classes for the details.
+
+ The generic function @|c-type-equal-p| uses the @|and| method combination.
+
+ \begin{describe}{meth}{c-type-equal-p @<type>_1 @<type>_2}
+ A default primary method for @|c-type-equal-p| is defined. It simply
+ returns @|nil|. This way, methods can specialize on both arguments
+ without fear that a call will fail because no methods are applicable.
+ \end{describe}
+ \begin{describe}{ar-meth}{c-type-equal-p @<type>_1 @<type>_2}
+ A default around-method for @|c-type-equal-p| is defined. It returns
+ true if @<type>_1 and @<type>_2 are @|eql|; otherwise it delegates to the
+ primary methods. Since several common kinds of C types are interned,
+ this is a common case worth optimizing.
+ \end{describe}
+\end{describe}
+
+\subsection{Outputting C types} \label{sec:proto.c-types.output}
+
+\begin{describe}{gf}{pprint-c-type @<type> @<stream> @<kernel>}
+ The generic function @|pprint-c-type| pretty-prints to @<stream> a C-syntax
+ declaration of an object or function of type @<type>. The result is
+ written to @<stream>.
+
+ A C declaration has two parts: a sequence of \emph{declaration specifiers}
+ and a \emph{declarator}. The declarator syntax involves parentheses and
+ operators, in order to reflect the operators applicable to the declared
+ variable. For example, the name of a pointer variable is preceded by @`*';
+ the name of an array is followed by dimensions enclosed in @`['\dots @`]'.
+
+ The @<kernel> argument must be a function designator (though see the
+ standard around-method); it is invoked as
+ \begin{quote} \codeface
+ (funcall @<kernel> @<stream> @<priority> @<spacep>)
+ \end{quote}
+ It should write to @<stream> -- which may not be the same stream originally
+ passed into the generic function -- the `kernel' of the declarator, i.e.,
+ the part to which prefix and/or postfix operators are attached to form the
+ full declarator.
+
+ The methods on @|pprint-c-type| specialized for compound types work by
+ recursively calling @|pprint-c-type| on the subtype, passing down a closure
+ which prints the necessary additional declarator operators before calling
+ the original @<kernel> function. The additional arguments @<priority> and
+ @<spacep> support this implementation technique.
+
+ The @<priority> argument describes the surrounding operator context. It is
+ zero if no type operators are directly attached to the kernel (i.e., there
+ are no operators at all, or the kernel is enclosed in parentheses), one if
+ a prefix operator is directly attached, or two if a postfix operator is
+ directly attached. If the @<kernel> function intends to provide its own
+ additional declarator operators, it should check the @<priority> in order
+ to determine whether parentheses are necessary. See also the
+ @|maybe-in-parens| macro (page~\pageref{mac:maybe-in-parens}).
+
+ The @<spacep> argument indicates whether a space needs to be printed in
+ order to separate the declarator from the declaration specifiers. A kernel
+ which contains an identifier should insert a space before the identifier
+ when @<spacep> is non-nil. An `empty' kernel, as found in an abstract
+ declarator (one that specifies no name), looks more pleasing without a
+ trailing space. See also the @|c-type-space| function
+ (page~\pageref{fun:c-type-space}).
+
+ Every concrete subclass of @|c-type| is expected to provide a primary
+ method on this function. There is no default primary method.
+
+ \begin{describe}{ar-meth}{pprint-c-type @<type> @<stream> @<kernel>}
+ A default around method is defined on @|pprint-c-type| which `canonifies'
+ non-function @<kernel> arguments. In particular:
+ \begin{itemize}
+ \item if @<kernel> is nil, then @|pprint-c-type| is called recursively
+ with a @<kernel> function that does nothing; and
+ \item if @<kernel> is any other kind of object, then @|pprint-c-type| is
+ called recursively with a @<kernel> function that prints the object as
+ if by @|princ|, preceded if necessary by space using @|c-type-space|.
+ \end{itemize}
+ \end{describe}
+\end{describe}
+
+\begin{describe}{fun}{c-type-space @<stream>}
+ Writes a space and other pretty-printing instructions to @<stream> in order
+ visually to separate a declarator from the preceding declaration
+ specifiers. The precise details are subject to change.
+\end{describe}
+
+\begin{describe}{mac}{%
+ maybe-in-parens (@<stream-var> @<guard-form>) \\ \push
+ @<form>^*}
+ The @<guard-form> is evaluated, and then the @<form>s are evaluated in
+ sequence within a pretty-printer logical block writing to the stream named
+ by the symbol @<stream-var>. If the @<guard-form> evaluates to nil, then
+ the logical block has empty prefix and suffix strings; if it evaluates to a
+ non-nil value, then the logical block has prefix and suffix @`(' and @`)'
+ respectively.
+
+ Note that this may cause @<stream> to be bound to a different stream object
+ within the @<form>s.
+\end{describe}
+
+\subsection{Type qualifiers and qualifiable types}
+\label{sec:proto.ctypes.qual}
+
+\begin{describe}{cls}{qualifiable-c-type (c-type) \&key :qualifiers}
+ The class @|qualifiable-c-type| describes C types which can bear
+ `qualifiers' (\Cplusplus\ calls them `cv-qualifiers'): @|const|,
+ @|restrict| and @|volatile|.
+
+ The @<qualifiers> are a list of keyword symbols @|:const|, @|:restrict| and
+ @|:volatile|. There is no built-in limitation to these particular
+ qualifiers; others keywords may be used, though this isn't recommended.
+
+ Two qualifiable types are equal only if they have \emph{matching
+ qualifiers}: i.e., every qualifier attached to one is also attached to
+ the other: order is not significant, and neither is multiplicity.
+
+ The class @|qualifiable-c-type| is abstract.
+\end{describe}
+
+\begin{describe}{gf}{c-type-qualifiers @<type> @to @<list>}
+ Returns the qualifiers of the @|qualifiable-c-type| instance @<type> as an
+ immutable list.
+\end{describe}
+
+\begin{describe}{fun}{qualify-type @<type> @<qualifiers>}
+ The argument @<type> must be an instance of @|qualifiable-c-type|,
+ currently bearing no qualifiers, and @<qualifiers> a list of qualifier
+ keywords. The result is a C type object like @<c-type> except that it
+ bears the given @<qualifiers>.
+
+ The @<type> is not modified. If @<type> is interned, then the returned
+ type will be interned.
+\end{describe}
+
+\begin{describe}{fun}{format-qualifiers @<qualifiers>}
+ Returns a string containing the qualifiers listed in @<qualifiers> in C
+ syntax, with a space after each. In particular, if @<qualifiers> is
+ non-null then the final character of the returned string will be a space.
+\end{describe}
+
+\subsection{Leaf types} \label{sec:proto.c-types.leaf}
+
+A \emph{leaf type} is a type which is not defined in terms of another type.
+In Sod, the leaf types are
+\begin{itemize}
+\item \emph{simple types}, including builtin types like @|int| and @|char|,
+ as well as type names introduced by @|typename|, because Sod isn't
+ interested in what the type name means, merely that it names a type; and
+\item \emph{tagged types}, i.e., enum, struct and union types which are named
+ by a keyword identifying the kind of type, and a \emph{tag}.
+\end{itemize}
+
+\begin{describe}{cls}{simple-c-type (qualifiable-c-type)
+ \&key :qualifiers :name}
+ The class of `simple types'; an instance denotes the type @<qualifiers>
+ @<name>.
+
+ A simple type object maintains a \emph{name}, which is a string whose
+ contents are the C name for the type. The initarg @|:name| may be used to
+ provide this name when calling @|make-instance|.
+
+ Two simple type objects are equal if and only if they have @|string=| names
+ and matching qualifiers.
+
+ A number of symbolic type specifiers for builtin types are predefined as
+ shown in \xref{tab:proto.c-types.simple}. These are all defined as if by
+ @|define-simple-c-type|, so can be used to construct qualified types.
+\end{describe}
+
+\begin{table}
+ \begin{tabular}[C]{|l|l|} \hlx{hv}
+ \textbf{C type} & \textbf{Specifiers} \\ \hlx{vhv}
+ @|void| & @|void| \\ \hlx{vhv}
+ @|char| & @|char| \\ \hlx{v}
+ @|unsigned char| & @|unsigned-char|, @|uchar| \\ \hlx{v}
+ @|signed char| & @|signed-char|, @|schar| \\ \hlx{vhv}
+ @|short| & @|short|, @|signed-short|, @|short-int|,
+ @|signed-short-int| @|sshort| \\ \hlx{v}
+ @|unsigned short| & @|unsigned-short|, @|unsigned-short-int|,
+ @|ushort| \\ \hlx{vhv}
+ @|int| & @|int|, @|signed|, @|signed-int|,
+ @|sint| \\ \hlx{v}
+ @|unsigned int| & @|unsigned|, @|unsigned-int|, @|uint| \\ \hlx{vhv}
+ @|long| & @|long|, @|signed-long|, @|long-int|,
+ @|signed-long-int|, @|slong| \\ \hlx{v}
+ @|unsigned long| & @|unsigned-long|, @|unsigned-long-int|,
+ @|ulong| \\ \hlx{vhv}
+ @|long long| & @|long-long|, @|signed-long-long|,
+ @|long-long-int|, \\
+ & \qquad @|signed-long-long-int|,
+ @|llong|, @|sllong| \\ \hlx{v}
+ @|unsigned long long|
+ & @|unsigned-long-long|, @|unsigned-long-long-int|,
+ @|ullong| \\ \hlx{vhv}
+ @|float| & @|float| \\ \hlx{v}
+ @|double| & @|double| \\ \hlx{vhv}
+ @|va_list| & @|va-list| \\ \hlx{v}
+ @|size_t| & @|size-t| \\ \hlx{v}
+ @|ptrdiff_t| & @|ptrdiff-t| \\ \hlx{vh}
+ \end{tabular}
+ \caption{Builtin symbolic type specifiers for simple C types}
+ \label{tab:proto.c-types.simple}
+\end{table}
+
+\begin{describe}{fun}{make-simple-type @<name> \&optional @<qualifiers>}
+ Return the (unique interned) simple C type object for the C type whose name
+ is @<name> (a string) and which has the given @<qualifiers> (a list of
+ keywords).
+\end{describe}
+
+\begin{describe}{gf}{c-type-name @<type>}
+ Returns the name of a @|simple-c-type| instance @<type> as an immutable
+ string.
+\end{describe}
+
+\begin{describe}{mac}{%
+ define-simple-c-type @{ @<name> @! (@<name>^*) @} @<string>}
+ Define type specifiers for a new simple C type. Each symbol @<name> is
+ defined as a symbolic type specifier for the (unique interned) simple C
+ type whose name is the value of @<string>. Further, each @<name> is
+ defined to be a type operator: the type specifier @|(@<name>
+ @<qualifier>^*)| evaluates to the (unique interned) simple C type whose
+ name is @<string> and which has the @<qualifiers> (which are evaluated).
+\end{describe}
+
+\begin{describe}{cls}{tagged-c-type (qualifiable-c-type)
+ \&key :qualifiers :tag}
+ Provides common behaviour for C tagged types. A @<tag> is a string
+ containing a C identifier.
+
+ Two tagged types are equal if and only if they have the same class, their
+ @<tag>s are @|string=|, and they have matching qualifiers. (User-defined
+ subclasses may have additional methods on @|c-type-equal-p| which impose
+ further restrictions.)
+\end{describe}
+\begin{boxy}[Bug]
+ Sod maintains distinct namespaces for the three kinds of tagged types. In
+ C, there is only one namespace for tags which is shared between enums,
+ structs and unions.
+\end{boxy}
+
+\begin{describe}{gf}{c-tagged-type-kind @<type>}
+ Returns a symbol classifying the tagged @<type>: one of @|enum|, @|struct|
+ or @|union|. User-defined subclasses of @|tagged-c-type| should return
+ their own classification symbols. It is intended that @|(string-downcase
+ (c-tagged-type-kind @<type>))| be valid C syntax.\footnote{%
+ Alas, C doesn't provide a syntactic category for these keywords;
+ \Cplusplus\ calls them a @<class-key>.} %
+\end{describe}
+
+\begin{describe}{cls}{c-enum-type (tagged-c-type) \&key :qualifiers :tag}
+ Represents a C enumerated type. An instance denotes the C type @|enum|
+ @<tag>. See the direct superclass @|tagged-c-type| for details.
+
+ The type specifier @|(enum @<tag> @<qualifier>^*)| returns the (unique
+ interned) enumerated type with the given @<tag> and @<qualifier>s (all
+ evaluated).
+\end{describe}
+\begin{describe}{fun}{make-enum-type @<tag> \&optional @<qualifiers>}
+ Return the (unique interned) C type object for the enumerated C type whose
+ tag is @<tag> (a string) and which has the given @<qualifiers> (a list of
+ keywords).
+\end{describe}
+
+\begin{describe}{cls}{c-struct-type (tagged-c-type) \&key :qualifiers :tag}
+ Represents a C structured type. An instance denotes the C type @|struct|
+ @<tag>. See the direct superclass @|tagged-c-type| for details.
+
+ The type specifier @|(struct @<tag> @<qualifier>^*)| returns the (unique
+ interned) structured type with the given @<tag> and @<qualifier>s (all
+ evaluated).
+\end{describe}
+\begin{describe}{fun}{make-struct-type @<tag> \&optional @<qualifiers>}
+ Return the (unique interned) C type object for the structured C type whose
+ tag is @<tag> (a string) and which has the given @<qualifiers> (a list of
+ keywords).
+\end{describe}
+
+\begin{describe}{cls}{c-union-type (tagged-c-type) \&key :qualifiers :tag}
+ Represents a C union type. An instance denotes the C type @|union|
+ @<tag>. See the direct superclass @|tagged-c-type|
+ for details.
+
+ The type specifier @|(union @<tag> @<qualifier>^*)| returns the (unique
+ interned) union type with the given @<tag> and @<qualifier>s (all
+ evaluated).
+\end{describe}
+\begin{describe}{fun}{make-union-type @<tag> \&optional @<qualifiers>}
+ Return the (unique interned) C type object for the union C type whose tag
+ is @<tag> (a string) and which has the given @<qualifiers> (a list of
+ keywords).
+\end{describe}
+
+\subsection{Pointers and arrays} \label{sec:proto.c-types.ptr-array}
+
+Pointers and arrays are \emph{compound types}: they're defined in terms of
+existing types. A pointer describes the type of objects it points to; an
+array describes the type of array element.
+\begin{describe}{gf}{c-type-subtype @<type>}
+ Returns the underlying type of a compound type @<type>. Precisely what
+ this means depends on the class of @<type>.
+\end{describe}
+
+\begin{describe}{cls}{c-pointer-type (qualifiable-c-type)
+ \&key :qualifiers :subtype}
+ Represents a C pointer type. An instance denotes the C type @<subtype>
+ @|*|@<qualifiers>.
+
+ The @<subtype> may be any C type. Two pointer types are equal if and only
+ if their subtypes are equal and they have matching qualifiers.
+
+ The type specifier @|(* @<type-spec> @<qualifier>^*)| returns a type
+ qualified pointer-to-@<subtype>, where @<subtype> is the type specified by
+ @<type-spec> and the @<qualifier>s are qualifier keywords (which are
+ evaluated). The synonyms @|ptr| and @|pointer| may be used in place of the
+ star @`*'.
+
+ The symbol @|string| is a type specifier for the type of pointer to
+ characters; the symbol @|const-string| is a type specifier for the type
+ pointer to constant characters.
+\end{describe}
+\begin{describe}{fun}{make-pointer-type @<subtype> \&optional @<qualifiers>}
+ Return an object describing the type of qualified pointers to @<subtype>.
+ If @<subtype> is interned, then the returned pointer type object is
+ interned also.
+\end{describe}
+
+\begin{describe}{cls}{c-array-type (c-type) \&key :subtype :dimensions}
+ Represents a multidimensional C array type. The @<dimensions> are a list
+ of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then
+ denotes the C type @<subtype> @|[$d_0$][$d_1$]$\ldots$[$d_{n-1}$]|. An
+ individual dimension specifier is either a string containing a C integral
+ constant expression, or nil which is equivalent to an empty string. Only
+ the first (outermost) dimension $d_0$ should be empty.
+
+ C doesn't actually have multidimensional arrays as a primitive notion;
+ rather, it permits an array (with known extent) to be the element type of
+ an array, which achieves an equivalent effect. C arrays are stored in
+ row-major order: i.e., if we write down the indices of the elements of an
+ array in order of ascending address, the rightmost index varies fastest;
+ hence, the type constructed is more accurately an array of $d_0$ arrays of
+ $d_1$ of \ldots\ arrays of $d_{n-1}$ elements of type @<subtype>. We shall
+ continue to abuse terminology and refer to multidimensional arrays.
+
+ The type specifier @|([] @<type-spec> @<dimension>^*)| constructs a
+ multidimensional array with the given @<dimension>s whose elements have the
+ type specified by @<type-spec>. If no dimensions are given then a
+ single-dimensional array with unspecified extent. The synonyms @|array|
+ and @|vector| may be used in place of the brackets @`[]'.
+\end{describe}
+\begin{describe}{fun}{make-array-type @<subtype> @<dimensions>}
+ Return an object describing the type of arrays with given @<dimensions> and
+ with element type @<subtype> (an instance of @|c-type|). The @<dimensions>
+ argument is a list whose elements are strings or nil; see the description
+ of the class @|c-array-type| above for details.
+\end{describe}
+\begin{describe}{gf}{c-array-dimensions @<type>}
+ Returns the dimensions of @<type>, an array type, as an immutable list.
+\end{describe}
+
+\subsection{Function types} \label{sec:proto.c-types.fun}
+
+\begin{describe}{cls}{c-function-type (c-type) \&key :subtype :arguments}
+ Represents C function types. An instance denotes the C type of a C
+ function which
+\end{describe}
+
+%%%----- That's all, folks --------------------------------------------------
+
+%%% Local variables:
+%%% mode: LaTeX
+%%% TeX-master: "sod.tex"
+%%% TeX-PDF-mode: t
+%%% End:
\usepackage[palatino, helvetica, courier, maths=cmr]{mdwfonts}
\usepackage{syntax}
\usepackage{sverb}
+\usepackage{mdwtab}
+\usepackage{footnote}
\usepackage{at}
\usepackage{mdwref}
\title{A Sensible Object Design for C}
\author{Mark Wooding}
+\makeatletter
+
+\errorcontextlines999
+
\def\syntleft{\normalfont\itshape}
\let\syntright\empty
-\def\ulitleft{\normalfont\sffamily}
+\let\codeface\sffamily
+
+\def\ulitleft{\normalfont\codeface}
\let\ulitright\empty
\let\listingsize\relax
\let\epsilon\varepsilon
-\atdef <#1>{\synt{#1}}
-\atdef "#1"{\lit*{#1}}
-\atdef `#1'{\lit{#1}}
-\atdef |#1|{\textsf{#1}}
-
-\def\Cplusplus{C\kern-1pt++}
+\atdef <#1>{\synt{#1}\@scripts}
+\atdef "#1"{\lit*{#1}\@scripts}
+\atdef `#1'{\lit{#1}\@scripts}
+\atdef |#1|{\textsf{#1}\@scripts}
+\def\dbl@maybe#1{\let\@tempa#1\futurelet\@ch\dbl@maybe@i}
+\def\dbl@maybe@i{\m@maybe\ifx\@ch\@tempa\@tempa\!\@tempa%
+ \expandafter\@firstoftwo\expandafter\@scripts%
+ \else\@tempa\expandafter\@scripts\fi}
+\atdef [{\dbl@maybe[}
+\atdef ]{\dbl@maybe]}
+\atdef {{\m@maybe\{\@scripts}
+\atdef }{\m@maybe\}\@scripts}
+\atdef ({\m@maybe(\@scripts}
+\atdef ){\m@maybe)\@scripts}
+\atdef !{\m@maybe|\@scripts}
+\atdef to{\leavevmode\unskip\quad\m@maybe\longrightarrow\m@maybe@end\quad}
+\let\m@maybe@end\relax
+\def\m@maybe{\ifmmode\else$\let\m@maybe@end$\fi}
+\def\@scripts{\futurelet\@ch\@scripts@i}
+
+\atdef ;#1\\{\normalfont\itshape;#1\\}
+
+\begingroup\lccode`\~=`\_\lowercase{\endgroup
+\def\@scripts@i{\if1\ifx\@ch~1\else\ifx\@ch^1\else0\fi\fi%
+ \expandafter\@scripts@ii\else\expandafter\m@maybe@end\fi}}
+\def\@scripts@ii#1#2{\m@maybe#1{#2}\@scripts}
+
+\def\Cplusplus{C\kern-\p@++}
\def\Csharp{C\#}
\def\man#1#2{\textbf{#1}(#2)}
\lowercase{
\endgroup
\def\prog{%
- \sffamily%
+ \codeface%
\quote%
- \let\oldnl\\%
+ \let\old@nl\\%
\obeylines%
\tabbing%
\global\let~\\%
}
\def\endprog{%
\endtabbing%
- \global\let\\\oldnl%
+ \global\let\\\old@nl%
\endquote%
}}
+\newenvironment{boxy}[1][\q@]{%
+ \dimen@\linewidth\advance\dimen@-1.2pt\advance\dimen@-2ex%
+ \medskip%
+ \vbox\bgroup\hrule\hbox\bgroup\vrule%
+ \vbox\bgroup\vskip1ex\hbox\bgroup\hskip1ex\minipage\dimen@%
+ \def\@temp{#1}\ifx\@temp\q@\else\leavevmode{\headfam\bfseries#1\quad}\fi%
+}{%
+ \endminipage\hskip1ex\egroup\vskip1ex\egroup%
+ \vrule\egroup\hrule\egroup%
+ \medskip%
+}
+
+\def\definedescribecategory#1#2{\@namedef{cat!#1}{#2}}
+\def\describecategoryname#1{%
+ \expandafter\let\expandafter\@tempa\csname cat!#1\endcsname%
+ \ifx\@tempa\relax#1\else\@tempa\fi}
+\definedescribecategory{fun}{function}
+\definedescribecategory{gf}{generic function}
+\definedescribecategory{var}{variable}
+\definedescribecategory{const}{constant}
+\definedescribecategory{meth}{primary method}
+\definedescribecategory{ar-meth}{around-method}
+\definedescribecategory{be-meth}{before-method}
+\definedescribecategory{af-meth}{after-method}
+\definedescribecategory{cls}{class}
+\definedescribecategory{ty}{type}
+\definedescribecategory{mac}{macro}
+
+\def\q@{\q@}
+\newenvironment{describe}[3][\q@]{%
+ \normalfont%
+ \par\goodbreak%
+ \vspace{\bigskipamount}%
+ \setbox\z@\hbox{\bfseries[\describecategoryname{#2}]}%
+ \dimen@\linewidth\advance\dimen@-\wd\z@%
+ \def\@temp##1 ##2\q@{\message{#2:##1}\label{#2:##1}}%
+ \def\@tempa{#1}\ifx\@tempa\q@\@temp#3 \q@\else\@temp{#1} \\\fi%
+ \edef\@temp{{\the\linewidth}{@{}p{\the\dimen@}%
+ @{\extracolsep{\fill}}l@{\extracolsep{0pt}}}}%
+ \noindent\csname tabular*\expandafter\endcsname\@temp%
+ \tabbing\codeface#3\endtabbing&\unhbox\z@\\\endtabular%
+% \@afterheading%
+ \list{}{\rightmargin\z@}\item%
+}{%
+ \endlist%
+}
+
+\def\push{\quad\=\+\kill}
+
\begin{document}
\maketitle
--- /dev/null
+(dolist (entry '((parse 0)
+ (many 1)
+ (skip-many 1)
+ (seq 1)
+ (lisp 0)
+ (if-parse 2)
+ (if-char 2)
+ (expr 1)
+ (acond . cond)
+ (define-class-slot 3)))
+ (put (car entry) 'common-lisp-indent-function
+ (if (symbolp (cdr entry))
+ (get (cdr entry) 'common-lisp-indent-function)
+ (cadr entry))))
\ No newline at end of file
+++ /dev/null
-* Instance layout
-
-This is fairly easy. The superclasses are partitioned into chains.
-Each chain is named after its head class (i.e., the class with no
-successor).
-
-** Things in instance layouts
-
-An instance layout contains a chunk for each component chain.
-
- struct CLASS__ilayout {
- struct CLASS__ichain_CHAINn NICKn;
- /* ... */
- };
-
-An ilayout is a C structure consisting of an ichain for each of the
-class's chains, with the primary chain first. The others are in
-direct-superclass order.
-
-** Instance slots
-
-An islots structure is a C structure consisting of a class's instance
-slots, in order.
-
- struct CLASS__islots {
- TYPEn SLOTn;
- /* ... */
- };
-
-If a class defines no slots then it has no islots structure.
-
-** Instance chains
-
- struct CLASS__ichain_CHAIN {
- const struct CLASS__vt_CHAIN *_vt;
- struct SUPERn__islots NICKn;
- /* ... */
- };
-
-A ichain is a C structure consisting of:
-
- * A pointer `_vt' to the chain's vtable structure.
-
- * An islots substructure, named after the class's nick for each class
- on the chain, least-specific first.
-
-Because of the chain invariant, all of a class's ichains are prefixes of
-the corresponding ichains of any of its subclasses.
-
-The type CLASS is an alias for the class's primary ichain
-CLASS__ichain_CHAIN. One needs to do a cross-chain upcast to find slots
-in non-primary chains.
-
-* Vtable layout
-
-This is more complicated. The vtable for a chain doesn't just contain
-things directly relevant to the classes on the chain: because a vtable
-is (assumed) immutable, we can have copies of values from other chains
-where this is convenient.
-
-Note that effective methods are customized for particular classes: they
-can assume that their argument points to a specific ichain of a an
-instance of a specific class. This makes conversions in effective
-methods very cheap. By including apparently effective-method pointers
-for messages defined in other chains, we can speed up dispatch.
-
-** Things in a vtable chain
-
-There are three kinds of items to store in a vtable chain.
-
- * Class pointers
- * The base offset
- * Chain offsets
- * Effective method pointers
-
- struct CLASS__vt_CHAIN {
- struct METACLASS__ichain_sod_object *_class;
- size_t _base;
- struct METACLASS__ichain_METACHAINn *_cls_NICKn;
- ptrdiff_t _off_CHAINn;
- struct SUPERn__vtmsgs NICKn;
- };
-
-A class has a separate vtable chain for each of its chains.
-
-** The base offset
-
-There is a single member _base which is the offset of the chain's ichain
-in the overall ilayout structure. This lets you find the bottom of the
-ilayout given a pointer to any ichain as
-
- (CLASS__ilayout *)((char *)p - p->_vt._base)
-
-** Class pointers
-
-The class's metaclass may have multiple chains. For each chain of the
-metaclass, there is a separate pointer to that metaclass's ichain, named
-_cls_NICKn after the metaclass's chain head. Exception: _cls_cls is
-called _class instead.
-
-** Chain offsets
-
-For each other chain, there is a member _off_NICKn named after the
-chain's head giving the offset of that ichain from the current chain's
-ichain. (There's a long way around, exploring the class's layout
-information, but this provides a much easier way of doing cross-chain
-upcasts.)
-
-** Effective method pointers
-
-For each class, there may be a structure
-
- struct CLASS__vtmsgs {
- TYPEn (*MSGn)(ARGnn *, ...);
- /* ... */
- };
-
-of pointers to effective methods for the messages defined by the class.
-If a class defines no messages then it won't have a vtmsgs structure.
-
-** Layout order
-
-The first two items are always _class and _base. After that:
-
- * for each class in the chain, from least to most specific,
-
- * for each of that class's superclasses, in reverse class-precedence-
- list order, which has not yet been processed:
-
- * if the class is in a chain which hasn't been seen before (it must be
- the chain head!), emit a chain offset for it;
-
- * if the class has a metaclass chain which hasn't been seen before,
- emit a class pointer for it;
-
- * if the class has a vtmsgs structure, emit it.
-
-* Questions
-
-Are class-slot initializers inherited? No. We have instance
-initializers on metaclasses for that.
/*----- Licensing notice --------------------------------------------------*
*
- * This file is part of the Simple Object Definition system.
+ * 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
* Returns: Nonzero if @sub@ is a subclass of @super@.
*/
-int sod_subclassp(const SodClass *c, const SodClass *d)
- { return (!!find_chain(c, d)); }
+int sod_subclassp(const SodClass *sub, const SodClass *super)
+ { return (!!find_chain(sub, super)); }
/* --- @sod_convert@ --- *
*
/*----- Licensing notice --------------------------------------------------*
*
- * This file is part of the Simple Object Definition system.
+ * 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
* pointer to one of these.
*/
struct sod_vtable {
- SodClass *_class; /* Pointer to class object */
+ const SodClass *_class; /* Pointer to class object */
size_t _base; /* Offset to instance base */
};
/* --- @sod_subclassp@ --- *
*
- * Arguments: @const SodClass *c, *d@ = pointers to two classes
+ * Arguments: @const SodClass *sub, *super@ = pointers to two classes
*
* Returns: Nonzero if @c@ is a subclass of @d@.
*/
-extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/);
+extern int sod_subclassp(const SodClass */*sub*/, const SodClass */*super*/);
/* --- @sod_convert@ --- *
*
* Use: General down/cross-casting function.
*
* Upcasts can be performed efficiently using the automatically
- * generated macros. In particular, upcasts with a chain are
+ * generated macros. In particular, upcasts within a chain are
* trivial; cross-chain upcasts require information from vtables
* but are fairly fast. This function is rather slower, but is
* much more general.
*
* Suppose we have an instance of a class C, referred to by a
- * pointer to an instance of one of C's superclasses S. If S'
+ * pointer to an instance of one of C's superclasses S. If T
* is some other superclass of C then this function will return
- * a pointer to C suitable for use as an instance of S'. If S'
+ * a pointer to C suitable for use as an instance of T. If T
* is not a superclass of C, then the function returns null.
* (If the pointer doesn't point to an instance of some class
* then the behaviour is undefined.) Note that you don't need
- * to know what C or S actually are.
+ * to know what either C or S actually are.
*/
extern void *sod_convert(const SodClass */*cls*/, void */*p*/);
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output driver for SOD translator
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; Sequencing machinery.
-
-(defclass sequencer-item ()
- ((name :initarg :name :reader sequencer-item-name)
- (functions :initarg :functions :initform nil
- :type list :accessor sequencer-item-functions))
- (:documentation
- "Represents a distinct item to be sequenced by a SEQUENCER.
-
- A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
- sequencer is invoked. This class is not intended to be subclassed."))
-
-(defmethod print-object ((item sequencer-item) stream)
- (print-unreadable-object (item stream :type t)
- (prin1 (sequencer-item-name item) stream)))
-
-(defclass sequencer ()
- ((constraints :initarg :constraints :initform nil
- :type list :accessor sequencer-constraints)
- (table :initform (make-hash-table :test #'equal)
- :reader sequencer-table))
- (:documentation
- "A sequencer tracks items and invokes them in the proper order.
-
- The job of a SEQUENCER object is threefold. Firstly, it collects
- sequencer items and stores them in its table indexed by name. Secondly,
- it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly,
- it can be instructed to invoke the items in an order compatible with the
- established constraints.
-
- Sequencer item names may may any kind of object which can be compared with
- EQUAL. In particular, symbols, integers and strings are reasonable
- choices for atomic names, and lists work well for compound names -- so
- it's possible to construct a hierarchy."))
-
-(defgeneric ensure-sequencer-item (sequencer name)
- (:documentation
- "Arrange that SEQUENCER has a sequencer-item called NAME.
-
- Returns the corresponding SEQUENCER-ITEM object."))
-
-(defgeneric add-sequencer-constraint (sequencer constraint)
- (:documentation
- "Attach the given CONSTRAINT to an SEQUENCER.
-
- The CONSTRAINT should be a list of sequencer-item names; see
- ENSURE-SEQUENCER-ITEM for what they look like. Note that the names
- needn't have been declared in advance; indeed, they needn't be mentioned
- anywhere else at all."))
-
-(defgeneric add-sequencer-item-function (sequencer name function)
- (:documentation
- "Arranges to call FUNCTION when the item called NAME is traversed.
-
- More than one function can be associated with a given sequencer item.
- They are called in the same order in which they were added.
-
- Note that an item must be mentioned in at least one constraint in order to
- be traversed by INVOKE-SEQUENCER-ITEMS. If there are no special ordering
- requirments for a particular item, then the trivial constraint (NAME) will
- suffice."))
-
-(defgeneric invoke-sequencer-items (sequencer &rest arguments)
- (:documentation
- "Invoke functions attached to the SEQUENCER's items in the right order.
-
- Each function is invoked in turn with the list of ARGUMENTS. The return
- values of the functions are discarded."))
-
-(defmethod ensure-sequencer-item ((sequencer sequencer) name)
- (with-slots (table) sequencer
- (or (gethash name table)
- (setf (gethash name table)
- (make-instance 'sequencer-item :name name)))))
-
-(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
- (let ((converted-constraint (mapcar (lambda (name)
- (ensure-sequencer-item sequencer
- name))
- constraint)))
- (with-slots (constraints) sequencer
- (pushnew converted-constraint constraints :test #'equal))))
-
-(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
- (let ((item (ensure-sequencer-item sequencer name)))
- (pushnew function (sequencer-item-functions item))))
-
-(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
- (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
- (dolist (function (reverse (sequencer-item-functions item)))
- (apply function arguments))))
-
-;;;--------------------------------------------------------------------------
-;;; Output preparation.
-
-(defgeneric add-output-hooks (object reason sequencer)
- (:documentation
- "Announces the intention to write SEQUENCER, with a particular REASON.
-
- The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
- can be matched using an EQL-specializer. In response, OBJECT should add
- any constrains and item functions that it wishes, and pass the
- announcement to its sub-objects.")
- (:method-combination progn)
- (:method progn (object reason sequencer)
- nil))
-
-(defvar *seen-announcement*) ;Keep me unbound!
-#+hmm
-(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
- "Arrange not to invoke any object more than once during a particular
- announcement."
- (declare (ignore stuff))
- (cond ((not (boundp '*seen-announcement*))
- (let ((*seen-announcement* (make-hash-table)))
- (setf (gethash object *seen-announcement*) t)
- (call-next-method)))
- ((gethash object *seen-announcement*)
- nil)
- (t
- (setf (gethash object *seen-announcement*) t)
- (call-next-method))))
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Header output.
-
-(defun write-module-header (module)
- (let* ((file (merge-pathnames (make-pathname :type "H" :case :common)
- (module-name module)))
- (fakename (make-pathname :name (pathname-name file)
- :type (pathname-type file))))
- (with-open-file (uoutput file
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (let ((output (make-instance 'position-aware-output-stream
- :stream uoutput
- :file fakename)))
-
- ;; Format the header and guards.
- (format output "~
-/* -*-c-*-
- *
- * Header file generated by SOD for ~A
- */
-
-#ifndef ~A
-#define ~:*~A
-
-#ifdef __cplusplus
- extern \"C\" {
-#endif~%"
- (namestring (module-name module))
- (or (getf (module-plist module) 'include-guard)
- ))
-
- ;; Forward declarations of all the structures and types. Nothing
- ;; interesting gets said here; this is just so that the user code
- ;; can talk meainingfully about the things we're meant to be
- ;; defining here.
- ;;
- ;; FIXME
-
- ;; The user fragments.
- (when (module-header-fragments module)
- (banner "User code" output)
- (dolist (frag (module-header-fragments module))
- (princ frag output)))
-
- ;; The definitions of the necessary structures.
- ;;
- ;; FIXME
-
- ;; The definitions of the necessary direct-methods.
- ;;
- ;; FIXME
-
- ;; The trailer section.
- (banner "That's all, folks" output)
- (format output "~
-#ifdef __cplusplus
- }
-#endif
-
-#endif~%")))))
-
-;;;--------------------------------------------------------------------------
-;;; Source output.
-
-(defun write-module-source (module)
- (let* ((file (merge-pathnames (make-pathname :type "C" :case :common)
- (module-name module)))
- (fakename (make-pathname :name (pathname-name file)
- :type (pathname-type file))))
- (with-open-file (uoutput file
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (let ((output (make-instance 'position-aware-output-stream
- :stream uoutput
- :file fakename)))
-
- ;; Format the header.
- (format output "~
-/* -*-c-*-
- *
- * Source file generated by SOD for ~A
- */~%"
- (namestring (module-name module)))
-
- ;; The user fragments.
- (when (module-source-fragments module)
- (banner "User code" output)
- (dolist (frag (module-source-fragments module))
- (princ frag output)))
-
- ;; The definitions of the necessary tables.
- ;;
- ;; FIXME
-
- ;; The definitions of the necessary effective-methods.
- ;;
- ;; FIXME
-
- ;; The trailer section.
- (banner "That's all, folks" output :blank-line-p nil)))))
-
-;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Builtin module provides basic definitions
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(define-sod-class "AbstractStack" ("SodObject")
+ :nick 'abstk
+ (message "emptyp" (fun int))
+ (message "push" (fun void ("item" (* void))))
+ (message "pop" (fun (* void)))
+ (method "abstk" "pop" (fun void) #{
+ assert(!me->_vt.emptyp());
+ }
+ :role :before))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Dealing with C types
+;;;
+;;; (c) 2008 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Plain old C types.
+
+;; Class definition.
+
+;; Important protocol.
+
+;; Utility functions and macros.
+
+;; S-expression syntax machinery.
+
+;; Basic definitions.
+
+;; A handy utility.
+
+;;;--------------------------------------------------------------------------
+;;; Simple C types (e.g., built-in arithmetic types).
+
+;; Basic definitions.
+
+(let ((cache (make-hash-table :test #'equal)))
+
+;;;--------------------------------------------------------------------------
+;;; Tag types (structs, unions and enums).
+
+;; Definitions.
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+;; Definitions.
+
+(let ((cache (make-hash-table :test #'eql)))
+
+;; S-expression syntax.
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+;; Definitions.
+
+
+;;;--------------------------------------------------------------------------
+;;; Function types.
+
+;; Arguments.
+
+;; Definitions.
+
+;; S-expression syntax.
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Equipment for building classes and friends
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Finding things by name
+
+(defun find-superclass-by-nick (class nick)
+ "Returns the superclass of CLASS with nickname NICK, or signals an error."
+
+ ;; Slightly tricky. The class almost certainly hasn't been finalized, so
+ ;; trundle through its superclasses and hope for the best.
+ (if (string= nick (sod-class-nickname class))
+ class
+ (or (some (lambda (super)
+ (find nick (sod-class-precedence-list super)
+ :key #'sod-class-nickname
+ :test #'string=))
+ (sod-class-direct-superclasses class))
+ (error "No superclass of `~A' with nickname `~A'" class nick))))
+
+(flet ((find-item-by-name (what class list name key)
+ (or (find name list :key key :test #'string=)
+ (error "No ~A in class `~A' with name `~A'" what class name))))
+
+ (defun find-instance-slot-by-name (class super-nick slot-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-item-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-class-slot-by-name (class super-nick slot-name)
+ (let* ((meta (sod-class-metaclass class))
+ (super (find-superclass-by-nick meta super-nick)))
+ (find-item-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-message-by-name (class super-nick message-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-item-by-name "message" super (sod-class-messages super)
+ message-name #'sod-message-name))))
+
+;;;--------------------------------------------------------------------------
+;;; Class construction.
+
+(defun make-sod-class (name superclasses pset &optional location)
+ "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
+
+ This is the main constructor function for classes. The protocol works as
+ follows. The :LISP-CLASS property in PSET is checked: if it exists, it
+ must be a symbol naming a (CLOS) class, which is used in place of
+ SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further
+ behaviour is left to the standard CLOS instance construction protocol; for
+ example, SOD-CLASS defines an :AFTER-method on 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."
+
+ (with-default-error-location (location)
+ (let ((class (make-instance (get-property pset :lisp-class :symbol
+ 'sod-class)
+ :name name
+ :superclasses superclasses
+ :location (file-location location)
+ :pset pset)))
+ (check-unused-properties pset)
+ class)))
+
+(defgeneric guess-metaclass (class)
+ (:documentation
+ "Determine a suitable metaclass for the CLASS.
+
+ The default behaviour is to choose the most specific metaclass of any of
+ the direct superclasses of CLASS, or to signal an error if that failed."))
+
+;;;--------------------------------------------------------------------------
+;;; Slot construction.
+
+(defgeneric make-sod-slot (class name type pset &optional location)
+ (:documentation
+ "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
+
+ This is the main constructor function for slots. This is a generic
+ function primarily so that the CLASS can intervene in the construction
+ process. The default method uses the :LISP-CLASS property (defaulting 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."))
+
+;;;--------------------------------------------------------------------------
+;;; Slot initializer construction.
+
+;;;--------------------------------------------------------------------------
+;;; Message construction.
+
+;;;--------------------------------------------------------------------------
+;;; Method construction.
+
+;;;--------------------------------------------------------------------------
+;;; Builder macros.
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class finalization
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Class finalization.
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Layout for instances and vtables
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slot objects.
+
+(defclass effective-slot ()
+ ((class :initarg :class :type sod-slot :reader effective-slot-class)
+ (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
+ (initializer :initarg :initializer :type (or sod-initializer null)
+ :reader effective-slot-initializer))
+ (:documentation
+ "Describes a slot and how it's meant to be initialized.
+
+ Effective slot objects are usually attached to layouts."))
+
+(defgeneric find-slot-initializer (class slot)
+ (:documentation
+ "Return the most specific initializer for SLOT, starting from CLASS."))
+
+(defgeneric compute-effective-slot (class slot)
+ (:documentation
+ "Construct an effective slot from the supplied direct slot.
+
+ SLOT is a direct slot defined on CLASS or one of its superclasses.
+ (Metaclass initializers are handled using a different mechanism.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout objects.
+
+(defclass islots ()
+ ((class :initarg :class :type sod-class :reader islots-class)
+ (subclass :initarg :subclass :type sod-class :reader islots-subclass)
+ (slots :initarg :slots :type list :reader islots-slots))
+ (:documentation
+ "The collection of effective SLOTS defined by an instance of CLASS."))
+
+;;; Standard implementation.
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+;;; base-offset
+
+;;; chain-offset
+
+;;; vtable
+
+;;; Implementation.
+
+;;;----- That's all, folks --------------------------------------------------
(cl:in-package #:sod)
-;;;--------------------------------------------------------------------------
-;;; Utility macro.
-
-(defmacro sequence-output
- ((streamvar sequencer) &body clauses)
- (let ((seqvar (gensym "SEQ")))
- (labels ((convert-item-name (name)
- (if (listp name)
- (cons 'list name)
- name))
- (convert-constraint (constraint)
- (cons 'list (mapcar #'convert-item-name constraint)))
- (process-body (clauses)
- (if (eq (car clauses) :constraint)
- (cons `(add-sequencer-constraint
- ,seqvar
- ,(convert-constraint (cadr clauses)))
- (process-body (cddr clauses)))
- (mapcar (lambda (clause)
- (let ((name (car clause))
- (body (cdr clause)))
- `(add-sequencer-item-function
- ,seqvar
- ,(convert-item-name name)
- (lambda (,streamvar)
- ,@body))))
- clauses))))
- `(let ((,seqvar ,sequencer))
- ,@(process-body clauses)))))
-
;;;--------------------------------------------------------------------------
;;; Classes.
-(defmethod add-output-hooks progn
- ((class sod-class) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :h))
+ sequencer)
;; Main output sequencing.
(sequence-output (stream sequencer)
;; Maybe generate an islots structure.
(when (sod-class-slots class)
(dolist (slot (sod-class-slots class))
- (add-output-hooks slot 'populate-islots sequencer))
+ (hook-output slot 'islots sequencer))
(sequence-output (stream sequencer)
((class :islots :start)
(format stream "/* Instance slots. */~@
(terpri stream)))))
;; Generate vtmsgs structure for all superclasses.
- (add-output-hooks (car (sod-class-vtables class))
- 'populate-vtmsgs
+ (hook-output (car (sod-class-vtables class))
+ 'vtmsgs
sequencer))
-(defmethod add-output-hooks progn ((class sod-class) reason sequencer)
+(defmethod hook-output progn ((class sod-class) reason sequencer)
(with-slots (ilayout vtables methods effective-methods) class
- (add-output-hooks ilayout reason sequencer)
- (dolist (method methods) (add-output-hooks method reason sequencer))
+ (hook-output ilayout reason sequencer)
+ (dolist (method methods) (hook-output method reason sequencer))
(dolist (method effective-methods)
- (add-output-hooks method reason sequencer))
- (dolist (vtable vtables) (add-output-hooks vtable reason sequencer))))
+ (hook-output method reason sequencer))
+ (dolist (vtable vtables) (hook-output vtable reason sequencer))))
;;;--------------------------------------------------------------------------
;;; Instance structure.
-(defmethod add-output-hooks progn
- ((slot sod-slot) (reason (eql 'populate-islots)) sequencer)
+(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
+ sequencer)
(sequence-output (stream sequencer)
(((sod-slot-class slot) :islots :slots)
(pprint-logical-block (stream nil :prefix " " :suffix ";")
(pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
(terpri stream))))
-(defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer)
+(defmethod hook-output progn ((ilayout ilayout) reason sequencer)
(with-slots (ichains) ilayout
- (dolist (ichain ichains) (add-output-hooks ichain reason sequencer))))
+ (dolist (ichain ichains) (hook-output ichain reason sequencer))))
-(defmethod add-output-hooks progn
- ((ilayout ilayout) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((ichain ichain) reason sequencer)
+ (dolist (item (ichain-body ichain))
+ (hook-output item reason sequencer)))
+
+(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
+ sequencer)
(with-slots (class ichains) ilayout
(sequence-output (stream sequencer)
((class :ilayout :start)
((class :ilayout :end)
(format stream "};~2%")))
(dolist (ichain ichains)
- (add-output-hooks ichain 'populate-ilayout sequencer))))
+ (hook-output ichain 'ilayout sequencer))))
-(defmethod add-output-hooks progn
- ((ichain ichain) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head chain-tail) ichain
(when (eq class chain-tail)
(sequence-output (stream sequencer)
~:{ struct ~A ~A;~%~}~
};~2%"
(ichain-union-tag chain-tail chain-head)
+
+ ;; Make sure the most specific class is first: only the
+ ;; first element of a union can be statically initialized in
+ ;; C90.
(mapcar (lambda (super)
(list (ichain-struct-tag super chain-head)
(sod-class-nickname super)))
(sod-class-chain chain-tail))))))))
-(defmethod add-output-hooks progn
- ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
+ sequencer)
(with-slots (class chain-head chain-tail) ichain
(sequence-output (stream sequencer)
((class :ilayout :slots)
(ichain-union-tag chain-tail chain-head)
(sod-class-nickname chain-head))))))
-(defmethod add-output-hooks progn
- ((vtptr vtable-pointer) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
((class :ichain chain-head :slots)
(format stream " const struct ~A *_vt;~%"
(vtable-struct-tag chain-tail chain-head))))))
-(defmethod add-output-hooks progn ((islots islots) reason sequencer)
+(defmethod hook-output progn ((islots islots) reason sequencer)
(dolist (slot (islots-slots islots))
- (add-output-hooks slot reason sequencer)))
+ (hook-output slot reason sequencer)))
-(defmethod add-output-hooks progn
- ((islots islots) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((islots islots) (reason (eql :h))
+ sequencer)
(with-slots (class subclass slots) islots
(sequence-output (stream sequencer)
((subclass :ichain (sod-class-chain-head class) :slots)
;;;--------------------------------------------------------------------------
;;; Vtable structure.
-(defmethod add-output-hooks progn ((vtable vtable) reason sequencer)
+(defmethod hook-output progn ((vtable vtable) reason sequencer)
(with-slots (body) vtable
- (dolist (item body) (add-output-hooks item reason sequencer))))
+ (dolist (item body) (hook-output item reason sequencer))))
-(defmethod add-output-hooks progn
- ((method sod-method) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((method sod-method) (reason (eql :h))
+ sequencer)
(with-slots (class) method
(sequence-output (stream sequencer)
((class :methods)
(sod-method-function-name method))
(format stream ";~%"))))))
-(defmethod add-output-hooks progn
- ((vtable vtable) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head chain-tail) vtable
(when (eq class chain-tail)
(sequence-output (stream sequencer)
(vtable-struct-tag chain-tail chain-head)
class (sod-class-nickname chain-head))))))
-(defmethod add-output-hooks progn
- ((vtmsgs vtmsgs) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
+ sequencer)
(with-slots (class subclass chain-head chain-tail) vtmsgs
(sequence-output (stream sequencer)
((subclass :vtable chain-head :slots)
(vtmsgs-struct-tag subclass class)
(sod-class-nickname class))))))
-(defmethod add-output-hooks progn
- ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
+ sequencer)
(when (vtmsgs-entries vtmsgs)
(with-slots (class subclass) vtmsgs
(sequence-output (stream sequencer)
((subclass :vtmsgs class :end)
(format stream "};~2%"))))))
-(defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
(with-slots (entries) vtmsgs
- (dolist (entry entries) (add-output-hooks entry reason sequencer))))
+ (dolist (entry entries) (hook-output entry reason sequencer))))
-(defmethod add-output-hooks progn ((entry method-entry) reason sequencer)
+(defmethod hook-output progn ((entry method-entry) reason sequencer)
(with-slots (method) entry
- (add-output-hooks method reason sequencer)))
+ (hook-output method reason sequencer)))
-(defmethod add-output-hooks progn
- ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer)
+(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
+ sequencer)
(let* ((method (method-entry-effective-method entry))
(message (effective-method-message method))
(class (effective-method-class method))
(pprint-c-type commented-type stream (sod-message-name message)))
(terpri stream)))))
-(defmethod add-output-hooks progn
- ((cptr class-pointer) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head metaclass meta-chain-head) cptr
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(sod-class-nickname meta-chain-head)
nil))))))
-(defmethod add-output-hooks progn
- ((boff base-offset) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head) boff
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(write-line " size_t _base;" stream)))))
-(defmethod add-output-hooks progn
- ((choff chain-offset) (reason (eql :h)) sequencer)
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
+ sequencer)
(with-slots (class chain-head target-head) choff
(sequence-output (stream sequencer)
((class :vtable chain-head :slots)
(defvar *instance-class*)
-(defmethod add-output-hooks progn
- ((class sod-class) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((class sod-class) (reason (eql :c))
+ sequencer)
(sequence-output (stream sequencer)
:constraint
(format stream "};~2%")))
(let ((*instance-class* class))
- (add-output-hooks (sod-class-ilayout (sod-class-metaclass class))
- 'populate-class
+ (hook-output (sod-class-ilayout (sod-class-metaclass class))
+ 'class
sequencer)))
;;;--------------------------------------------------------------------------
;;; Direct methods.
-(defmethod add-output-hooks progn
- ((method delegating-direct-method) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
+ sequencer)
(with-slots (class body) method
(unless body
- (return-from add-output-hooks))
+ (return-from hook-output))
(sequence-output (stream sequencer)
((class :direct-method method :start)
(format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
((class :direct-method method :end)
(format stream "#undef CALL_NEXT_METHOD~%")))))
-(defmethod add-output-hooks progn
- ((method sod-method) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((method sod-method) (reason (eql :c))
+ sequencer)
(with-slots (class body) method
(unless body
- (return-from add-output-hooks))
+ (return-from hook-output))
(sequence-output (stream sequencer)
:constraint ((class :direct-methods :start)
(class :direct-method method :start)
;;;--------------------------------------------------------------------------
;;; Vtables.
-(defmethod add-output-hooks progn
- ((vtable vtable) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
+ sequencer)
(with-slots (class chain-head chain-tail) vtable
(sequence-output (stream sequencer)
:constraint ((class :vtables :start)
((class :vtable chain-head :end)
(format stream "};~2%")))))
-(defmethod add-output-hooks progn
- ((cptr class-pointer) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
+ sequencer)
(with-slots (class chain-head metaclass meta-chain-head) cptr
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(sod-class-nickname meta-chain-head)
(sod-class-nickname metaclass))))))
-(defmethod add-output-hooks progn
- ((boff base-offset) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
+ sequencer)
(with-slots (class chain-head) boff
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(ilayout-struct-tag class)
(sod-class-nickname chain-head))))))
-(defmethod add-output-hooks progn
- ((choff chain-offset) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
+ sequencer)
(with-slots (class chain-head target-head) choff
(sequence-output (stream sequencer)
:constraint ((class :vtable chain-head :start)
(sod-class-nickname chain-head)
(sod-class-nickname target-head))))))
-(defmethod add-output-hooks progn
- ((vtmsgs vtmsgs) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
+ sequencer)
(with-slots (class subclass chain-head) vtmsgs
(sequence-output (stream sequencer)
:constraint ((subclass :vtable chain-head :start)
((subclass :vtable chain-head :vtmsgs class :end)
(format stream " },~%")))))
-(defmethod add-output-hooks progn
- ((entry method-entry) (reason (eql :c)) sequencer)
+(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
+ sequencer)
(with-slots (method chain-head chain-tail) entry
(let* ((message (effective-method-message method))
(class (effective-method-class method))
;;;--------------------------------------------------------------------------
;;; Filling in the class object.
-(defmethod add-output-hooks progn
- ((ichain ichain) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
+ sequencer)
(with-slots (class chain-head) ichain
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object :start)
((*instance-class* :object chain-head :ichain :end)
(format stream " } },~%")))))
-(defmethod add-output-hooks progn
- ((islots islots) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((islots islots) (reason (eql 'class))
+ sequencer)
(with-slots (class) islots
(let ((chain-head (sod-class-chain-head class)))
(sequence-output (stream sequencer)
((*instance-class* :object class :slots :end)
(format stream " },~%"))))))
-(defmethod add-output-hooks progn
- ((vtptr vtable-pointer) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
+ sequencer)
(with-slots (class chain-head chain-tail) vtptr
(sequence-output (stream sequencer)
:constraint ((*instance-class* :object chain-head :ichain :start)
(:compound (format stream " ~@<{ ~;~A~; },~:>~%"
(sod-initializer-value-form init)))))))
-(defmethod add-output-hooks progn ((slot sod-class-effective-slot)
- (reason (eql 'populate-class))
+(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
sequencer)
(let ((instance *instance-class*)
(func (effective-slot-prepare-function slot)))
((instance :object :prepare)
(funcall func instance stream))))))
-(defmethod add-output-hooks progn
- ((slot effective-slot) (reason (eql 'populate-class)) sequencer)
+(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
+ sequencer)
(with-slots (class (dslot slot)) slot
(let ((instance *instance-class*)
(super (sod-slot-class dslot)))
(defun test (name)
(let ((sequencer (make-instance 'sequencer))
(class (find-sod-class name)))
- (add-output-hooks class :h sequencer)
+ (hook-output class :h sequencer)
(invoke-sequencer-items sequencer *standard-output*)
sequencer))
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Code generator for effective methods
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Temporary names.
+
+;;;--------------------------------------------------------------------------
+;;; Instructions.
+
+;;;--------------------------------------------------------------------------
+;;; Instruction types.
+;; Top level things.
+
+;;;--------------------------------------------------------------------------
+;;; Code generator objects.
+
+(defgeneric emit-inst (codegen inst)
+ (:documentation
+ "Add INST to the end of CODEGEN's list of instructions.")
+ (:method ))
+
+(defgeneric emit-insts (codegen insts)
+ (:documentation
+ "Add a list of INSTS to the end of CODEGEN's list of instructions.")
+ (:method))
+
+(defgeneric ensure-var (codegen name type &optional init)
+ (:documentation
+ "Add a variable to CODEGEN's list.
+
+ The variable is called NAME (which should be comparable using EQUAL and
+ print to an identifier) and has the given TYPE. If INIT is present and
+ non-nil it is an expression INST used to provide the variable with an
+ initial value.")
+ (:method))
+
+(defgeneric codegen-push (codegen)
+ (:documentation
+ "Pushes the current code generation state onto a stack.
+
+ The state consists of the accumulated variables and instructions, i.e.,
+ what is representable by a BASIC-CODEGEN.")
+ (:method))
+
+(defgeneric codegen-pop (codegen)
+ (:documentation
+ "Pops a saved state off of the CODEGEN's stack.
+
+ Returns the newly accumulated variables and instructions as lists, as
+ separate values.")
+ (:method))
+
+(defgeneric codegen-add-function (codegen function)
+ (:documentation
+ "Adds a function to CODEGEN's list.
+
+ Actually, we're not picky: FUNCTION can be any kind of object that you're
+ willing to find in the list returned by CODEGEN-FUNCTIONS.")
+ (:method ))
+
+
+;;;--------------------------------------------------------------------------
+;;; Code generation idioms.
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Method combinations
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Common behaviour.
+
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Computing class precedence lists
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Linearizations.
+
+;;;--------------------------------------------------------------------------
+;;; Class protocol.
+
+(defgeneric compute-cpl (class)
+ (:documentation
+ "Returns the class precedence list for CLASS."))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(progn
+ (defclass test-class ()
+ ((name :initarg :name :accessor sod-class-name)
+ (direct-superclasses :initarg :superclasses
+ :accessor sod-class-direct-superclasses)
+ (class-precedence-list)))
+
+ (defmethod print-object ((class test-class) stream)
+ (if *print-escape*
+ (print-unreadable-object (class stream :type t :identity nil)
+ (princ (sod-class-name class) stream))
+ (princ (sod-class-name class) stream)))
+
+ (defvar *test-linearization*)
+
+ (defmethod sod-class-precedence-list ((class test-class))
+ (if (slot-boundp class 'class-precedence-list)
+ (slot-value class 'class-precedence-list)
+ (setf (slot-value class 'class-precedence-list)
+ (funcall *test-linearization* class)))))
+
+#+test
+(defun test-cpl (linearization heterarchy)
+ (let* ((*test-linearization* linearization)
+ (classes (make-hash-table :test #'equal)))
+ (dolist (class heterarchy)
+ (let ((name (car class)))
+ (setf (gethash (car class) classes)
+ (make-instance 'test-class :name name))))
+ (dolist (class heterarchy)
+ (setf (sod-class-direct-superclasses (gethash (car class) classes))
+ (mapcar (lambda (super) (gethash super classes)) (cdr class))))
+ (mapcar (lambda (class)
+ (handler-case
+ (mapcar #'sod-class-name
+ (sod-class-precedence-list (gethash (car class)
+ classes)))
+ (inconsistent-merge-error ()
+ (list (car class) :error))))
+ heterarchy)))
+
+#+test
+(progn
+ (defparameter *confused-heterarchy*
+ '((object) (grid-layout object)
+ (horizontal-grid grid-layout) (vertical-grid grid-layout)
+ (hv-grid horizontal-grid vertical-grid)
+ (vh-grid vertical-grid horizontal-grid)
+ (confused-grid hv-grid vh-grid)))
+ (defparameter *boat-heterarchy*
+ '((object)
+ (boat object)
+ (day-boat boat)
+ (wheel-boat boat)
+ (engine-less day-boat)
+ (small-multihull day-boat)
+ (pedal-wheel-boat engine-less wheel-boat)
+ (small-catamaran small-multihull)
+ (pedalo pedal-wheel-boat small-catamaran)))
+ (defparameter *menu-heterarchy*
+ '((object)
+ (choice-widget object)
+ (menu choice-widget)
+ (popup-mixin object)
+ (popup-menu menu popup-mixin)
+ (new-popup-menu menu popup-mixin choice-widget)))
+ (defparameter *pane-heterarchy*
+ '((pane) (scrolling-mixin) (editing-mixin)
+ (scrollable-pane pane scrolling-mixin)
+ (editable-pane pane editing-mixin)
+ (editable-scrollable-pane scrollable-pane editable-pane)))
+ (defparameter *baker-nonmonotonic-heterarchy*
+ '((z) (x z) (y) (b y) (a b x) (c a b x y)))
+ (defparameter *baker-nonassociative-heterarchy*
+ '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
+ (defparameter *distinguishing-heterarchy*
+ '((object)
+ (a object) (b object) (c object)
+ (p a b) (q a c)
+ (u p) (v q)
+ (x u v)
+ (y x b c)
+ (z x c b)))
+ (defparameter *python-heterarchy*
+ '((object)
+ (a object) (b object) (c object) (d object) (e object)
+ (k1 a b c)
+ (k2 d b e)
+ (k3 d a)
+ (z k1 k2 k3))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;;--------------------------------------------------------------------------
+;;; C types stuff.
+
+(cl:defpackage #:c-types
+ (:use #:common-lisp
+ #+sbcl #:sb-mop
+ #+(or cmu clisp) #:mop
+ #+ecl #:clos)
+ (:export #:c-type
+ #:c-declarator-priority #:maybe-parenthesize
+ #:pprint-c-type
+ #:c-type-subtype #:compount-type-declaration
+ #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
+ #:simple-c-type #:c-type-name
+ #:c-pointer-type
+ #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
+ #:tagged-c-type-kind
+ #:c-array-type #:c-array-dimensions
+ #:make-argument #:argument-name #:argument-type
+ #:c-function-type #:c-function-arguments
+
+ #:define-c-type-syntax #:c-type-alias #:defctype
+ #:print-c-type
+ #:qualifier #:declare-qualifier
+ #:define-simple-c-type
+
+ #:const #:volatile #:static #:restrict
+ #:char #:unsigned-char #:uchar #:signed-char #:schar
+ #:int #:signed #:signed-int #:sint
+ #:unsigned #:unsigned-int #:uint
+ #:short #:signed-short #:short-int #:signed-short-int #:sshort
+ #:unsigned-short #:unsigned-short-int #:ushort
+ #:long #:signed-long #:long-int #:signed-long-int #:slong
+ #:unsigned-long #:unsigned-long-int #:ulong
+ #:float #:double #:long-double
+ #:pointer #:ptr
+ #:[] #:vec
+ #:fun #:func #:fn))
+
+
+;;;--------------------------------------------------------------------------
+;;; Convenient syntax for C types.
+
+;; Basic machinery.
+
+;; Qualifiers. They have hairy syntax and need to be implemented by hand.
+
+;; Simple types.
+
+;; Pointers.
+
+;; Tagged types.
+
+;; Arrays.
+
+;; Functions.
+
+
+(progn
+ (defconstant q-byte (byte 3 0))
+ (defconstant q-const 1)
+ (defconstant q-volatile 2)
+ (defconstant q-restrict 4)
+
+ (defconstant z-byte (byte 3 3))
+ (defconstant z-unspec 0)
+ (defconstant z-short 1)
+ (defconstant z-long 2)
+ (defconstant z-long-long 3)
+ (defconstant z-double 4)
+ (defconstant z-long-double 5)
+
+ (defconstant s-byte (byte 2 6))
+ (defconstant s-unspec 0)
+ (defconstant s-signed 1)
+ (defconstant s-unsigned 2)
+
+ (defconstant t-byte (byte 3 8))
+ (defconstant t-unspec 0)
+ (defconstant t-int 1)
+ (defconstant t-char 2)
+ (defconstant t-float 3)
+ (defconstant t-user 4))
+
+(defun make-type-flags (size sign type &rest quals)
+ (let ((flags 0))
+ (dolist (qual quals)
+ (setf flags (logior flags qual)))
+ (setf (ldb z-byte flags) size
+ (ldb s-byte flags) sign
+ (ldb t-byte flags) type)
+ flags))
+
+
+(defun expand-c-type (spec)
+ "Parse SPEC as a C type and return the result.
+
+ The SPEC can be one of the following.
+
+ * A C-TYPE object, which is returned immediately.
+
+ * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
+ function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
+ or some other means is invoked on the ARGUMENTS, and the result is
+ returned.
+
+ * A symbol, which is treated the same way as a singleton list would be."
+
+ (flet ((interp (sym)
+ (or (get sym 'c-type)
+ (error "Unknown C type operator ~S." sym))))
+ (etypecase spec
+ (c-type spec)
+ (symbol (funcall (interp spec)))
+ (list (apply (interp (car spec)) (cdr spec))))))
+
+(defmacro c-type (spec)
+ "Evaluates to the type that EXPAND-C-TYPE would return.
+
+ Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
+ later it will do something more clever."
+ `(expand-c-type ',spec))
+
+;; S-expression machinery. Qualifiers have hairy syntax and need to be
+;; implemented by hand.
+
+(defun qualifier (qual &rest args)
+ "Parse a qualified C type.
+
+ The ARGS consist of a number of qualifiers and exactly one C-type
+ S-expression. The result is a qualified version of this type, with the
+ given qualifiers attached."
+ (if (null args)
+ qual
+ (let* ((things (mapcar #'expand-c-type args))
+ (quals (delete-duplicates
+ (sort (cons qual (remove-if-not #'keywordp things))
+ #'string<)))
+ (types (remove-if-not (lambda (thing) (typep thing 'c-type))
+ things)))
+ (when (or (null types)
+ (not (null (cdr types))))
+ (error "Only one proper type expected in ~S." args))
+ (qualify-type (car types) quals))))
+(setf (get 'qualifier 'c-type) #'qualifier)
+
+(defun declare-qualifier (qual)
+ "Defines QUAL as being a type qualifier.
+
+ When used as a C-type operator, it applies that qualifier to the type that
+ is its argument."
+ (let ((kw (intern (string qual) :keyword)))
+ (setf (get qual 'c-type)
+ (lambda (&rest args)
+ (apply #'qualifier kw args)))))
+
+;; Define some initial qualifiers.
+(dolist (qual '(const volatile restrict))
+ (declare-qualifier qual))
+
+
+(define-c-type-syntax simple-c-type (name)
+ "Constructs a simple C type called NAME (a string or symbol)."
+ (make-simple-type (c-name-case name)))
+
+(defmethod print-c-type :around
+ (stream (type qualifiable-c-type) &optional colon atsign)
+ (if (c-type-qualifiers type)
+ (pprint-logical-block (stream nil :prefix "(" :suffix ")")
+ (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
+ (c-type-qualifiers type))
+ (call-next-method stream type colon atsign))
+ (call-next-method)))
+;; S-expression syntax.
+
+
+(define-c-type-syntax enum (tag)
+ "Construct an enumeration type named TAG."
+ (make-instance 'c-enum-type :tag (c-name-case tag)))
+(define-c-type-syntax struct (tag)
+ "Construct a structure type named TAG."
+ (make-instance 'c-struct-type :tag (c-name-case tag)))
+(define-c-type-syntax union (tag)
+ "Construct a union type named TAG."
+ (make-instance 'c-union-type :tag (c-name-case tag)))
+
+(defgeneric make-me-argument (message class)
+ (:documentation
+ "Return an ARGUMENT object for the `me' argument to MESSAGE, as
+ specialized to CLASS."))
+
+(defmethod make-me-argument
+ ((message basic-message) (class sod-class))
+ (make-argument "me" (make-instance 'c-pointer-type
+ :subtype (sod-class-type class))))
+
+;;;--------------------------------------------------------------------------
+;;; Keyword arguments and lambda lists.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun transform-otherkeys-lambda-list (bvl)
+ "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
+
+ &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
+ (which must also be present); &ALLOW-OTHER-KEYS must not be present.
+
+ The behaviour is that
+
+ * the presence of non-listed keyword arguments is permitted, as if
+ &ALLOW-OTHER-KEYS had been provided, and
+
+ * a list of the keyword arguments other than the ones explicitly listed
+ is stored in the VAR.
+
+ The return value is a replacement BVL which binds the &OTHER-KEYS variable
+ as an &AUX parameter if necessary.
+
+ At least for now, fancy things like destructuring lambda-lists aren't
+ supported. I suspect you'll get away with a specializing lambda-list."
+
+ (prog ((new-bvl nil)
+ (rest-var nil)
+ (keywords nil)
+ (other-keys-var nil)
+ (tail bvl))
+
+ find-rest
+ ;; Scan forwards until we find &REST or &KEY. If we find the former,
+ ;; then remember the variable name. If we find the latter first then
+ ;; there can't be a &REST argument, so we should invent one. If we
+ ;; find neither then there's nothing to do.
+ (when (endp tail)
+ (go ignore))
+ (let ((item (pop tail)))
+ (push item new-bvl)
+ (case item
+ (&rest (when (endp tail)
+ (error "Missing &REST argument name"))
+ (setf rest-var (pop tail))
+ (push rest-var new-bvl))
+ (&aux (go ignore))
+ (&key (unless rest-var
+ (setf rest-var (gensym "REST"))
+ (setf new-bvl (nconc (list '&key rest-var '&rest)
+ (cdr new-bvl))))
+ (go scan-keywords)))
+ (go find-rest))
+
+ scan-keywords
+ ;; Read keyword argument specs one-by-one. For each one, stash it on
+ ;; the NEW-BVL list, and also parse it to extract the keyword, which
+ ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
+ ;; nothing for us to do.
+ (when (endp tail)
+ (go ignore))
+ (let ((item (pop tail)))
+ (push item new-bvl)
+ (case item
+ ((&aux &allow-other-keys) (go ignore))
+ (&other-keys (go fix-tail)))
+ (let ((keyword (if (symbolp item)
+ (intern (symbol-name item) :keyword)
+ (let ((var (car item)))
+ (if (symbolp var)
+ (intern (symbol-name var) :keyword)
+ (car var))))))
+ (push keyword keywords))
+ (go scan-keywords))
+
+ fix-tail
+ ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
+ (pop new-bvl)
+ (when (endp tail)
+ (error "Missing &OTHER-KEYS argument name"))
+ (setf other-keys-var (pop tail))
+ (push '&allow-other-keys new-bvl)
+
+ ;; There should be an &AUX next. If there isn't, assume there isn't
+ ;; one and provide our own. (This is safe as long as nobody else is
+ ;; expecting to plumb in lambda keywords too.)
+ (when (and (not (endp tail)) (eq (car tail) '&aux))
+ (pop tail))
+ (push '&aux new-bvl)
+
+ ;; Add our shiny new &AUX argument.
+ (let ((keys-var (gensym "KEYS"))
+ (list-var (gensym "LIST")))
+ (push `(,other-keys-var (do ((,list-var nil)
+ (,keys-var ,rest-var (cddr ,keys-var)))
+ ((endp ,keys-var) (nreverse ,list-var))
+ (unless (member (car ,keys-var)
+ ',keywords)
+ (setf ,list-var
+ (cons (cadr ,keys-var)
+ (cons (car ,keys-var)
+ ,list-var))))))
+ new-bvl))
+
+ ;; Done.
+ (return (nreconc new-bvl tail))
+
+ ignore
+ ;; Nothing to do. Return the unmolested lambda-list.
+ (return bvl))))
+
+(defmacro lambda-otherkeys (bvl &body body)
+ "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
+ `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defun-otherkeys (name bvl &body body)
+ "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
+ `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
+
+(defmacro defmethod-otherkeys (name &rest stuff)
+ "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
+ (do ((quals nil)
+ (stuff stuff (cdr stuff)))
+ ((listp (car stuff))
+ `(defmethod ,name ,@(nreverse quals)
+ ,(transform-otherkeys-lambda-list (car stuff))
+ ,@(cdr stuff)))
+ (push (car stuff) quals)))
+
+
+(defparse many ((acc init update
+ &key (new 'it) (final acc) (min nil minp) max (commitp t))
+ parser &optional (sep nil sepp))
+ "Parse a sequence of homogeneous items.
+
+ The behaviour is similar to `do'. Initially an accumulator ACC is
+ established, and bound to the value of INIT. The PARSER is then evaluated
+ repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults
+ to `it') bound to the result of the parse, and the value returned by
+ UPDATE is stored back into ACC. If the PARSER fails, then the parse ends.
+
+ If a SEP parser is provided, then the behaviour changes as follows.
+ Before each attempt to parse a new item using PARSER, the parser SEP is
+ invoked. If SEP fails then the parse ends; if SEP succeeds, then the
+ PARSER must also succeed or the overall parse will fail.
+
+ If MAX (which will be evaluated) is not nil, then it must be a number: the
+ parse ends automatically after PARSER has succeeded MAX times. When the
+ parse has ended, if the PARSER succeeded fewer than MIN (which will be
+ evaluated) times then the parse fails. Otherwise, the FINAL form (which
+ defaults to simply returning ACC) is evaluated and its value becomes the
+ result of the parse. MAX defaults to nil -- i.e., no maximum; MIN
+ defaults to 1 if a SEP parser is given, or 0 if not.
+
+ Note that `many' cannot fail if MIN is zero."
+
+ (unless minp (setf min (if sepp 1 0)))
+ (with-gensyms (block value win consumedp cp i up done)
+ (once-only (init min max commitp)
+ (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
+ `(block ,block
+
+ ;; Keep track of variables. We only need an accumulator if it's
+ ;; not nil, and we don't need a counter if (a) there's no maximum,
+ ;; and either (b) the minimum is zero, or (c) the minimum is one
+ ;; and there's a separator. In case (c), we can keep track of how
+ ;; much has been seen using control flow.
+ (let ((,consumedp nil)
+ ,@(and acc `((,acc ,init)))
+ ,@(and counterp `((,i 0))))
+
+ ;; Some handy functions. `up' will update the accumulator.
+ ;; `done' will return the necessary final value.
+ (flet (,@(and acc `((,up (,new)
+ (declare (ignorable ,new))
+ (setf ,acc ,update))))
+ (,done () (return-from ,block
+ (values ,final t ,consumedp))))
+
+ ;; If there's a separator, prime the pump by parsing a first
+ ;; item. This makes the loop easy: it just parses a separator
+ ;; and an item each time. And it means we don't need a
+ ;; counter in the case of a minimum of 1.
+ ,@(and sepp
+ `((multiple-value-bind (,value ,win ,cp)
+ (parse ,parser)
+ (when ,cp (setf ,consumedp t))
+ (unless ,win
+ ,(cond ((eql min 0)
+ `(,done))
+ ((and (numberp min) (plusp min))
+ `(return-from ,block
+ (values ,value nil ,consumedp)))
+ (t
+ `(if (< 0 ,min)
+ (return-from ,block
+ (values ,value nil, consumedp))
+ (,done)))))
+ ,@(and acc `((,up ,value))))
+ ,@(and counterp `((incf ,i)))))
+
+ ;; The main loop...
+ (loop
+
+ ;; If we've hit the maximum then stop. But, attention, if
+ ;; we have a separator and we're not committing to parsing
+ ;; items, then check after scanning the separator, not
+ ;; before.
+ ,@(and max commitp
+ `((when (and ,@(and (not (constantp max))
+ `(,max))
+ ,@(and (not (constantp commitp))
+ `(,commitp))
+ (>= ,i ,max))
+ (,done))))
+
+ ,@(if sepp
+ ;; We're expecting a separator. If this fails and
+ ;; we're below minimum then we've failed altogether.
+ ;; If it succeeds then we should go on to parse an
+ ;; item.
+ `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
+ ,@(and (numberp min) (<= min 1)
+ `((declare (ignore ,value))))
+ (when ,cp (setf ,consumedp t))
+ (unless ,win
+ ,(if (and (numberp min) (<= min 1))
+ `(,done)
+ `(if (>= ,i ,min)
+ (return ,final)
+ (return-from ,block
+ (values ,value nil ,consumedp))))))
+
+ ;; If we're not committing then now is the time to
+ ;; check for hitting the maximum number of
+ ;; repetitions.
+ ,@(and max (or (not commitp)
+ (not (constantp commitp)))
+ `((when (and ,@(and (not (constantp max))
+ `(,max))
+ ,@(and commitp
+ `((not ,commitp)))
+ (>= ,i ,max))
+ (,done))))
+
+ ;; Now parse an item. If this fails and we're
+ ;; committed then we've blown the whole parse. If
+ ;; it fails and we've not committed then we need to
+ ;; check the minimum. It's getting very tempting to
+ ;; write a compiler for optimizing these
+ ;; conditionals. (If we don't do this, we get
+ ;; annoying warnings.)
+ (multiple-value-bind (,value ,win ,cp)
+ (parse ,parser)
+ (when ,cp (setf ,consumedp t))
+ (unless ,win
+ ,(cond ((and (constantp commitp) commitp)
+ `(return-from ,block
+ (values ,value nil ,consumedp)))
+ ((not commitp)
+ (if (and (numberp min) (<= min 1))
+ `(,done)
+ `(if (>= ,i ,min)
+ (,done)
+ (return-from ,block
+ (values ,value nil
+ ,consumedp)))))
+ ((and (numberp min) (<= min 1))
+ `(if ,commitp
+ (return-from ,block
+ (values ,value nil ,consumedp))
+ (,done)))
+ (t
+ `(if (or ,commitp (< ,i ,min))
+ (return-from ,block
+ (values ,value nil ,consumedp))
+ (,done)))))
+ ,@(and acc `((,up ,value)))))
+
+ ;; No separator. Just parse the value. If it fails,
+ ;; check that we've met the minimum.
+ `((multiple-value-bind (,value ,win ,cp)
+ (parse ,parser)
+ ,@(and (eql min 0) (null acc)
+ `((declare (ignore ,value))))
+ (when ,cp (setf ,consumedp t))
+ (unless ,win
+ ,(if (eql min 0)
+ `(,done)
+ `(if (>= ,i ,min)
+ (,done)
+ (return-from ,block
+ (values ,value nil ,consumedp)))))
+ ,@(and acc `((,up ,value))))))
+
+ ;; Done. Update the counter and go round again.
+ ,@(and counterp `((incf ,i)))))))))))
\ No newline at end of file
;;; Enclosing conditions.
(define-condition enclosing-condition (condition)
- ((enclosed-condition :initarg :condition
- :type condition
+ ((enclosed-condition :initarg :condition :type condition
:reader enclosed-condition))
(:documentation
"A condition which encloses another condition
;;; Conditions with location information.
(define-condition condition-with-location (condition)
- ((location :initarg :location
- :reader file-location
- :type file-location))
+ ((location :initarg :location :reader file-location :type file-location))
(:documentation
"A condition which has some location information attached."))
--- /dev/null
+;;;
+(write-line "stuff's a-goin' on")
(defgeneric skip-spaces (lexer)
(:documentation
- "Skip over whitespace characters in the LEXER.")
- (:method ((lexer lexer))
- (do ((ch (lexer-char lexer) (next-char lexer)))
- ((not (whitespace-char-p ch))))))
+ "Skip over whitespace characters in the LEXER."))
;;;--------------------------------------------------------------------------
;;; Lexer utilities.
-(defun require-token
- (lexer wanted-token-type &key (errorp t) (consumep t) default)
- (with-slots (token-type token-value) lexer
- (cond ((eql token-type wanted-token-type)
- (prog1 token-value
- (when consumep (next-token lexer))))
- (errorp
- (cerror* "Expected ~A but found ~A"
- (format-token wanted-token-type)
- (format-token token-type token-value))
- default)
- (t
- default))))
-
;;;--------------------------------------------------------------------------
;;; Our main lexer.
;;;--------------------------------------------------------------------------
;;; C fragments.
-(defclass c-fragment ()
- ((location :initarg :location :type file-location
- :accessor c-fragment-location)
- (text :initarg :text :type string :accessor c-fragment-text))
- (:documentation
- "Represents a fragment of C code to be written to an output file.
-
- A C fragment is aware of its original location, and will bear proper #line
- markers when written out."))
-
-(defun output-c-excursion (stream location thunk)
- "Invoke THUNK surrounding it by writing #line markers to STREAM.
-
- The first marker describes LOCATION; the second refers to the actual
- output position in STREAM. If LOCATION doesn't provide a line number then
- no markers are output after all. If the output stream isn't
- position-aware then no final marker is output."
-
- (let* ((location (file-location location))
- (line (file-location-line location))
- (pathname (file-location-pathname location))
- (namestring (and pathname (namestring pathname))))
- (cond (line
- (format stream "~&#line ~D~@[ ~S~]~%" line namestring)
- (funcall thunk)
- (when (typep stream 'position-aware-stream)
- (fresh-line stream)
- (format stream "~&#line ~D ~S~%"
- (1+ (position-aware-stream-line stream))
- (namestring (stream-pathname stream)))))
- (t
- (funcall thunk)))))
-
-(defmethod print-object ((fragment c-fragment) stream)
- (let ((text (c-fragment-text fragment))
- (location (c-fragment-location fragment)))
- (if *print-escape*
- (print-unreadable-object (fragment stream :type t)
- (when location
- (format stream "~A " location))
- (cond ((< (length text) 40)
- (prin1 text stream) stream)
- (t
- (prin1 (subseq text 0 40) stream)
- (write-string "..." stream))))
- (output-c-excursion stream location
- (lambda () (write-string text stream))))))
-
-(defmethod make-load-form ((fragment c-fragment) &optional environment)
- (make-load-form-saving-slots fragment :environment environment))
-
(defun scan-c-fragment (lexer end-chars)
"Snarfs a sequence of C tokens with balanced brackets.
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Infrastructure for effective method generation
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Direct method classes.
+
+;;;--------------------------------------------------------------------------
+;;; Effective method classes.
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+;;;--------------------------------------------------------------------------
+;;; Effective method entry points.
+
+;;;--------------------------------------------------------------------------
+;;; Output.
+
+;;;----- That's all, folks --------------------------------------------------
(cl:in-package #:sod)
-;;;--------------------------------------------------------------------------
-;;; Module basics.
-
-(defclass module ()
- ((name :initarg :name :type pathname :reader module-name)
- (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
- (items :initarg :items :initform nil :type list :accessor module-items)
- (dependencies :initarg :dependencies :initform nil
- :type list :accessor module-dependencies)
- (state :initarg :state :initform nil :accessor module-state))
- (:documentation
- "A module is a container for the definitions made in a source file.
-
- Modules are the fundamental units of translation. The main job of a
- module is to remember which definitions it contains, so that they can be
- translated and written to output files. The module contains the following
- handy bits of information:
-
- * A (path) name, which is the filename we used to find it. The default
- output filenames are derived from this. (We use the file's truename
- as the hash key to prevent multiple inclusion, and that's a different
- thing.)
-
- * A property list containing other useful things.
-
- * A list of the classes defined in the source file.
-
- * Lists of C fragments to be included in the output header and C source
- files.
-
- * A list of other modules that this one depends on.
-
- Modules are usually constructed by the PARSE-MODULE function, which is in
- turn usually invoked by IMPORT-MODULE, though there's nothing to stop
- fancy extensions building modules programmatically."))
-
-(defparameter *module* nil
- "The current module under construction.
-
- This is always an instance of MODULE. Once we've finished constructing
- it, we'll call CHANGE-CLASS to turn it into an instance of whatever type
- is requested in the module's :LISP-CLASS property.")
-
-(defgeneric module-import (object)
- (:documentation
- "Import definitions into the current environment.
-
- Instructs the OBJECT to import its definitions into the current
- environment. Modules pass the request on to their constituents. There's
- a default method which does nothing at all.
-
- It's not usual to modify the current module. Inserting things into the
- *TYPE-MAP* is a good plan.")
- (:method (object) nil))
-
-(defgeneric add-to-module (module item)
- (:documentation
- "Add ITEM to the MODULE's list of accumulated items.
-
- The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
- protocols."))
-
-(defgeneric finalize-module (module)
- (:documentation
- "Finalizes a module, setting everything which needs setting.
-
- This isn't necessary if you made the module by hand. If you've
- constructed it incrementally, then it might be a good plan. In
- particular, it will change the class (using CHANGE-CLASS) of the module
- according to the class choice set in the module's :LISP-CLASS property.
- This has the side effects of calling SHARED-INITIALIZE, setting the
- module's state to T, and checking for unrecognized properties. (Therefore
- subclasses should add a method to SHARED-INITIALIZE should take care of
- looking at interesting properties, just to make sure they're ticked
- off.)"))
-
-(defmethod module-import ((module module))
- (dolist (item (module-items module))
- (module-import item)))
-
-(defmethod add-to-module ((module module) item)
- (setf (module-items module)
- (nconc (module-items module) (list item)))
- (module-import item))
-
-(defmethod shared-initialize :after ((module module) slot-names &key pset)
- "Tick off known properties on the property set."
- (declare (ignore slot-names))
- (when pset
- (dolist (prop '(:guard))
- (get-property pset prop nil))))
-
-(defmethod finalize-module ((module module))
- (let* ((pset (module-pset module))
- (class (get-property pset :lisp-class :symbol 'module)))
-
- ;; Always call CHANGE-CLASS, even if it's the same one; this will
- ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can
- ;; catch unknown-property errors.
- (change-class module class :state t :pset pset)
- (check-unused-properties pset)
- module))
-
;;;--------------------------------------------------------------------------
;;; Module importing.
-(defun build-module
- (name body-func &key (truename (probe-file name)) location)
- (let ((*module* (make-instance 'module
- :name (pathname name)
- :state (file-location location)))
- (*type-map* (make-hash-table :test #'equal)))
- (module-import *builtin-module*)
- (when truename
- (setf (gethash truename *module-map*) *module*))
- (unwind-protect
- (progn
- (funcall body-func)
- (finalize-module *module*))
- (when (and truename (not (eq (module-state *module*) t)))
- (remhash truename *module-map*)))))
-
-(defmacro define-module
- ((name &key (truename nil truenamep) (location nil locationp))
- &body body)
- `(build-module ,name
- (lambda () ,@body)
- ,@(and truenamep `(:truename ,truename))
- ,@(and locationp `(:location ,location))))
-
(defun read-module (pathname &key (truename (truename pathname)) location)
"Reads a module.
:report "Ignore the error and continue parsing."
nil))))
-;;;--------------------------------------------------------------------------
-;;; Type definitions.
-
-(defclass type-item ()
- ((name :initarg :name :type string :reader type-name))
- (:documentation
- "A note that a module exports a type.
-
- We can only export simple types, so we only need to remember the name.
- The magic simple-type cache will ensure that we get the same type object
- when we do the import."))
-
-(defmethod module-import ((item type-item))
- (let* ((name (type-name item))
- (def (gethash name *type-map*))
- (type (make-simple-type name)))
- (cond ((not def)
- (setf (gethash name *type-map*) type))
- ((not (eq def type))
- (error "Conflicting types `~A'" name)))))
-
-(defmethod module-import ((class sod-class))
- (record-sod-class class))
-
(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
"module-decl ::= `typename' id-list `;'"
(loop (let ((name (require-token lexer :id)))
;;;--------------------------------------------------------------------------
;;; Fragments.
-(defclass code-fragment-item ()
- ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
- (reason :initarg :reason :type keyword :reader code-fragment-reason)
- (name :initarg :name :type t :reader code-fragment-name)
- (constraints :initarg :constraints :type list
- :reader code-fragment-constraints))
- (:documentation
- "A plain fragment of C to be dropped in at top-level."))
-
-(defmacro define-fragment ((reason name) &body things)
- (categorize (thing things)
- ((constraints (listp thing))
- (frags (typep thing '(or string c-fragment))))
- (when (null frags)
- (error "Missing code fragment"))
- (when (cdr frags)
- (error "Multiple code fragments"))
- `(add-to-module
- *module*
- (make-instance 'code-fragment-item
- :fragment ',(car frags)
- :name ,name
- :reason ,reason
- :constraints (list ,@(mapcar (lambda (constraint)
- (cons 'list constraint))
- constraints))))))
-
(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
"module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
constraint ::= id*"
(finalize-sod-class class)
(add-to-module *module* class)))
-;;;--------------------------------------------------------------------------
-;;; Modules.
-
-#+(or)
-(defun parse-module (lexer)
- "Parse a module from the given LEXER.
-
- The newly constructed module is returned. This is the top-level parsing
- function."
-
- (let ((hfrags nil)
- (cfrags nil)
- (classes nil)
- (plist nil)
- (deps nil))
-
- (labels ((fragment (func)
- (next-token lexer)
- (when (require-token lexer #\{ :consumep nil)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (funcall func frag)))))
-
- (tagbody
-
- top
- ;; module : empty | module-def module
- ;;
- ;; Just read module-defs until we reach the end of the file.
- (case (token-type lexer)
-
- (:eof
- (go done))
- (#\;
- (next-token lexer)
- (go top))
-
- ;; module-def : `lisp' sexp
- ;;
- ;; Process an in-line Lisp form immediately.
- (:lisp
-
- (next-token lexer)
- (go top))
-
- ;; module-def : `typename' ids `;'
- ;; ids : id | ids `,' id
- ;;
- ;; Add ids as registered type names. We don't need to know what
- ;; they mean at this level.
- (:typename
- (next-token lexer)
- (loop
- (let ((id (require-token lexer :id)))
- (cond ((null id)
- (return))
- ((gethash id *type-map*)
- (cerror* "Type ~A is already defined" id))
- (t
- (setf (gethash id *type-map*)
- (make-instance 'simple-c-type :name id))))
- (unless (eql (token-type lexer) #\,)
- (return))
- (next-token lexer)))
- (go semicolon))
-
- ;; module-def : `source' `{' c-stuff `}'
- ;; module-def : `header' `{' c-stuff `}'
- (:source
- (fragment (lambda (frag) (push frag cfrags)))
- (go top))
- (:header
- (fragment (lambda (frag) (push frag hfrags)))
- (go top))
-
- ;; Anything else is an error.
- (t
- (cerror* "Unexpected token ~A ignored" (format-token lexer))
- (next-token lexer)
- (go top)))
-
- semicolon
- ;; Scan a terminating semicolon.
- (require-token lexer #\;)
- (go top)
-
- done)
-
- ;; Assemble the module and we're done.
- (make-instance 'module
- :name (stream-pathname (lexer-stream lexer))
- :plist plist
- :classes classes
- :header-fragments hfrags
- :source-fragments cfrags
- :dependencies deps))))
-
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output driver for SOD translator
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; 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)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defclass sequencer-item ()
+ ((name :initarg :name :reader sequencer-item-name)
+ (functions :initarg :functions :initform nil
+ :type list :accessor sequencer-item-functions))
+ (:documentation
+ "Represents a distinct item to be sequenced by a SEQUENCER.
+
+ A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
+ sequencer is invoked. This class is not intended to be subclassed."))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defvar *seen-announcement*) ;Keep me unbound!
+#+hmm
+(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
+ "Arrange not to invoke any object more than once during a particular
+ announcement."
+ (declare (ignore stuff))
+ (cond ((not (boundp '*seen-announcement*))
+ (let ((*seen-announcement* (make-hash-table)))
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method)))
+ ((gethash object *seen-announcement*)
+ nil)
+ (t
+ (setf (gethash object *seen-announcement*) t)
+ (call-next-method))))
+
+;;;--------------------------------------------------------------------------
+;;; Utility macro.
+
+;;;----- That's all, folks --------------------------------------------------
(cl:in-package #:sod)
-;;;--------------------------------------------------------------------------
-;;; Property representation.
-
-(defun property-key (name)
- "Convert NAME into a keyword.
-
- If NAME isn't a symbol already, then flip its case (using FROB-CASE),
- replace underscores by hyphens, and intern into the KEYWORD package."
- (etypecase name
- (symbol name)
- (string (intern (substitute #\- #\_ (frob-case name)) :keyword))))
-
-(defun property-type (value)
- "Guess a sensible property type to use for VALUE."
- (typecase value
- (symbol :symbol)
- (integer :integer)
- (string :string)
- (character :char)
- (c-fragment :frag)
- (t :other)))
-
-(defstruct (property
- (: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)))))
- "A simple structure for holding a property in a property set.
-
- The main useful feature is the ability to tick off properties which have
- been used, so that we can complain about unrecognized properties.
-
- An explicit type tag is necessary because we need to be able to talk
- distinctly about identifiers, strings and symbols, and we've only got two
- obvious Lisp types to play with. Sad, but true."
-
- (name nil :type (or string symbol))
- (value nil :type t)
- (type nil :type symbol)
- (location (file-location nil) :type file-location)
- (key nil :type symbol)
- (seenp nil :type boolean))
-
-(defun string-to-symbol (string &optional (package *package*))
- "Convert STRING to a symbol in PACKAGE.
-
- If PACKAGE is nil, then parse off a `PACKAGE:' prefix from STRING to
- identify the package. A doubled colon allows access to internal symbols,
- and will intern if necessary. Note that escape characters are /not/
- processed; don't put colons in package names if you want to use them from
- SOD property sets."
-
- (let* ((length (length string))
- (colon (position #\: string)))
- (multiple-value-bind (start internalp)
- (cond ((not colon) (values 0 t))
- ((and (< (1+ colon) length)
- (char= (char string (1+ colon)) #\:))
- (values (+ colon 2) t))
- (t
- (values (1+ colon) nil)))
- (when colon
- (let* ((package-name (subseq string 0 colon))
- (found (find-package package-name)))
- (unless found
- (error "Unknown package `~A'" package-name))
- (setf package found)))
- (let ((name (subseq string start)))
- (multiple-value-bind (symbol status)
- (funcall (if internalp #'intern #'find-symbol) name package)
- (cond ((or internalp (eq status :external))
- symbol)
- ((not status)
- (error "Symbol `~A' not found in package `~A'"
- name (package-name package)))
- (t
- (error "Symbol `~A' not external in package `~A'"
- name (package-name package)))))))))
-
-(defgeneric coerce-property-value (value type wanted)
- (:documentation
- "Convert VALUE, a property of type TYPE, to be of type WANTED.
-
- It's sensible to add additional methods to this function, but there are
- all the ones we need.")
-
- ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
- ;; form. Otherwise, if nothing else matched, then I guess we'll have to
- ;; say it didn't work.
- (:method (value type wanted)
- (if (eql type wanted)
- value
- (error "Incorrect type: expected ~A but found ~A" wanted type)))
-
- ;; If the caller asks for type T then give him the raw thing.
- (:method (value type (wanted (eql t)))
- value)
-
- ;; Keywords.
- (:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
- value)
- (:method ((value string) (type (eql :id)) (wanted (eql :keyword)))
- (string-to-symbol (substitute #\- #\_ (frob-case value)) :keyword))
- (:method ((value string) (type (eql :string)) (wanted (eql :keyword)))
- (string-to-symbol (frob-case value) :keyword))
-
- ;; Symbols.
- (:method ((value string) (type (eql :id)) (wanted (eql :symbol)))
- (string-to-symbol (substitute #\- #\_ (frob-case value))))
- (:method ((value string) (type (eql :string)) (wanted (eql :symbol)))
- (string-to-symbol (frob-case value)))
-
- ;; Identifiers.
- (:method ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
- (substitute #\_ #\- (frob-case (symbol-name value)))))
-
-;;;--------------------------------------------------------------------------
-;;; Property set representation.
-;;;
-;;; There shouldn't be any code elsewhere which depends on the
-;;; representation. It's changed before; it may change again.
-
-(defstruct (pset (:constructor %make-pset)
- (:conc-name %pset-))
- "A property set.
-
- Wrapped up in a structure so that we can define a print function."
- (hash (make-hash-table) :type hash-table))
-
-(declaim (inline make-pset pset-get pset-store pset-map))
-
-(defun make-pset ()
- "Constructor for property sets."
- (%make-pset))
-
-(defun pset-get (pset key)
- "Look KEY up in PSET and return what we find.
-
- If there's no property by that name, return NIL."
- (values (gethash key (%pset-hash pset))))
-
-(defun pset-store (pset prop)
- "Store property PROP in PSET.
-
- Overwrite or replace any previous property with the same name. Mutates
- the property set."
- (setf (gethash (p-key prop) (%pset-hash pset)) prop))
-
-(defun pset-map (func pset)
- "Call FUNC for each property in PSET."
- (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
- (%pset-hash pset)))
-
-;;;--------------------------------------------------------------------------
-;;; `Cooked' property set operations.
-
-(defun store-property
- (pset name value &key (type (property-type value)) location)
- "Store a property in PSET."
- (pset-store pset
- (make-property name value :type type :location location)))
-
-(defun get-property (pset name type &optional default)
- "Fetch a property from a property set.
-
- If a property NAME is not found in PSET, or if a property is found, but
- its type doesn't match TYPE, then return DEFAULT and NIL; otherwise return
- the value and its file location. In the latter case, mark the property as
- having been used.
-
- The value returned depends on the TYPE argument provided. If you pass NIL
- then you get back the entire PROPERTY object. If you pass T, then you get
- whatever was left in the property set, uninterpreted. Otherwise the value
- is coerced to the right kind of thing (where possible) and returned.
-
- If PSET is nil, then return DEFAULT."
-
- (let ((prop (and pset (pset-get pset (property-key name)))))
- (with-default-error-location ((and prop (p-location prop)))
- (cond ((not prop)
- (values default nil))
- ((not type)
- (setf (p-seenp prop) t)
- (values prop (p-location prop)))
- (t
- (setf (p-seenp prop) t)
- (values (coerce-property-value (p-value prop)
- (p-type prop)
- type)
- (p-location prop)))))))
-
-(defun add-property
- (pset name value &key (type (property-type value)) location)
- "Add a property to PSET.
-
- If a property with the same NAME already exists, report an error."
-
- (with-default-error-location (location)
- (let ((existing (get-property pset name nil)))
- (when existing
- (error "Property ~S already defined~@[ at ~A~]"
- name (p-location existing)))
- (store-property pset name value :type type :location location))))
-
-(defun make-property-set (&rest plist)
- "Make a new property set, with given properties.
-
- This isn't the way to make properties when parsing, but it works well for
- programmatic generation. The arguments should form a property list
- (alternating keywords and values is good).
-
- 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."
-
- (do ((pset (make-pset))
- (plist plist (cddr plist)))
- ((endp plist) pset)
- (add-property pset (car plist) (cadr plist))))
-
-(defmethod print-object ((pset pset) stream)
- (print-unreadable-object (pset stream :type t)
- (pprint-logical-block (stream nil)
- (let ((firstp t))
- (pset-map (lambda (prop)
- (cond (firstp (setf firstp nil))
- (t (write-char #\space stream)
- (pprint-newline :linear stream)))
- (format stream "~:@<~S ~@_~S ~@_~S~:>"
- (p-name prop) (p-type prop) (p-value prop)))
- pset)))))
-
-(defun check-unused-properties (pset)
- "Issue errors about unused properties in PSET."
- (when pset
- (pset-map (lambda (prop)
- (unless (p-seenp prop)
- (cerror*-with-location (p-location prop)
- "Unknown property `~A'"
- (p-name prop))
- (setf (p-seenp prop) t)))
- pset)))
-
;;;--------------------------------------------------------------------------
;;; Expression parser.
--- /dev/null
+;;; sift through lists of classes and so on.
+
+(in-package #:cl-user)
+
+(defstruct (cset (:conc-name s-))
+ members supers subs gfs)
+
+(defstruct (class-node (:conc-name c-))
+ name class own-p supers subs visited-p sets)
+
+(defmacro pushnew-end (object place &rest keys &environment env)
+ (multiple-value-bind (temps inits newtemps setform getform)
+ (get-setf-expansion place env)
+ (let ((objvar (gensym "OBJECT"))
+ (listvar (gensym "LIST")))
+ `(let* ((,objvar ,object)
+ ,@(mapcar #'list temps inits)
+ (,listvar ,getform))
+ (cond ((member ,objvar ,listvar ,@keys)
+ ,listvar)
+ (t
+ (multiple-value-bind ,newtemps
+ (append ,listvar (list ,objvar))
+ ,setform
+ (values ,@newtemps))))))))
+
+(defun show-classes (classes)
+ (let ((map (make-hash-table)))
+
+ (labels ((getnode (class &optional own-p)
+ (let ((found (gethash class map)))
+ (if found
+ (values found t)
+ (values (setf (gethash class map)
+ (make-class-node :name (class-name class)
+ :class class
+ :own-p own-p))
+ nil))))
+
+ (gather (class)
+ (let ((node (getnode class)))
+ (dolist (super (class-direct-superclasses class))
+ (unless (member super (append (mapcar #'find-class
+ '(t standard-object
+ structure-object))
+ (class-direct-superclasses
+ (find-class 'condition))))
+ (multiple-value-bind (supernode foundp)
+ (getnode super)
+ (pushnew-end supernode (c-supers node))
+ (pushnew node (c-subs supernode))
+ (unless foundp (gather super)))))))
+
+ (walk (node &optional (level 0) super)
+ (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
+ (* 2 level)
+ (c-own-p node)
+ (c-name node))
+ (cond ((null (cdr (c-supers node))))
+ ((eq (car (c-supers node)) super)
+ (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>"
+ (mapcar #'c-name (c-supers node))))
+ (t
+ (format *standard-output* "*~%")
+ (return-from walk)))
+ (terpri *standard-output*)
+ (dolist (sub (c-subs node))
+ (walk sub (1+ level) node))))
+
+ ;; make nodes for all of the official classes.
+ (dolist (class classes)
+ (getnode class t))
+
+ ;; build the hierarchy, up and down. this may drag in classes from
+ ;; other packages.
+ (dolist (class classes)
+ (gather class))
+
+ ;; write the table.
+ (dolist (node (sort (loop for node being the hash-values of map
+ unless (c-supers node)
+ collect node)
+ #'string< :key #'c-name))
+ (walk node)))))
+
+(defun check-sets (members)
+ (let ((done (make-hash-table)))
+ (labels ((check (s)
+ (when (gethash s done)
+ (return-from check))
+ (setf (gethash s done) t)
+
+ ;; subsets must be proper subsets
+ (dolist (u (s-supers s))
+ (assert (subsetp (s-members s) (s-members u)))
+ (assert (not (subsetp (s-members u) (s-members s))))
+ (assert (member s (s-subs u))))
+
+ ;; supersets must be proper supersets
+ (dolist (u (s-subs s))
+ (assert (subsetp (s-members u) (s-members s)))
+ (assert (not (subsetp (s-members s) (s-members u))))
+ (assert (member s (s-supers u))))
+
+ ;; supersets must be minimal
+ (dolist (u (s-supers s))
+ (dolist (v (s-supers s))
+ (assert (or (eq u v)
+ (not (subsetp (s-members u)
+ (s-members v)))))))
+
+ ;; subsets must be maximal
+ (dolist (u (s-subs s))
+ (dolist (v (s-subs s))
+ (assert (or (eq u v)
+ (not (subsetp (s-members u)
+ (s-members v)))))))
+
+ ;; members must link to us, directly or indirectly.
+ (dolist (m (s-members s))
+ (labels ((look (u)
+ (or (eq u s) (some #'look (s-supers u)))))
+ (assert (some #'look (c-sets m)))))
+
+ ;; check supersets and subsets
+ (dolist (u (s-supers s)) (check u))
+ (dolist (u (s-subs s)) (check u))))
+
+ (dolist (m members)
+ (dolist (s (c-sets m))
+
+ ;; sets must contain us
+ (assert (member m (s-members s)))
+
+ ;; sets must be minimal
+ (dolist (u (c-sets m))
+ (assert (or (eq u s)
+ (not (subsetp (s-members u)
+ (s-members s))))))
+
+ ;; check set
+ (check s))))))
+
+(defmethod print-object ((c class-node) stream)
+ (format stream "#[~(~A~)]" (c-name c)))
+
+(defmethod print-object ((s cset) stream)
+ (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))
+
+(defun ensure-set (members)
+
+ (setf members (remove-duplicates members))
+ (check-sets members)
+
+ (let ((subs nil) (supers nil))
+
+ ;; find the maximal subsets and minimal supersets. if s is not a subset
+ ;; then answer nil; otherwise answer t, and recursively process all the
+ ;; supersets of s; if none of them answer t then is maximal, so add it to
+ ;; the list.
+ (labels ((up (s)
+ (cond ((subsetp (s-members s) members)
+ (unless (some #'up (s-supers s)) (pushnew s subs))
+ t)
+ ((subsetp members (s-members s))
+ (pushnew s supers)
+ nil)
+ (t nil))))
+ (dolist (m members)
+ (mapc #'up (c-sets m))))
+ (when (and subs (subsetp members (s-members (car subs))))
+ (return-from ensure-set (car subs)))
+ (let* ((new (make-cset :members members :supers supers :subs subs)))
+
+ ;; now we have to interpolate ourselves properly. this is the tricky
+ ;; part.
+ (dolist (s supers)
+ (setf (s-subs s)
+ (cons new (set-difference (s-subs s) subs))))
+ (dolist (s subs)
+ (setf (s-supers s)
+ (cons new (set-difference (s-supers s) supers))))
+ (dolist (m members)
+ (unless (some (lambda (s) (subsetp (s-members s) members))
+ (c-sets m))
+ (setf (c-sets m) (cons new
+ (remove-if (lambda (s)
+ (subsetp members
+ (s-members s)))
+ (c-sets m))))))
+
+ ;; done
+ (check-sets members)
+ new)))
+
+(defun categorize-protocols (generics classes)
+ (let ((cmap (make-hash-table)))
+
+ (labels ((getnode (class &optional own-p)
+ (let ((found (gethash class cmap)))
+ (if found
+ (values found t)
+ (values (setf (gethash class cmap)
+ (make-class-node :name (class-name class)
+ :class class
+ :own-p own-p))
+ nil))))
+
+ (gather (class)
+ (let ((node (getnode class)))
+ (dolist (super (class-direct-superclasses class))
+ (unless (member super (append (mapcar #'find-class
+ '(t standard-object
+ structure-object))
+ (class-direct-superclasses
+ (find-class 'condition))))
+ (multiple-value-bind (supernode foundp)
+ (getnode super)
+ (pushnew-end supernode (c-supers node))
+ (pushnew node (c-subs supernode))
+ (unless foundp (gather super))))))))
+
+ ;; make nodes for all of the official classes.
+ (dolist (class classes)
+ (getnode class t))
+
+ ;; build the hierarchy, up and down. this may drag in classes from
+ ;; other packages.
+ (dolist (class classes)
+ (gather class))
+
+ ;; go through the generic functions collecting sets of implementing
+ ;; classes.
+ (dolist (gf generics)
+ (let* ((specs (reduce #'append
+ (mapcar #'method-specializers
+ (generic-function-methods gf))
+ :from-end t))
+ (members (labels ((down (c)
+ (delete-duplicates
+ (cons c (mapcan #'down (c-subs c)))))
+ (gather (spec)
+ (let ((c (gethash spec cmap)))
+ (and c (down c)))))
+ (delete-duplicates (mapcan #'gather specs))))
+ (s (and members (ensure-set members))))
+ (when s
+ (push gf (s-gfs s)))))
+
+ ;; finally dump the list of participating classes.
+ (let ((tops nil))
+
+ ;; find the top-level sets
+ (let ((m (make-hash-table)))
+ (labels ((ascend (s)
+ (unless (gethash s m)
+ (setf (gethash s m) t)
+ (if (s-supers s)
+ (mapc #'ascend (s-supers s))
+ (push s tops)))))
+ (dolist (c classes)
+ (mapc #'ascend (c-sets (gethash c cmap))))))
+
+ (let ((done (make-hash-table)))
+ (labels ((walk (s &optional (level 0))
+ (let ((seen (gethash s done)))
+ (unless seen
+ (setf (gethash s done) t)
+ (dolist (gf (s-gfs s))
+ (format *standard-output* "~v,0T~(~A~)~%"
+ (* 2 level)
+ (generic-function-name gf))))
+ (dolist (c (set-difference
+ (s-members s)
+ (reduce #'union (mapcar #'s-members
+ (s-subs s))
+ :initial-value nil)))
+ (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
+ (c-name c) seen))
+ (dolist (u (s-subs s))
+ (walk u (1+ level))))))
+ (mapc #'walk tops)
+ nil))))))
+
+(defun gather-stuff (package)
+ (let ((classes nil)
+ (functions nil)
+ (generics nil)
+ (structs nil)
+ (macros nil)
+ (methods nil)
+ (package (find-package package)))
+
+ ;; find all of the interesting things in the package.
+ (do-symbols (sym package)
+ (when (eq (symbol-package sym) package)
+ (let ((class (find-class sym nil)))
+ (typecase class
+ ((or standard-class sb-pcl::condition-class)
+ (push class classes))
+ (structure-class (push class structs))))
+ (when (fboundp sym)
+ (let ((func (symbol-function sym)))
+ (if (typep func 'generic-function)
+ (push func generics)
+ (push sym functions))))
+ (let ((macro (macro-function sym)))
+ (when macro (push sym macros)))))
+
+ ;; sort the lists -- makes things look prettier.
+ (macrolet ((frob (list key)
+ `(setf ,list (sort ,list #'string< :key #',key))))
+ (frob classes class-name)
+ (frob functions identity)
+ (frob structs class-name)
+ (frob generics generic-function-name)
+ (frob macros identity)
+ (frob methods (lambda (m)
+ (generic-function-name (method-generic-function m)))))
+
+ ;; present the classes in a vaguely useful way
+ (flet ((sep ()
+ (format t "~%-------------------------~2%")))
+ (show-classes classes)
+ (sep)
+ (show-classes structs)
+ (sep)
+ (categorize-protocols generics classes)
+ (loop for title in '("Macros" "Functions")
+ for list in (list macros functions) do
+ (sep)
+ (format t "~{~(~A~)~%~}" list)))))
+
(:file "class-finalize" :depends-on ("class-defs" "cpl"))
(:file "class-builder" :depends-on ("class-finalize" "pset"))
(:file "class-layout" :depends-on ("class-defs"))
- (:file "module" :depends-on ("parse-c-types" "tables"))
+ (:file "module" :depends-on ("parse-c-types" "class-defs" "tables"))
+ (:file "builtin" :depends-on ("module" "class-layout"))
(:file "output" :depends-on ("module"))
- (:file "class-output" :depends-on ("class-layout" "output"))))
+ (:file "methods" :depends-on ("class-layout" "codegen" "output"))
+ (:file "class-output" :depends-on ("builtin" "class-builder"
+ "methods" "output"))
+ (:file "combination" :depends-on ("methods"))
+ (:file "module-output" :depends-on ("combination" "class-output"))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Builtin module provides the root of the class graph
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Infrastructure.
+
+(defvar *class-slot-alist* nil)
+
+(defun add-class-slot-function (name function)
+ "Attach a slot function to the *class-slot-alist*.
+
+ The FUNCTION is invoked with one argument, which is a `sod-class' object
+ to which it should add a slot. If a function with the same NAME is
+ already defined then that function is replaced; otherwise a new name/
+ function pair is defined.
+
+ Functions are are invoked in the order in which their names were first
+ added."
+
+ (aif (assoc name *class-slot-alist* :test #'string=)
+ (setf (cdr it) function)
+ (asetf *class-slot-alist* (append it (list (cons name function))))))
+
+(defmacro define-class-slot
+ (name (class &optional stream) type init &body prepare)
+ "Define a new class slot.
+
+ The slot will be caled NAME, and will be of TYPE (which should be a type
+ S-expression). The slot's (static) initializer will be constructed by
+ printing the value of INIT, which is evaluated with CLASS bound to the
+ class object being constructed. If any PREPARE forms are provided, then
+ they are evaluated as a progn; they are evaluated with CLASS bound to the
+ class object, and STREAM bound to the output stream it should write on."
+
+ (with-gensyms (classvar)
+ `(add-class-slot-function
+ ',name
+ (lambda (,classvar)
+ (make-sod-slot ,classvar ,name (c-type ,type)
+ (make-property-set :lisp-class 'sod-class-slot
+ :initializer-function
+ (lambda (,class)
+ ,init)
+ ,@(and prepare
+ `(:prepare-function
+ (lambda (,class ,stream)
+ ,@prepare)))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Basic information.
+
+(define-class-slot "name" (class) const-string
+ (prin1-to-string (sod-class-name class)))
+
+(define-class-slot "nick" (class) const-string
+ (prin1-to-string (sod-class-nickname class)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance allocation and initialization.
+
+(define-class-slot "initsz" (class) size-t
+ (format nil "sizeof(struct ~A)" (ilayout-struct-tag class)))
+
+(define-class-slot "imprint" (class stream)
+ (* (fun (* void) ("/*p*/" (* void))))
+ (format nil "~A__imprint" class)
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+/* Imprint raw memory with instance structure. */
+static void *~A__imprint(void *p)
+{
+ struct ~A *sod__obj = p;
+
+ ~:{sod__obj.~A.~A._vt = &~A;~:^~% ~}
+ return (p);
+}~2%"
+ class
+ (ilayout-struct-tag class)
+ (mapcar (lambda (ichain)
+ (let* ((head (ichain-head ichain))
+ (tail (ichain-tail ichain)))
+ (list (sod-class-nickname head)
+ (sod-class-nickname tail)
+ (vtable-name class head))))
+ (ilayout-ichains ilayout)))))
+
+(define-class-slot "init" (class stream)
+ (* (fun (* void) ("/*p*/" (* void))))
+ (format nil "~A__init" class)
+
+ ;; FIXME this needs a metaobject protocol
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__init(void *p)
+{
+ struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+ class
+ (ilayout-struct-tag class))
+ (dolist (ichain (ilayout-ichains ilayout))
+ (let ((ich (format nil "sod__obj.~A.~A"
+ (sod-class-nickname (ichain-head ichain))
+ (sod-class-nickname (ichain-tail ichain)))))
+ (dolist (item (ichain-body ichain))
+ (etypecase item
+ (vtable-pointer
+ nil)
+ (islots
+ (let ((isl (format nil "~A.~A"
+ ich
+ (sod-class-nickname (islots-class item)))))
+ (dolist (slot (islots-slots item))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (format stream " ~A.~A =" isl
+ (sod-slot-name dslot))
+ (ecase (sod-initializer-value-kind init)
+ (:simple (write (sod-initializer-value-form init)
+ :stream stream
+ :pretty nil :escape nil)
+ (format stream ";~%"))
+ (:compound (format stream " (~A) {"
+ (sod-slot-type dslot))
+ (write (sod-initializer-value-form init)
+ :stream stream
+ :pretty nil :escape nil)
+ (format stream "};~%"))))))))))))
+ (format stream "~&~:
+ return (p);
+}~2%")))
+
+;;;--------------------------------------------------------------------------
+;;; Superclass structure.
+
+(define-class-slot "n_supers" (class) size-t
+ (length (sod-class-direct-superclasses class)))
+
+(define-class-slot "supers" (class stream)
+ (* (* (class "SodClass" :const) :const))
+ (if (null (sod-class-direct-superclasses class)) 0
+ (format nil "~A__supers" class))
+ (let ((supers (sod-class-direct-superclasses class)))
+ (when supers
+ (format stream "~&~:
+/* Direct superclasses. */
+static const SodClass *const ~A__supers[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class supers))))
+
+(define-class-slot "n_cpl" (class) size-t
+ (length (sod-class-precedence-list class)))
+
+(define-class-slot "cpl" (class stream)
+ (* (* (class "SodClass" :const) :const))
+ (format nil "~A__cpl" class)
+ (format stream "~&~:
+/* Class precedence list. */
+static const SodClass *const ~A__cpl[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class (sod-class-precedence-list class)))
+
+;;;--------------------------------------------------------------------------
+;;; Chain structure.
+
+(define-class-slot "link" (class) (* (class "SodClass" :const))
+ (aif (sod-class-chain-link class)
+ (format nil "~A__class" it)
+ 0))
+
+(define-class-slot "head" (class) (* (class "SodClass" :const))
+ (format nil "~A__class" (sod-class-chain-head class)))
+
+(define-class-slot "level" (class) size-t
+ (position class (reverse (sod-class-chain class))))
+
+(define-class-slot "n_chains" (class) size-t
+ (length (sod-class-chains class)))
+
+(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const))
+ (format nil "~A__chains" class)
+ (let ((chains (sod-class-chains class)))
+ (format stream "~&~:
+/* Chain structure. */
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+ ~{~A__class~^,~% ~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{ { ~3@*~A,
+ ~0@*&~A__chain_~A,
+ ~4@*offsetof(struct ~A, ~A),
+ (const struct sod_vtable *)&~A,
+ sizeof(struct ~A) }~:^,~%~}
+};~2%"
+ class ;0
+ (mapcar (lambda (chain) ;1
+ (let* ((head (sod-class-chain-head (car chain)))
+ (chain-nick (sod-class-nickname head)))
+ (list class chain-nick ;0 1
+ (reverse chain) ;2
+ (length chain) ;3
+ (ilayout-struct-tag class) chain-nick ;4 5
+ (vtable-name class head) ;6
+ (ichain-struct-tag class head)))) ;7
+ chains))))
+
+;;;--------------------------------------------------------------------------
+;;; Class-specific layout.
+
+(define-class-slot "off_islots" (class) size-t
+ (format nil "offsetof(struct ~A, ~A)"
+ (ichain-struct-tag class (sod-class-chain-head class))
+ (sod-class-nickname class)))
+
+(define-class-slot "islotsz" (class) size-t
+ (format nil "sizeof(struct ~A)"
+ (islots-struct-tag class)))
+
+;;;--------------------------------------------------------------------------
+;;; Bootstrapping the class graph.
+
+(defun bootstrap-classes (module)
+ (let* ((sod-object (make-sod-class "SodObject" nil
+ (make-property-set :nick 'obj)))
+ (sod-class (make-sod-class "SodClass" (list sod-object)
+ (make-property-set :nick 'cls)))
+ (classes (list sod-object sod-class)))
+
+ ;; Sort out the recursion.
+ (setf (slot-value sod-class 'chain-link) sod-object)
+ (dolist (class classes)
+ (setf (slot-value class 'metaclass) sod-class))
+
+ ;; Predeclare the class types.
+ (dolist (class classes)
+ (make-class-type (sod-class-name class)))
+
+ ;; Attach the class slots.
+ (dolist (slot *class-slot-alist*)
+ (funcall (cdr slot) sod-class))
+
+ ;; These classes are too closely intertwined. We must partially finalize
+ ;; them together by hand. This is cloned from `finalize-sod-class'.
+ (dolist (class classes)
+ (with-slots (class-precedence-list chain-head chain chains) class
+ (setf class-precedence-list (compute-cpl class))
+ (setf (values chain-head chain chains) (compute-chains class))))
+
+ ;; Done.
+ (dolist (class classes)
+ (finalize-sod-class class)
+ (add-to-module module class))))
+
+(defun make-builtin-module ()
+ (let ((module (make-instance 'module
+ :name (make-pathname :name "SOD-BASE"
+ :type "SOD"
+ :case :common)
+ :state nil))
+ (include (format nil "#include \"~A\"~%"
+ (make-pathname :name "SOD" :type "H"
+ :case :common))))
+ (call-with-module-environment
+ (lambda ()
+ (dolist (name '("va_list" "size_t" "ptrdiff_t"))
+ (add-to-module module (make-instance 'type-item :name name)))
+ (add-to-module module (make-instance 'code-fragment-item
+ :reason :c
+ :constraints nil
+ :name :includes
+ :fragment include))
+ (bootstrap-classes module)))
+ module))
+
+(defvar *builtin-module* nil)
+
+(define-clear-the-decks reset-builtin-module
+ (setf *builtin-module* (make-builtin-module)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; A collection of utility functions for SOD classes
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Finding things by name
+
+(export 'find-superclass-by-nick)
+(defun find-superclass-by-nick (class nick)
+ "Returns the superclass of CLASS with nickname NICK, or signals an error."
+
+ ;; Slightly tricky. The class almost certainly hasn't been finalized, so
+ ;; trundle through its superclasses and hope for the best.
+ (if (string= nick (sod-class-nickname class))
+ class
+ (or (some (lambda (super)
+ (find nick (sod-class-precedence-list super)
+ :key #'sod-class-nickname
+ :test #'string=))
+ (sod-class-direct-superclasses class))
+ (error "No superclass of `~A' with nickname `~A'" class nick))))
+
+(export '(find-instance-slot-by-name find-class-slot-by-name
+ find-message-by-name))
+(flet ((find-thing-by-name (what class list name key)
+ (or (find name list :key key :test #'string=)
+ (error "No ~A in class `~A' with name `~A'" what class name))))
+
+ (defun find-instance-slot-by-name (class super-nick slot-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-thing-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-class-slot-by-name (class super-nick slot-name)
+ (let* ((meta (sod-class-metaclass class))
+ (super (find-superclass-by-nick meta super-nick)))
+ (find-thing-by-name "slot" super (sod-class-slots super)
+ slot-name #'sod-slot-name)))
+
+ (defun find-message-by-name (class super-nick message-name)
+ (let ((super (find-superclass-by-nick class super-nick)))
+ (find-thing-by-name "message" super (sod-class-messages super)
+ message-name #'sod-message-name))))
+
+;;;--------------------------------------------------------------------------
+;;; Miscellaneous useful functions.
+
+(export 'sod-subclass-p)
+(defun sod-subclass-p (class-a class-b)
+ "Return whether CLASS-A is a descendent of CLASS-B.
+
+ Careful! Assumes that the class precedence list of CLASS-A has been
+ computed!"
+ (member class-b (sod-class-precedence-list class-a)))
+
+(export 'valid-name-p)
+(defun valid-name-p (name)
+ "Checks whether NAME is a valid name.
+
+ The rules are:
+
+ * the name must be a string
+ * which is nonempty
+ * whose first character is alphabetic
+ * all of whose characters are alphanumeric or underscores
+ * and which doesn't contain two consecutive underscores."
+
+ (and (stringp name)
+ (plusp (length name))
+ (alpha-char-p (char name 0))
+ (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name)
+ (not (search "__" name))))
+
+(export 'find-root-superclass)
+(defun find-root-superclass (class)
+ "Returns the `root' superclass of CLASS.
+
+ The root superclass is the superclass which itself has no direct
+ superclasses. In universes not based on the provided builtin module, the
+ root class may not be our beloved SodObject; however, there must be one
+ (otherwise the class graph is cyclic, which should be forbidden), and we
+ insist that it be unique."
+
+ ;; The root superclass must be a chain head since the chains partition the
+ ;; superclasses; the root has no superclasses so it can't have a link and
+ ;; must therefore be a head. This narrows the field down quite a lot.
+ ;;
+ ;; Note! This function gets called from `check-sod-class' before the
+ ;; class's chains have been computed. Therefore we iterate over the direct
+ ;; superclass's chains rather than the class's own. This misses a chain
+ ;; only in the case where the class is its own chain head. There are two
+ ;; subcases: if there are no direct superclasses at all, then the class is
+ ;; its own root; otherwise, it clearly can't be the root and the omission
+ ;; is harmless.
+
+ (let* ((supers (sod-class-direct-superclasses class))
+ (roots (if supers
+ (remove-duplicates
+ (remove-if #'sod-class-direct-superclasses
+ (mappend (lambda (super)
+ (mapcar (lambda (chain)
+ (sod-class-chain-head
+ (car chain)))
+ (sod-class-chains super)))
+ supers)))
+ (list class))))
+ (cond ((null roots) (error "Class ~A has no root class!" class))
+ ((cdr roots) (error "Class ~A has multiple root classes ~
+ ~{~A~#[~; and ~;, ~]~}"
+ class roots))
+ (t (car roots)))))
+
+(export 'find-root-metaclass)
+(defun find-root-metaclass (class)
+ "Returns the `root' metaclass of CLASS.
+
+ The root metaclass is the metaclass of the root superclass -- see
+ `find-root-superclass'."
+ (sod-class-metaclass (find-root-superclass class)))
+
+;;;--------------------------------------------------------------------------
+;;; Type hacking.
+
+(export 'argument-lists-compatible-p)
+(defun argument-lists-compatible-p (message-args method-args)
+ "Compare argument lists for compatibility.
+
+ Return true if METHOD-ARGS is a suitable method argument list
+ corresponding to the message argument list MESSAGE-ARGS. This is the case
+ if the lists are the same length, each message argument has a
+ corresponding method argument with the same type, and if the message
+ arguments end in an ellpisis, the method arguments must end with a
+ `va_list' argument. (We can't pass actual variable argument lists around,
+ except as `va_list' objects, which are devilish inconvenient things and
+ require much hacking. See the method combination machinery for details.)"
+
+ (and (= (length message-args) (length method-args))
+ (every (lambda (message-arg method-arg)
+ (if (eq message-arg :ellipsis)
+ (eq method-arg (c-type va-list))
+ (c-type-equal-p (argument-type message-arg)
+ (argument-type method-arg))))
+ message-args method-args)))
+
+;;;--------------------------------------------------------------------------
+;;; Names of things.
+
+(export 'islots-struct-tag)
+(defun islots-struct-tag (class)
+ (format nil "~A__islots" class))
+
+(export 'ichain-struct-tag)
+(defun ichain-struct-tag (class chain-head)
+ (format nil "~A__ichain_~A" class (sod-class-nickname chain-head)))
+
+(export 'ichain-union-tag)
+(defun ichain-union-tag (class chain-head)
+ (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head)))
+
+(export 'ilayout-struct-tag)
+(defun ilayout-struct-tag (class)
+ (format nil "~A__ilayout" class))
+
+(export 'vtmsgs-struct-tag)
+(defun vtmsgs-struct-tag (class super)
+ (format nil "~A__vtmsgs_~A" class (sod-class-nickname super)))
+
+(export 'vtable-struct-tag)
+(defun vtable-struct-tag (class chain-head)
+ (format nil "~A__vt_~A" class (sod-class-nickname chain-head)))
+
+(export 'vtable-name)
+(defun vtable-name (class chain-head)
+ (format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class definitions for main classes
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(export '(sod-class sod-class-name sod-class-nickname
+ sod-class-type sod-class-metaclass
+ sod-class-direct-superclasses sod-class-precedence-list
+ sod-class-chain-link sod-class-chain-head
+ sod-class-chain sod-class-chains
+ sod-class-slots
+ sod-class-instance-initializers sod-class-class-initializers
+ sod-class-messages sod-class-methods
+ sod-class-state
+ sod-class-ilayout sod-class-vtables))
+(defclass sod-class ()
+ ((name :initarg :name :type string :reader sod-class-name)
+ (location :initarg :location :initform (file-location nil)
+ :type file-location :reader file-location)
+ (nickname :initarg :nick :type string :reader sod-class-nickname)
+ (direct-superclasses :initarg :superclasses :type list
+ :reader sod-class-direct-superclasses)
+ (chain-link :initarg :link :type (or sod-class null)
+ :reader sod-class-chain-link)
+ (metaclass :initarg :metaclass :type sod-class
+ :reader sod-class-metaclass)
+ (slots :initarg :slots :initform nil
+ :type list :accessor sod-class-slots)
+ (instance-initializers :initarg :instance-initializers :initform nil
+ :type list
+ :accessor sod-class-instance-initializers)
+ (class-initializers :initarg :class-initializers :initform nil
+ :type list :accessor sod-class-class-initializers)
+ (messages :initarg :messages :initform nil
+ :type list :accessor sod-class-messages)
+ (methods :initarg :methods :initform nil
+ :type list :accessor sod-class-methods)
+
+ (class-precedence-list :type list :accessor sod-class-precedence-list)
+
+ (type :type c-class-type :accessor sod-class-type)
+
+ (chain-head :type sod-class :accessor sod-class-chain-head)
+ (chain :type list :accessor sod-class-chain)
+ (chains :type list :accessor sod-class-chains)
+
+ (ilayout :type ilayout :accessor sod-class-ilayout)
+ (effective-methods :type list :accessor sod-class-effective-methods)
+ (vtables :type list :accessor sod-class-vtables)
+
+ (state :initform nil :type (member nil :finalized broken)
+ :accessor sod-class-state))
+ (:documentation
+ "Classes describe the layout and behaviour of objects.
+
+ The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and
+ METACLASS slots are intended to be initialized when the class object is
+ constructed:
+
+ * The NAME is the identifier associated with the class in the user's
+ source file. It is used verbatim in the generated C code as a type
+ name, and must be distinct from other file-scope names in any source
+ file which includes the class definition. Furthermore, other names
+ are derived from the class name (most notably the class object
+ NAME__class), which have external linkage and must therefore be
+ distinct from all other identifiers in the program. It is forbidden
+ for a class NAME to begin with an underscore or to contain two
+ consecutive underscores.
+
+ * The LOCATION identifies where in the source the class was defined. It
+ gets used in error messages.
+
+ * The NICKNAME is a shorter identifier used to name the class in some
+ circumstances. The uniqueness requirements on NICKNAME are less
+ strict, which allows them to be shorter: no class may have two classes
+ with the same nickname on its class precedence list. Nicknames are
+ used (user-visibly) to distinguish slots and messages defined by
+ different classes, and (invisibly) in the derived names of direct
+ methods. It is forbidden for a nickname to begin with an underscore,
+ or to contain two consecutive underscores.
+
+ * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses,
+ in the order that they were declared in the source. The class
+ precedence list is computed from the DIRECT-SUPERCLASSES lists of all
+ of the superclasses involved.
+
+ * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES. Class
+ chains are a means for recovering most of the benefits of simple
+ hierarchy lost by the introduction of multiple inheritance. A class's
+ superclasses (including itself) are partitioned into chains,
+ consisting of a class, its CHAIN-LINK superclass, that class's
+ CHAIN-LINK, and so on. It is an error if two direct subclasses of any
+ class appear in the same chain (a global property which requires
+ global knowledge of an entire program's class hierarchy in order to
+ determine sensibly). Slots of superclasses in the same chain can be
+ accessed efficiently; there is an indirection needed to access slots
+ of superclasses in other chains. Furthermore, an indirection is
+ required to perform a cross-chain conversion (i.e., converting a
+ pointer to an instance of some class into a pointer to an instance of
+ one of its superclasses in a different chain), an operation which
+ occurs implicitly in effective methods in order to call direct methods
+ defined on cross-chain superclasses.
+
+ * The METACLASS is the class of the class object. Classes are objects
+ in their own right, and therefore must be instances of some class;
+ this class is the metaclass. Metaclasses can define additional slots
+ and methods to be provided by their instances; a class definition can
+ provide (C constant expression) initial values for the metaclass
+ instance.
+
+ The next few slots can't usually be set at object-construction time, since
+ the objects need to contain references to the class object itself.
+
+ * The SLOTS are a list of the slots defined by the class (instances of
+ `sod-slot'). (The class will also define all of the slots defined by
+ its superclasses.)
+
+ * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of
+ initializers for slots (see `sod-initializer' and subclasses),
+ providing initial values for instances of the class, and for the
+ class's class object itself, respectively.
+
+ * The MESSAGES are a list of the messages recognized by the class
+ (instances of `sod-message' and subclasses). (Note that the message
+ need not have any methods defined on it. The class will also
+ recognize all of the messages defined by its superclasses.)
+
+ * The METHODS are a list of (direct) methods defined on the class
+ (instances of `sod-method' and subclasses). Each method provides
+ behaviour to be invoked by a particular message recognized by the
+ class.
+
+ Other slots are computed from these in order to describe the class's
+ layout and effective methods; this is done by `finalize-sod-class'.
+
+ * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order.
+ It is computed by `compute-class-precedence-list', whose default
+ implementation ensures that the order of superclasses is such that (a)
+ subclasses appear before their superclasses; (b) the direct
+ superclasses of a given class appear in the order in which they were
+ declared by the programmer; and (c) classes always appear in the same
+ relative order in all class precedence lists in the same superclass
+ graph.
+
+ * The CHAIN-HEAD is the least-specific class in the class's chain. If
+ there is no link class then the CHAIN-HEAD is the class itself. This
+ slot, like the next two, is computed by the generic function
+ `compute-chains'.
+
+ * The CHAIN is the list of classes on the complete primary chain,
+ starting from this class and ending with the CHAIN-HEAD.
+
+ * The CHAINS are the complete collection of chains (most-to-least
+ specific) for the class and all of its superclasses.
+
+ Finally, slots concerning the instance and vtable layout of the class are
+ computed on demand via methods on `slot-unbound'.
+
+ * The ILAYOUT describes the layout for an instance of the class. It's
+ quite complicated; see the documentation of the ILAYOUT class for
+ detais.
+
+ * The EFFECTIVE-METHODS are a list of effective methods, specialized for
+ the class.
+
+ * The VTABLES are a list of descriptions of vtables for the class. The
+ individual elements are VTABLE objects, which are even more
+ complicated than ILAYOUT structures. See the class documentation for
+ details."))
+
+(defmethod print-object ((class sod-class) stream)
+ (maybe-print-unreadable-object (class stream :type t)
+ (princ (sod-class-name class) stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Slots and initializers.
+
+(export '(sod-slot sod-slot-name sod-slot-class sod-slot-type))
+(defclass sod-slot ()
+ ((name :initarg :name :type string :reader sod-slot-name)
+ (location :initarg :location :initform (file-location nil)
+ :type file-location :reader file-location)
+ (class :initarg :class :type sod-class :reader sod-slot-class)
+ (type :initarg :type :type c-type :reader sod-slot-type))
+ (:documentation
+ "Slots are units of information storage in instances.
+
+ Each class defines a number of slots, which function similarly to (data)
+ members in structures. An instance contains all of the slots defined in
+ its class and all of its superclasses.
+
+ A slot carries the following information.
+
+ * A NAME, which distinguishes it from other slots defined by the same
+ class. Unlike most (all?) other object systems, slots defined in
+ different classes are in distinct namespaces. There are no special
+ restrictions on slot names.
+
+ * A LOCATION, which states where in the user's source the slot was
+ defined. This gets used in error messages.
+
+ * A CLASS, which states which class defined the slot. The slot is
+ available in instances of this class and all of its descendents.
+
+ * A TYPE, which is the C type of the slot. This must be an object type
+ (certainly not a function type, and it must be a complete type by the
+ time that the user header code has been scanned)."))
+
+(defmethod print-object ((slot sod-slot) stream)
+ (maybe-print-unreadable-object (slot stream :type t)
+ (pprint-c-type (sod-slot-type slot) stream
+ (format nil "~A.~A"
+ (sod-class-nickname (sod-slot-class slot))
+ (sod-slot-name slot)))))
+
+(export '(sod-initializer sod-initializer-slot sod-initializer-class
+ sod-initializer-value-kind sod-initializer-value-form))
+(defclass sod-initializer ()
+ ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
+ (location :initarg :location :initform (file-location nil)
+ :type file-location :reader file-location)
+ (class :initarg :class :type sod-class :reader sod-initializer-class)
+ (value-kind :initarg :value-kind :type keyword
+ :reader sod-initializer-value-kind)
+ (value-form :initarg :value-form :type c-fragment
+ :reader sod-initializer-value-form))
+ (:documentation
+ "Provides an initial value for a slot.
+
+ The slots of an initializer are as follows.
+
+ * The SLOT specifies which slot this initializer is meant to initialize.
+
+ * The LOCATION states the position in the user's source file where the
+ initializer was found. This gets used in error messages. (Depending
+ on the source layout style, this might differ from the location in the
+ VALUE-FORM C fragment.)
+
+ * The CLASS states which class defined this initializer. For instance
+ slot initializers (`sod-instance-initializer'), this will be the same
+ as the SLOT's class, or be one of its descendants. For class slot
+ initializers (`sod-class-initializer'), this will be an instance of
+ the SLOT's class, or an instance of one of its descendants.
+
+ * The VALUE-KIND states what manner of initializer we have. It can be
+ either `:single', indicating a standalone expression, or `:compound',
+ indicating a compound initializer which must be surrounded by braces
+ on output.
+
+ * The VALUE-FORM gives the text of the initializer, as a C fragment.
+
+ Typically you'll see instances of subclasses of this class in the wild
+ rather than instances of this class directly. See `sod-class-initializer'
+ and `sod-instance-initializer'."))
+
+(defmethod print-object ((initializer sod-initializer) stream)
+ (if *print-escape*
+ (print-unreadable-object (initializer stream :type t)
+ (format stream "~A = ~A"
+ (sod-initializer-slot initializer)
+ initializer))
+ (format stream "~:[{~A}~;~A~]"
+ (eq (sod-initializer-value-kind initializer) :single)
+ (sod-initializer-value-form initializer))))
+
+(export 'sod-class-initializer)
+(defclass sod-class-initializer (sod-initializer)
+ ()
+ (:documentation
+ "Provides an initial value for a class slot.
+
+ A class slot initializer provides an initial value for a slot in the class
+ object (i.e., one of the slots defined by the class's metaclass). Its
+ VALUE-FORM must have the syntax of an initializer, and its consituent
+ expressions must be constant expressions.
+
+ See `sod-initializer' for more details."))
+
+(export 'sod-instance-initializer)
+(defclass sod-instance-initializer (sod-initializer)
+ ()
+ (:documentation
+ "Provides an initial value for a slot in all instances.
+
+ An instance slot initializer provides an initial value for a slot in
+ instances of the class. Its VALUE-FORM must have the syntax of an
+ initializer. Furthermore, if the slot has aggregate type, then you'd
+ better be sure that your compiler supports compound literals (6.5.2.5)
+ because that's what the initializer gets turned into.
+
+ See `sod-initializer' for more details."))
+
+;;;--------------------------------------------------------------------------
+;;; Messages and methods.
+
+(export '(sod-message sod-message-name sod-message-class sod-message-type))
+(defclass sod-message ()
+ ((name :initarg :name :type string :reader sod-message-name)
+ (location :initarg :location :initform (file-location nil)
+ :type file-location :reader file-location)
+ (class :initarg :class :type sod-class :reader sod-message-class)
+ (type :initarg :type :type c-function-type :reader sod-message-type))
+ (:documentation
+ "Messages the means for stimulating an object to behave.
+
+ SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
+ on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages'
+ to objects. A message carries a name (distinguishing it from other
+ messages recognized by the same class), and a number of arguments; the
+ object may return a value in response. Sending a message therefore looks
+ very much like calling a function; indeed, each message bears the static
+ TYPE signature of a function.
+
+ An object reacts to being sent a message by executing an `effective
+ method', constructed from the direct methods defined on the recpient's
+ (run-time, not necessarily statically-declared) class and its superclasses
+ according to the message's `method combination'.
+
+ Much interesting work is done by subclasses of `sod-message', which (for
+ example) specify method combinations.
+
+ The slots are as follows.
+
+ * The NAME distinguishes the message from others defined by the same
+ class. Unlike most (all?) other object systems, messages defined in
+ different classes are in distinct namespaces. It is forbidden for a
+ message name to begin with an underscore, or to contain two
+ consecutive underscores. (Final underscores are fine.)
+
+ * The LOCATION states where in the user's source the slot was defined.
+ It gets used in error messages.
+
+ * The CLASS states which class defined the message.
+
+ * The TYPE is a function type describing the message's arguments and
+ return type.
+
+ Subclasses can (and probably will) define additional slots."))
+
+(defmethod print-object ((message sod-message) stream)
+ (maybe-print-unreadable-object (message stream :type t)
+ (pprint-c-type (sod-message-type message) stream
+ (format nil "~A.~A"
+ (sod-class-nickname (sod-message-class message))
+ (sod-message-name message)))))
+
+(export '(sod-method sod-method-message sod-method-class sod-method-type
+ sod-method-body))
+(defclass sod-method ()
+ ((message :initarg :message :type sod-message :reader sod-method-message)
+ (location :initarg :location :initform (file-location nil)
+ :type file-location :reader file-location)
+ (class :initarg :class :type sod-class :reader sod-method-class)
+ (type :initarg :type :type c-function-type :reader sod-method-type)
+ (body :initarg :body :type (or c-fragment null) :reader sod-method-body))
+ (:documentation
+ "(Direct) methods are units of behaviour.
+
+ Methods are the unit of behaviour in SOD. Classes define direct methods
+ for particular messages.
+
+ When a message is received by an instance, all of the methods defined for
+ that message on that instance's (run-time, not static) class and its
+ superclasses are `applicable'. The applicable methods are gathered
+ together and invoked in some way; the details of this are left to the
+ `method combination', determined by the subclass of `sod-message'.
+
+ The slots are as follows.
+
+ * The MESSAGE describes which meessage invokes the method's behaviour.
+ The method is combined with other methods on the same message
+ according to the message's method combination, to form an `effective
+ method'.
+
+ * The LOCATION states where, in the user's source, the method was
+ defined. This gets used in error messages. (Depending on the user's
+ coding style, this location might be subtly different from the BODY's
+ location.)
+
+ * The CLASS specifies which class defined the method. This will be
+ either the class of the message, or one of its descendents.
+
+ * The TYPE gives the type of the method, including its arguments. This
+ will, in general, differ from the type of the message for several
+ reasons.
+
+ -- Firstly, the method type must include names for all of the
+ method's parameters. The message definition can omit the
+ parameter names (in the same way as a function declaration can).
+ Formally, the message definition can contain abstract
+ declarators, whereas method definitions must not.
+
+ -- Method combinations may require different parameter or return
+ types. For example, `before' and `after' methods don't
+ contribute to the message's return value, so they must be defined
+ as returning `void'.
+
+ -- Method combinations may permit methods whose parameter and/or
+ return types don't exactly match the corresponding types of the
+ message. For example, one might have methods with covariant
+ return types and contravariant parameter types. (This sounds
+ nice, but it doesn't actually seem like such a clever idea when
+ you consider that the co-/contravariance must hold among all the
+ applicable methods ordered according to the class precedence
+ list. As a result, a user might have to work hard to build
+ subclasses whose CPLs match the restrictions implied by the
+ method types.)
+
+ Method objects are fairly passive in the SOD translator. However,
+ subclasses of `sod-message' may (and probably will) construct instances of
+ subclasses of `sod-method' in order to carry the additional metadata they
+ need to keep track of."))
+
+(defmethod print-object ((method sod-method) stream)
+ (maybe-print-unreadable-object (method stream :type t)
+ (format stream "~A ~@_~A"
+ (sod-method-message method)
+ (sod-method-class method))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+(cl:in-package #:sod)
+
+(defun list-tokens (scanner)
+ (let ((toke (make-instance 'sod-token-scanner :char-scanner scanner)))
+ (loop collect (list (token-type toke) (token-value toke))
+ until (scanner-at-eof-p toke)
+ do (scanner-step toke))))
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Integrating classes into the C type system
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Class definition.
+
+(export '(c-class-type c-type-class))
+(defclass c-class-type (simple-c-type)
+ ((class :initarg :class :initform nil
+ :type (or null sod-class) :accessor c-type-class)
+ (tag :initarg :tag))
+ (:documentation
+ "A SOD class, as a C type.
+
+ One usually handles classes as pointers, but the type refers to the actual
+ instance structure itself. Or, in fact, just the primary chain of the
+ instance (i.e., the one containing the class's own direct slots) -- which
+ is why dealing with the instance structure directly doesn't make much
+ sense.
+
+ The CLASS slot will be NIL if the class isn't defined yet, i.e., this
+ entry was constructed by a forward reference operation.
+
+ The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print
+ the type even when it's a forward reference."))
+
+;; Constructor function and interning.
+
+(define-module-var *module-type-map* (make-hash-table :test #'equal)
+ "Table mapping identifiers to C type objects.
+
+ Each module has its own map.")
+
+(export 'find-class-type)
+(defun find-class-type (name)
+ "Look up NAME and return the corresponding C-CLASS-TYPE.
+
+ * If the type was found, and was a class, returns TYPE.
+
+ * If no type was found at all, returns NIL.
+
+ * If a type was found, but it wasn't a class, signals an error."
+
+ (atypecase (gethash name *module-type-map*)
+ (null nil)
+ (c-class-type it)
+ (t (error "Type `~A' (~A) is not a class" name it))))
+
+(export 'make-class-type)
+(defun make-class-type (name &optional qualifiers)
+ "Make a distinguished object for the class type called NAME."
+
+ ;; We're in an awkward situation. We want to enter it into the
+ ;; `*c-type-intern-map*' so that it will handle the qualifiers list for
+ ;; us. But that map isn't scoped to particular modules, so we maintain our
+ ;; own `*module-type-map*'. But now we need to keep them in sync.
+ ;;
+ ;; The solution is to make the `*module-type-map*' be the master. Each
+ ;; class-type object has a tag -- a gensym, so that `equal' will think
+ ;; they're different, and we use the tag as part of the input to
+ ;; `intern-c-type'.
+ ;;
+ ;; So the first thing to do is to find the tag for the basic type, without
+ ;; any qualifiers.
+ (multiple-value-bind (type tag)
+ (aif (find-class-type name)
+ (values it (slot-value it 'tag))
+ (let* ((tag (gensym "TAG-"))
+ (type (intern-c-type 'c-class-type :name name :tag tag)))
+ (values type tag)))
+
+ ;; If no qualifiers are wanted then we've already found or created the
+ ;; wanted type. Otherwise we'll intern another type with the right
+ ;; qualifiers.
+ (if (null qualifiers)
+ type
+ (intern-c-type 'c-class-type
+ :name name :tag tag
+ :qualifiers (canonify-qualifiers qualifiers)))))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and
+ ((type-a c-class-type) (type-b c-class-type))
+ (eql (c-type-class type-a) (c-type-class type-b)))
+
+;; S-expression notation protocol.
+
+(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<CLASS ~:@_~:I~S~{ ~_~S~}~:>"
+ (c-type-name type)
+ (c-type-qualifiers type)))
+
+(export 'class)
+(define-c-type-syntax class (name &rest quals)
+ "Returns a type object for the named class."
+ `(make-class-type ,name (list ,@quals)))
+
+;;;--------------------------------------------------------------------------
+;;; Additional functions for lookup.
+
+(export 'find-sod-class)
+(defun find-sod-class (name)
+ "Return the SOD-CLASS object with the given NAME."
+ (aif (find-class-type name)
+ (or (c-type-class it) (error "Class `~A' is incomplete" name))
+ (error "Type `~A' not known" name)))
+
+(export 'record-sod-class)
+(defun record-sod-class (class)
+ "Record CLASS as being a class definition."
+ (with-default-error-location (class)
+ (let* ((name (sod-class-name class))
+ (type (make-class-type name)))
+ (if (c-type-class type)
+ (cerror* "Class `~A' already defined at ~A"
+ name (file-location (c-type-class type)))
+ (setf (c-type-class type) class)))))
+
+;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; Dealing with C types
+;;; C type representation implementation
;;;
-;;; (c) 2008 Straylight/Edgeware
+;;; (c) 2009 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; 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
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Plain old C types.
-
-;; Class definition.
-
-(defclass c-type ()
- ()
- (:documentation
- "Base class for C type objects."))
-
-;; Important protocol.
-
-(defgeneric c-type-subtype (type)
- (:documentation
- "For compound types, return the base type."))
-
-(defgeneric c-type-equal-p (type-a type-b)
- (:method-combination and)
- (:documentation
- "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
- (:method and (type-a type-b)
- (eql (class-of type-a) (class-of type-b))))
-
-(defgeneric pprint-c-type (type stream kernel)
- (:documentation
- "Pretty-printer for C types.
-
- Print TYPE to STREAM. In the middle of the declarator, call the function
- KERNEL with one argument: whether it needs a leading space.")
- (:method :around (type stream kernel)
- (typecase kernel
- (function (call-next-method))
- (null (pprint-c-type type stream
- (lambda (stream prio spacep)
- (declare (ignore stream prio spacep))
- nil)))
- (t (pprint-c-type type stream
- (lambda (stream prio spacep)
- (declare (ignore prio))
- (when spacep
- (c-type-space stream))
- (princ kernel stream)))))))
-
-(defgeneric print-c-type (stream type &optional colon atsign)
- (:documentation
- "Print an abbreviated syntax for TYPE to the STREAM."))
-
-(defmethod print-object ((object c-type) stream)
- (if *print-escape*
- (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
- (pprint-c-type object stream nil)))
-
-;; Utility functions and macros.
-
-(defun c-type-space (stream)
- "Print a space and a miser-mode newline to STREAM.
-
- This is the right function to call in a PPRINT-C-TYPE kernel function when
- the SPACEP argument is true."
- (pprint-indent :block 2 stream)
- (write-char #\space stream)
- (pprint-newline :miser stream))
-
-(defun maybe-in-parens* (stream condition thunk)
- "Helper function for the MAYBE-IN-PARENS macro."
- (pprint-logical-block
- (stream nil
- :prefix (if condition "(" "")
- :suffix (if condition ")" ""))
- (funcall thunk stream)))
-
-(defmacro maybe-in-parens ((stream condition) &body body)
- "Evaluate BODY; if CONDITION, write parens to STREAM around it.
-
- This macro is useful for implementing the PPRINT-C-TYPE method on compound
- types. The BODY is evaluated in the context of a logical block printing
- to STREAM. If CONDITION is non-nil, then the block will have open/close
- parens as its prefix and suffix; otherwise they will be empty.
-
- The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
- `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
-
-;; S-expression syntax machinery.
-
-(defun c-name-case (name)
- "Convert NAME to suitable case.
-
- Strings are returned as-is; symbols are squashed to lower-case and hyphens
- are replaced by underscores."
- (typecase name
- (symbol (with-output-to-string (out)
- (loop for ch across (symbol-name name)
- do (cond ((alpha-char-p ch)
- (write-char (char-downcase ch) out))
- ((or (digit-char-p ch)
- (char= ch #\_))
- (write-char ch out))
- ((char= ch #\-)
- (write-char #\_ out))
- (t
- (error "Bad character in C name ~S." name))))))
- (t name)))
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defgeneric expand-c-type-spec (spec)
- (:documentation
- "Expand SPEC into Lisp code to construct a C type.")
- (:method ((spec list))
- (expand-c-type-form (car spec) (cdr spec))))
- (defgeneric expand-c-type-form (head tail)
- (:documentation
- "Expand a C type list beginning with HEAD.")
- (:method ((name (eql 'lisp)) tail)
- `(progn ,@tail))))
-
-(defmacro c-type (spec)
- "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
- (expand-c-type-spec spec))
-
-(defmacro define-c-type-syntax (name bvl &rest body)
- "Define a C-type syntax function.
-
- A function defined by BODY and with lambda-list BVL is associated with the
- NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
- function with the argument list STUFF."
- (let ((headvar (gensym "HEAD"))
- (tailvar (gensym "TAIL")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
- (destructuring-bind ,bvl ,tailvar
- ,@body)))))
-
-(defmacro c-type-alias (original &rest aliases)
- "Make ALIASES behave the same way as the ORIGINAL type."
- (let ((headvar (gensym "HEAD"))
- (tailvar (gensym "TAIL")))
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(mapcar (lambda (alias)
- `(defmethod expand-c-type-form
- ((,headvar (eql ',alias)) ,tailvar)
- (expand-c-type-form ',original ,tailvar)))
- aliases))))
-
-(defmacro defctype (names value)
- "Define NAMES all to describe the C-type VALUE.
-
- NAMES can be a symbol (treated as a singleton list), or a list of symbols.
- The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will
- be expanded once at run-time."
- (let* ((names (if (listp names) names (list names)))
- (namevar (gensym "NAME"))
- (typevar (symbolicate 'c-type- (car names))))
- `(progn
- (defparameter ,typevar ,(expand-c-type-spec value))
- (eval-when (:compile-toplevel :load-toplevel :execute)
- ,@(mapcar (lambda (name)
- `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
- ',typevar))
- names)))))
+;;; Interning types.
+
+(defparameter *c-type-intern-map* (make-hash-table :test #'equal)
+ "Hash table mapping lists describing types to their distinguished
+ representations.")
+
+(defun intern-c-type (class &rest initargs)
+ "If the CLASS and INITARGS have already been interned, then return the
+ existing object; otherwise make a new one."
+ (let ((list (cons class initargs)))
+ (or (gethash list *c-type-intern-map*)
+ (let ((new (apply #'make-instance class initargs)))
+ (setf (gethash new *c-type-intern-map*) t
+ (gethash list *c-type-intern-map*) new)))))
+
+#+test
+(defun check-type-intern-map ()
+ "Sanity check for the type-intern map."
+ (let ((map (make-hash-table)))
+
+ ;; Pass 1: check that interned types are consistent with their keys.
+ ;; Remember interned types.
+ (maphash (lambda (k v)
+ (when (listp k)
+ (let ((ty (apply #'make-instance k)))
+ (assert (c-type-equal-p ty v)))
+ (setf (gethash v map) t)))
+ *c-type-intern-map*)
+
+ ;; Pass 2: check that the interned type indicators are correct.
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (assert (gethash k *c-type-intern-map*)))
+ map)
+ (maphash (lambda (k v)
+ (declare (ignore v))
+ (when (typep k 'c-type)
+ (assert (gethash k map))))
+ *c-type-intern-map*)))
;;;--------------------------------------------------------------------------
-;;; Types which can accept qualifiers.
+;;; Simple C types.
-;; Basic definitions.
+;; Class definition.
-(defclass qualifiable-c-type (c-type)
- ((qualifiers :initarg :qualifiers :initform nil
- :type list :accessor c-type-qualifiers))
+(export '(simple-c-type c-type-name))
+(defclass simple-c-type (qualifiable-c-type)
+ ((name :initarg :name :type string :reader c-type-name))
(:documentation
- "Base class for C types which can be qualified."))
-
-(defun format-qualifiers (quals)
- "Return a string listing QUALS, with a space after each."
- (format nil "~{~(~A~) ~}" quals))
-
-(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
- (type-b qualifiable-c-type))
- (flet ((fix (type)
- (sort (copy-list (c-type-qualifiers type)) #'string<)))
- (equal (fix type-a) (fix type-b))))
-
-;; A handy utility.
-
-(let ((cache (make-hash-table :test #'equal)))
- (defun qualify-type (c-type qualifiers)
- "Returns a qualified version of C-TYPE.
-
- Maintains a cache of qualified types so that we don't have to run out of
- memory. This can also speed up type comparisons."
- (if (null qualifiers)
- c-type
- (let ((key (cons c-type qualifiers)))
- (unless (typep c-type 'qualifiable-c-type)
- (error "~A isn't qualifiable." (class-name (class-of c-type))))
- (or (gethash key cache)
- (setf (gethash key cache)
- (copy-instance c-type :qualifiers qualifiers)))))))
+ "C types with simple forms."))
-;;;--------------------------------------------------------------------------
-;;; Simple C types (e.g., built-in arithmetic types).
+;; Constructor function and interning.
-(defvar *simple-type-map* (make-hash-table :test #'equal)
- "A hash table mapping type strings to Lisp symbols naming them.")
+(export 'make-simple-type)
+(defun make-simple-type (name &optional qualifiers)
+ "Make a distinguished object for the simple type called NAME."
+ (intern-c-type 'simple-c-type
+ :name name
+ :qualifiers (canonify-qualifiers qualifiers)))
-;; Basic definitions.
+;; Comparison protocol.
-(defclass simple-c-type (qualifiable-c-type)
- ((name :initarg :name :type string :reader c-type-name))
- (:documentation
- "C types with simple forms."))
+(defmethod c-type-equal-p and
+ ((type-a simple-c-type) (type-b simple-c-type))
+ (string= (c-type-name type-a) (c-type-name type-b)))
-(let ((cache (make-hash-table :test #'equal)))
- (defun make-simple-type (name &optional qualifiers)
- "Make a distinguished object for the simple type called NAME."
- (qualify-type (or (gethash name cache)
- (setf (gethash name cache)
- (make-instance 'simple-c-type :name name)))
- qualifiers)))
+;; C syntax output protocol.
(defmethod pprint-c-type ((type simple-c-type) stream kernel)
(pprint-logical-block (stream nil)
(c-type-name type))
(funcall kernel stream 0 t)))
-(defmethod c-type-equal-p and ((type-a simple-c-type)
- (type-b simple-c-type))
- (string= (c-type-name type-a) (c-type-name type-b)))
+;; S-expression notation protocol.
+
+(defparameter *simple-type-map* (make-hash-table)
+ "Hash table mapping strings of C syntax to symbolic names.")
(defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
(declare (ignore colon atsign))
(format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
(c-type-qualifiers type) (or symbol name))))
-;; S-expression syntax.
-
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmethod expand-c-type-spec ((spec string))
`(make-simple-type ,spec))
(defmethod expand-c-type-form ((head string) tail)
- `(make-simple-type ,head ,@tail)))
+ `(make-simple-type ,head (list ,@tail))))
+(export 'define-simple-c-type)
(defmacro define-simple-c-type (names type)
"Define each of NAMES to be a simple type called TYPE."
(let ((names (if (listp names) names (list names))))
(define-c-type-syntax ,(car names) (&rest quals)
`(make-simple-type ,',type (list ,@quals))))))
+;; Built-in C types.
+
+(export '(void float double long-double va-list size-t ptrdiff-t
+ char unsigned-char uchar signed-char schar
+ int signed signed-int sint unsigned unsigned-int uint
+ short signed-short short-int signed-short-int sshort
+ unsigned-short unsigned-short-int ushort
+ long signed-long long-int signed-long-int slong
+ unsigned-long unsigned-long-int ulong
+ long-long signed-long-long long-long-int signed-long-long-int
+ unsigned-long-long unsigned-long-long-int llong sllong ullong))
+
(define-simple-c-type void "void")
(define-simple-c-type char "char")
(define-simple-c-type ptrdiff-t "ptrdiff_t")
;;;--------------------------------------------------------------------------
-;;; Tag types (structs, unions and enums).
+;;; Tagged types (enums, structs and unions).
-;; Definitions.
+;; Class definition.
+(export '(tagged-c-type c-type-tag))
(defclass tagged-c-type (qualifiable-c-type)
((tag :initarg :tag :type string :reader c-type-tag))
(:documentation
"C types with tags."))
+;; Subclass definitions.
+
+(export 'c-tagged-type-kind)
(defgeneric c-tagged-type-kind (type)
(:documentation
"Return the kind of tagged type that TYPE is, as a keyword."))
+(export 'kind-c-tagged-type)
+(defgeneric kind-c-tagged-type (kind)
+ (:documentation
+ "Given a keyword KIND, return the appropriate class name."))
+
+(export 'make-c-tagged-type)
+(defun make-c-tagged-type (kind tag &optional qualifiers)
+ "Return a tagged type with the given KIND (keyword) and TAG (string)."
+ (intern-c-type (kind-c-tagged-type kind)
+ :tag tag
+ :qualifiers (canonify-qualifiers qualifiers)))
+
(macrolet ((define-tagged-type (kind what)
- (let ((type (symbolicate 'c- kind '-type))
- (constructor (symbolicate 'make- kind '-type)))
+ (let* ((type (symbolicate 'c- kind '-type))
+ (keyword (intern (symbol-name kind) :keyword))
+ (constructor (symbolicate 'make- kind '-type)))
`(progn
+ (export '(,type ,constructor))
(defclass ,type (tagged-c-type) ()
(:documentation ,(format nil "C ~a types." what)))
(defmethod c-tagged-type-kind ((type ,type))
- ',kind)
- (let ((cache (make-hash-table :test #'equal)))
- (defun ,constructor (tag &optional qualifiers)
- (qualify-type (or (gethash tag cache)
- (setf (gethash tag cache)
- (make-instance ',type
- :tag tag)))
- qualifiers)))
+ ',keyword)
+ (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
+ ',type)
+ (defun ,constructor (tag &optional qualifiers)
+ (intern-c-type ',type :tag tag
+ :qualifiers (canonify-qualifiers
+ qualifiers)))
(define-c-type-syntax ,kind (tag &rest quals)
,(format nil "Construct ~A type named TAG" what)
`(,',constructor ,tag (list ,@quals)))))))
(define-tagged-type struct "structure")
(define-tagged-type union "union"))
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
+ (string= (c-type-tag type-a) (c-type-tag type-b)))
+
+;; C syntax output protocol.
+
(defmethod pprint-c-type ((type tagged-c-type) stream kernel)
(pprint-logical-block (stream nil)
(format stream "~{~(~A~) ~@_~}~(~A~) ~A"
(c-type-tag type))
(funcall kernel stream 0 t)))
-(defmethod c-type-equal-p and ((type-a tagged-c-type)
- (type-b tagged-c-type))
- (string= (c-type-tag type-a) (c-type-tag type-b)))
+;; S-expression notation protocol.
(defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
(declare (ignore colon atsign))
;;;--------------------------------------------------------------------------
;;; Pointer types.
-;; Definitions.
+;; Class definition.
+(export 'c-pointer-type)
(defclass c-pointer-type (qualifiable-c-type)
((subtype :initarg :subtype :type c-type :reader c-type-subtype))
- (:documentation
- "C pointer types."))
+ (:documentation "C pointer types."))
-(let ((cache (make-hash-table :test #'eql)))
- (defun make-pointer-type (subtype &optional qualifiers)
- "Return a (maybe distinguished) pointer type."
- (qualify-type (or (gethash subtype cache)
- (make-instance 'c-pointer-type :subtype subtype))
- qualifiers)))
+;; Constructor function.
+
+(export 'make-pointer-type)
+(defun make-pointer-type (subtype &optional qualifiers)
+ "Return a (maybe distinguished) pointer type."
+ (let ((canonical (canonify-qualifiers qualifiers)))
+ (funcall (if (gethash subtype *c-type-intern-map*)
+ #'intern-c-type #'make-instance)
+ 'c-pointer-type
+ :subtype subtype
+ :qualifiers canonical)))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-pointer-type)
+ (type-b c-pointer-type))
+ (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
+
+;; C syntax output protocol.
(defmethod pprint-c-type ((type c-pointer-type) stream kernel)
(pprint-c-type (c-type-subtype type) stream
(c-type-qualifiers type))
(funcall kernel stream 1 (c-type-qualifiers type))))))
-(defmethod c-type-equal-p and ((type-a c-pointer-type)
- (type-b c-pointer-type))
- (c-type-equal-p (c-type-subtype type-a)
- (c-type-subtype type-b)))
+;; S-expression notation protocol.
(defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>"
+ (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
(c-type-subtype type)
(c-type-qualifiers type)))
-;; S-expression syntax.
-
+(export '(* pointer ptr))
(define-c-type-syntax * (sub &rest quals)
"Return the type of pointer-to-SUB."
`(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
(c-type-alias * pointer ptr)
+;; Built-in C types.
+
+(export '(string const-string))
(defctype string (* char))
(defctype const-string (* (char :const)))
;;;--------------------------------------------------------------------------
;;; Array types.
-;; Definitions.
+;; Class definition.
+(export '(c-array-type c-array-dimensions))
(defclass c-array-type (c-type)
((subtype :initarg :subtype :type c-type :reader c-type-subtype)
(dimensions :initarg :dimensions :type list :reader c-array-dimensions))
(:documentation
"C array types."))
+;; Constructor function.
+
+(export 'make-array-type)
(defun make-array-type (subtype dimensions)
"Return a new array of SUBTYPE with given DIMENSIONS."
(make-instance 'c-array-type :subtype subtype
:dimensions (or dimensions '(nil))))
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))
+
+ ;; Messy. C doesn't have multidimensional arrays, but we fake them for
+ ;; convenience's sake. But it means that we have to arrange for
+ ;; multidimensional arrays to equal vectors of vectors -- and in general
+ ;; for multidimensional arrays of multidimensional arrays to match each
+ ;; other properly, even when their dimensions don't align precisely.
+ (labels ((check (sub-a dim-a sub-b dim-b)
+ (cond ((endp dim-a)
+ (cond ((endp dim-b)
+ (c-type-equal-p sub-a sub-b))
+ ((typep sub-a 'c-array-type)
+ (check (c-type-subtype sub-a)
+ (c-array-dimensions sub-a)
+ sub-b dim-b))
+ (t
+ nil)))
+ ((endp dim-b)
+ (check sub-b dim-b sub-a dim-a))
+ ((equal (car dim-a) (car dim-b))
+ (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
+ (t
+ nil))))
+ (check (c-type-subtype type-a) (c-array-dimensions type-a)
+ (c-type-subtype type-b) (c-array-dimensions type-b))))
+
+;; C syntax output protocol.
+
(defmethod pprint-c-type ((type c-array-type) stream kernel)
(pprint-c-type (c-type-subtype type) stream
(lambda (stream prio spacep)
(format stream "~@<~{[~@[~A~]]~^~_~}~:>"
(c-array-dimensions type))))))
-(defmethod c-type-equal-p and ((type-a c-array-type)
- (type-b c-array-type))
- (and (c-type-equal-p (c-type-subtype type-a)
- (c-type-subtype type-b))
- (equal (c-array-dimensions type-a)
- (c-array-dimensions type-b))))
+;; S-expression notation protocol.
(defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
(declare (ignore colon atsign))
- (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>"
+ (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
(c-type-subtype type)
(c-array-dimensions type)))
-;; S-expression syntax.
-
+(export '([] array vec))
(define-c-type-syntax [] (sub &rest dims)
"Return the type of arrays of SUB with the dimensions DIMS.
;;;--------------------------------------------------------------------------
;;; Function types.
-;; Arguments.
-
-(defstruct (argument (:constructor make-argument (name type)) (:type list))
- "Simple list structure representing a function argument."
- name
- type)
+;; Function arguments.
(defun arguments-lists-equal-p (list-a list-b)
"Return whether LIST-A and LIST-B match.
(argument-type arg-b))))
list-a list-b)))
-(defgeneric commentify-argument-name (name)
- (:documentation
- "Produce a `commentified' version of the argument.
-
- The default behaviour is that temporary argument names are simply omitted
- (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
- printable representation of the argument.")
- (:method ((name null)) nil)
- (:method ((name t)) (format nil "/*~A*/" name)))
-
-(defun commentify-argument-names (arguments)
- "Return an argument list with the arguments commentified.
-
- That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
- (mapcar (lambda (arg)
- (if (eq arg :ellipsis)
- arg
- (make-argument (commentify-argument-name (argument-name arg))
- (argument-type arg))))
- arguments))
-
-(defun commentify-function-type (type)
- "Return a type like TYPE, but with arguments commentified.
-
- This doesn't recurse into the return type or argument types."
- (make-function-type (c-type-subtype type)
- (commentify-argument-names
- (c-function-arguments type))))
-
-;; Definitions.
+;; Class definition.
+(export '(c-function-type c-function-arguments))
(defclass c-function-type (c-type)
((subtype :initarg :subtype :type c-type :reader c-type-subtype)
(arguments :initarg :arguments :type list :reader c-function-arguments))
"C function types. The subtype is the return type, as implied by the C
syntax for function declarations."))
+;; Constructor function.
+
+(export 'make-function-type)
(defun make-function-type (subtype arguments)
"Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
(make-instance 'c-function-type :subtype subtype :arguments arguments))
-(defmethod c-type-equal-p and ((type-a c-function-type)
- (type-b c-function-type))
- (and (c-type-equal-p (c-type-subtype type-a)
- (c-type-subtype type-b))
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and
+ ((type-a c-function-type) (type-b c-function-type))
+ (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))
(arguments-lists-equal-p (c-function-arguments type-a)
(c-function-arguments type-b))))
-(defmethod print-c-type
- (stream (type c-function-type) &optional colon atsign)
- (declare (ignore colon atsign))
- (format stream
- #.(concatenate 'string
- "~:@<"
- "FUN ~@_~:I~/sod::print-c-type/"
- "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
- "~:>")
- (c-type-subtype type)
- (c-function-arguments type)))
+;; C syntax output protocol.
(defmethod pprint-c-type ((type c-function-type) stream kernel)
(pprint-c-type (c-type-subtype type) stream
(when spacep (c-type-space stream))
(funcall kernel stream 2 nil)
(pprint-indent :block 4 stream)
- ;;(pprint-newline :miser stream)
(pprint-logical-block
(stream nil :prefix "(" :suffix ")")
(let ((firstp t))
stream
(argument-name arg))))))))))
-;; S-expression syntax.
+;; S-expression notation protocol.
+
+(defmethod print-c-type
+ (stream (type c-function-type) &optional colon atsign)
+ (declare (ignore colon atsign))
+ (format stream "~:@<~
+ FUN ~@_~:I~/sod:print-c-type/~
+ ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~
+ ~:>"
+ (c-type-subtype type)
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ arg
+ (list (argument-name arg) (argument-type arg))))
+ (c-function-arguments type))))
+(export '(fun function func fn))
(define-c-type-syntax fun (ret &rest args)
"Return the type of functions which returns RET and has arguments ARGS.
((or (atom args) (atom (car args)))
(cond ((and (null args) (null list)) `nil)
((null args) `(list ,@(nreverse list)))
+ ((and (consp args)
+ (eq (car args) :ellipsis))
+ `(list ,@(nreverse list) :ellipsis))
((null list) `,args)
(t `(list* ,@(nreverse list) ,args)))))))
(c-type-alias fun function () func fn)
+;; Additional utilities for dealing with functions.
+
+(export 'commentify-argument-names)
+(defun commentify-argument-names (arguments)
+ "Return an argument list with the arguments commentified.
+
+ That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME."
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ arg
+ (make-argument (commentify-argument-name (argument-name arg))
+ (argument-type arg))))
+ arguments))
+
+(export 'commentify-function-type)
+(defun commentify-function-type (type)
+ "Return a type like TYPE, but with arguments commentified.
+
+ This doesn't recurse into the return type or argument types."
+ (make-function-type (c-type-subtype type)
+ (commentify-argument-names
+ (c-function-arguments type))))
+
;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; Computing class precedence lists
+;;; Class finalization implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; 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
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
-;;; Linearizations.
+;;; Class precedence lists.
-;; Just for fun, we implement a wide selection. C3 seems to be clearly the
-;; best, with fewer sharp edges for the unwary.
+;; Just for fun, we implement a wide selection of precedence list algorithms.
+;; C3 seems to be clearly the best, with fewer sharp edges for the unwary.
;;
;; The extended precedence graph (EPG) is constructed by adding edges to the
;; superclass graph. If A and B are classes, then write A < B if A is a
;; Superclass Linearization for Dylan' for more detail.
;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html
+;;; Tiebreaker functions.
+
(defun clos-tiebreaker (candidates so-far)
"The CLOS linearization tiebreaker function.
(error "SOD INTERNAL ERROR: Failed to break tie in CLOS."))
winner))
+(defun c3-tiebreaker (candidates cpls)
+ "The C3 linearization tiebreaker function.
+
+ Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
+ appears in the earliest element of CPLS, which should be the list of the
+ class precedence lists of the direct superclasses of the class in
+ question, in the order specified in the class declaration.
+
+ The only class in the class precedence list which does not appear in one
+ of these lists is the new class itself, which must precede all of the
+ others.
+
+ This must disambiguate, since if two classes are in the same class
+ precedence list, then one must appear in it before the other, which
+ provides an ordering between them. (In this situation we return the one
+ that matches earliest anyway, which would still give the right answer.)
+
+ Note that this will merge the CPLs of superclasses /as they are/, not
+ necessarily as C3 would have computed them. This ensures monotonicity
+ assuming that the superclass CPLs are already monotonic. If they aren't,
+ you're going to lose anyway."
+
+ (dolist (cpl cpls)
+ (dolist (candidate candidates)
+ (when (member candidate cpl)
+ (return-from c3-tiebreaker candidate))))
+ (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
+
+;;; Linearization functions.
+
(defun clos-cpl (class)
"Compute the class precedence list of CLASS using CLOS linearization rules.
(mapcar #'sod-class-precedence-list direct-supers))
:pick #'clos-tiebreaker)))
-(defun c3-tiebreaker (candidates cpls)
- "The C3 linearization tiebreaker function.
-
- Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which
- appears in the earliest element of CPLS, which should be the list of the
- class precedence lists of the direct superclasses of the class in
- question, in the order specified in the class declaration.
-
- The only class in the class precedence list which does not appear in one
- of these lists is the new class itself, which must precede all of the
- others.
-
- This must disambiguate, since if two classes are in the same class
- precedence list, then one must appear in it before the other, which
- provides an ordering between them. (In this situation we return the one
- that matches earliest anyway, which would still give the right answer.)
-
- Note that this will merge the CPLs of superclasses /as they are/, not
- necessarily as C3 would have computed them. This ensures monotonicity
- assuming that the superclass CPLs are already monotonic. If they aren't,
- you're going to lose anyway."
-
- (dolist (cpl cpls)
- (dolist (candidate candidates)
- (when (member candidate cpl)
- (return-from c3-tiebreaker candidate))))
- (error "SOD INTERNAL ERROR: Failed to break tie in C3."))
-
(defun c3-cpl (class)
"Compute the class precedence list of CLASS using C3 linearization rules.
(when (member class candidates)
(return class))))))))
-;;;--------------------------------------------------------------------------
-;;; Class protocol.
-
-(defgeneric compute-cpl (class)
- (:documentation
- "Returns the class precedence list for CLASS."))
+;;; Default function.
(defmethod compute-cpl ((class sod-class))
(handler-case (c3-cpl class)
(sod-class-name class)))))
;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(progn
- (defclass test-class ()
- ((name :initarg :name :accessor sod-class-name)
- (direct-superclasses :initarg :superclasses
- :accessor sod-class-direct-superclasses)
- (class-precedence-list)))
-
- (defmethod print-object ((class test-class) stream)
- (if *print-escape*
- (print-unreadable-object (class stream :type t :identity nil)
- (princ (sod-class-name class) stream))
- (princ (sod-class-name class) stream)))
-
- (defvar *test-linearization*)
-
- (defmethod sod-class-precedence-list ((class test-class))
- (if (slot-boundp class 'class-precedence-list)
- (slot-value class 'class-precedence-list)
- (setf (slot-value class 'class-precedence-list)
- (funcall *test-linearization* class)))))
-
-#+test
-(defun test-cpl (linearization heterarchy)
- (let* ((*test-linearization* linearization)
- (classes (make-hash-table :test #'equal)))
- (dolist (class heterarchy)
- (let ((name (car class)))
- (setf (gethash (car class) classes)
- (make-instance 'test-class :name name))))
- (dolist (class heterarchy)
- (setf (sod-class-direct-superclasses (gethash (car class) classes))
- (mapcar (lambda (super) (gethash super classes)) (cdr class))))
- (mapcar (lambda (class)
- (handler-case
- (mapcar #'sod-class-name
- (sod-class-precedence-list (gethash (car class)
- classes)))
- (inconsistent-merge-error ()
- (list (car class) :error))))
- heterarchy)))
-
-#+test
-(progn
- (defparameter *confused-heterarchy*
- '((object) (grid-layout object)
- (horizontal-grid grid-layout) (vertical-grid grid-layout)
- (hv-grid horizontal-grid vertical-grid)
- (vh-grid vertical-grid horizontal-grid)
- (confused-grid hv-grid vh-grid)))
- (defparameter *boat-heterarchy*
- '((object)
- (boat object)
- (day-boat boat)
- (wheel-boat boat)
- (engine-less day-boat)
- (small-multihull day-boat)
- (pedal-wheel-boat engine-less wheel-boat)
- (small-catamaran small-multihull)
- (pedalo pedal-wheel-boat small-catamaran)))
- (defparameter *menu-heterarchy*
- '((object)
- (choice-widget object)
- (menu choice-widget)
- (popup-mixin object)
- (popup-menu menu popup-mixin)
- (new-popup-menu menu popup-mixin choice-widget)))
- (defparameter *pane-heterarchy*
- '((pane) (scrolling-mixin) (editing-mixin)
- (scrollable-pane pane scrolling-mixin)
- (editable-pane pane editing-mixin)
- (editable-scrollable-pane scrollable-pane editable-pane)))
- (defparameter *baker-nonmonotonic-heterarchy*
- '((z) (x z) (y) (b y) (a b x) (c a b x y)))
- (defparameter *baker-nonassociative-heterarchy*
- '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
- (defparameter *distinguishing-heterarchy*
- '((object)
- (a object) (b object) (c object)
- (p a b) (q a c)
- (u p) (v q)
- (x u v)
- (y x b c)
- (z x c b)))
- (defparameter *python-heterarchy*
- '((object)
- (a object) (b object) (c object) (d object) (e object)
- (k1 a b c)
- (k2 d b e)
- (k3 d a)
- (z k1 k2 k3))))
+;;; Chains.
+
+(defmethod compute-chains ((class sod-class))
+ (with-default-error-location (class)
+ (with-slots (chain-link class-precedence-list) class
+ (let* ((head (if chain-link
+ (sod-class-chain-head chain-link)
+ class))
+ (chain (cons class (and chain-link
+ (sod-class-chain chain-link))))
+ (table (make-hash-table)))
+
+ ;; Check the chains. We work through each superclass, maintaining a
+ ;; hash table keyed by class. If we encounter a class C which links
+ ;; to L, then we store C as L's value; if L already has a value then
+ ;; we've found an error. By the end of all of this, the classes
+ ;; which don't have an entry are the chain tails.
+ (dolist (super class-precedence-list)
+ (let ((link (sod-class-chain-link super)))
+ (when link
+ (when (gethash link table)
+ (error "Conflicting chains in class ~A: ~
+ (~A and ~A both link to ~A)"
+ class super (gethash link table) link))
+ (setf (gethash link table) super))))
+
+ ;; Done.
+ (values head chain
+ (cons chain
+ (mapcar #'sod-class-chain
+ (remove-if (lambda (super)
+ (gethash super table))
+ (cdr class-precedence-list)))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Sanity checking.
+
+(defmethod check-sod-class ((class sod-class))
+ (with-default-error-location (class)
+
+ ;; Check the names of things are valid.
+ (with-slots (name nickname messages) class
+ (unless (valid-name-p name)
+ (error "Invalid class name `~A'" class))
+ (unless (valid-name-p nickname)
+ (error "Invalid class nickname `~A' on class `~A'" nickname class))
+ (dolist (message messages)
+ (unless (valid-name-p (sod-message-name message))
+ (error "Invalid message name `~A' on class `~A'"
+ (sod-message-name message) class))))
+
+ ;; Check that the slots and messages have distinct names.
+ (with-slots (slots messages class-precedence-list) class
+ (flet ((check-list (list what namefunc)
+ (let ((table (make-hash-table :test #'equal)))
+ (dolist (item list)
+ (let ((name (funcall namefunc item)))
+ (if (gethash name table)
+ (error "Duplicate ~A name `~A' on class `~A'"
+ what name class)
+ (setf (gethash name table) item)))))))
+ (check-list slots "slot" #'sod-slot-name)
+ (check-list messages "message" #'sod-message-name)
+ (check-list class-precedence-list "nickname" #'sod-class-name)))
+
+ ;; Check that the CHAIN-TO class is actually a proper superclass. (This
+ ;; eliminates hairy things like a class being its own link.)
+ (with-slots (class-precedence-list chain-link) class
+ (unless (or (not chain-link)
+ (member chain-link (cdr class-precedence-list)))
+ (error "In `~A~, chain-to class `~A' is not a proper superclass"
+ class chain-link)))
+
+ ;; Check for circularity in the superclass graph. Since the superclasses
+ ;; should already be acyclic, it suffices to check that our class is not
+ ;; a superclass of any of its own direct superclasses.
+ (let ((circle (find-if (lambda (super)
+ (sod-subclass-p super class))
+ (sod-class-direct-superclasses class))))
+ (when circle
+ (error "Circularity: ~A is already a superclass of ~A"
+ class circle)))
+
+ ;; Check that the class has a unique root superclass.
+ (find-root-superclass class)
+
+ ;; Check that the metaclass is a subclass of each direct superclass's
+ ;; metaclass.
+ (with-slots (metaclass direct-superclasses) class
+ (dolist (super direct-superclasses)
+ (unless (sod-subclass-p metaclass (sod-class-metaclass super))
+ (error "Incompatible metaclass for `~A': ~
+ `~A' isn't a subclass of `~A' (of `~A')"
+ class metaclass (sod-class-metaclass super) super))))))
+
+;;;--------------------------------------------------------------------------
+;;; Finalization.
+
+(defmethod finalize-sod-class ((class sod-class))
+
+ ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief)
+ ;; clone of the CPL and chain establishment code. If the interface changes
+ ;; then BOOTSTRAP-CLASSES will need to be changed too.
+
+ (with-default-error-location (class)
+ (ecase (sod-class-state class)
+ ((nil)
+
+ ;; If this fails, mark the class as a loss.
+ (setf (sod-class-state class) :broken)
+
+ ;; Finalize all of the superclasses. There's some special pleading
+ ;; here to make bootstrapping work: we don't try to finalize the
+ ;; metaclass if we're a root class (no direct superclasses -- because
+ ;; in that case the metaclass will have to be a subclass of us!), or
+ ;; if it's equal to us. This is enough to tie the knot at the top of
+ ;; the class graph.
+ (with-slots (name direct-superclasses metaclass) class
+ (dolist (super direct-superclasses)
+ (finalize-sod-class super))
+ (unless (or (null direct-superclasses)
+ (eq class metaclass))
+ (finalize-sod-class metaclass)))
+
+ ;; Stash the class's type.
+ (setf (sod-class-type class)
+ (make-class-type (sod-class-name class)))
+
+ ;; Clobber the lists of items if they've not been set.
+ (dolist (slot '(slots instance-initializers class-initializers
+ messages methods))
+ (unless (slot-boundp class slot)
+ (setf (slot-value class slot) nil)))
+
+ ;; If the CPL hasn't been done yet, compute it.
+ (with-slots (class-precedence-list) class
+ (unless (slot-boundp class 'class-precedence-list)
+ (setf class-precedence-list (compute-cpl class))))
+
+ ;; Check that the class is fairly sane.
+ (check-sod-class class)
+
+ ;; Determine the class's layout.
+ (with-slots (chain-head chain chains) class
+ (setf (values chain-head chain chains) (compute-chains class)))
+
+ ;; FIXME: make these slots autovivifying.
+ (with-slots (ilayout effective-methods vtables) class
+ (setf ilayout (compute-ilayout class))
+ (setf effective-methods (compute-effective-methods class))
+ (setf vtables (compute-vtables class)))
+
+ ;; Done.
+ (setf (sod-class-state class) :finalized)
+ t)
+
+ (:broken
+ nil)
+
+ (:finalized
+ t))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class layout protocol implementation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slots.
+
+(defmethod print-object ((slot effective-slot) stream)
+ (maybe-print-unreadable-object (slot stream :type t)
+ (format stream "~A~@[ = ~@_~A~]"
+ (effective-slot-direct-slot slot)
+ (effective-slot-initializer slot))))
+
+(defmethod find-slot-initializer ((class sod-class) (slot sod-slot))
+ (some (lambda (super)
+ (find slot
+ (sod-class-instance-initializers super)
+ :key #'sod-initializer-slot))
+ (sod-class-precedence-list class)))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-slot))
+ (make-instance 'effective-slot
+ :slot slot
+ :class class
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Special-purpose slot objects.
+
+(export 'sod-class-slot)
+(defclass sod-class-slot (sod-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader sod-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ These slots need class-specific initialization. It's easier to keep all
+ of the information (name, type, and how to initialize them) about these
+ slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+ ((slot sod-class-slot) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (slot 'initializer-function)
+ (get-property pset :initializer-function t nil))
+ (default-slot (slot 'prepare-function)
+ (get-property pset :prepare-function t nil)))
+
+(export 'sod-class-effective-slot)
+(defclass sod-class-effective-slot (effective-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader effective-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader effective-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ This class ignores any explicit initializers and computes initializer
+ values using the slot's INIT-FUNC slot and a magical protocol during
+ metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+ (make-instance 'sod-class-effective-slot
+ :class class :slot slot
+ :initializer-function (sod-slot-initializer-function slot)
+ :prepare-function (sod-slot-prepare-function slot)
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods.
+
+(defmethod print-object ((method effective-method) stream)
+ (maybe-print-unreadable-object (method stream :type t)
+ (format stream "~A ~A"
+ (effective-method-message method)
+ (effective-method-class method))))
+
+(defmethod print-object ((entry method-entry) stream)
+ (maybe-print-unreadable-object (entry stream :type t)
+ (format stream "~A:~A"
+ (method-entry-effective-method entry)
+ (sod-class-nickname (method-entry-chain-head entry)))))
+
+(defmethod compute-sod-effective-method
+ ((message sod-message) (class sod-class))
+ (let ((direct-methods (mappend (lambda (super)
+ (remove message
+ (sod-class-methods super)
+ :key #'sod-method-message
+ :test-not #'eql))
+ (sod-class-precedence-list class))))
+ (make-instance (message-effective-method-class message)
+ :message message
+ :class class
+ :direct-methods direct-methods)))
+
+(defmethod compute-effective-methods ((class sod-class))
+ (mapcan (lambda (super)
+ (mapcar (lambda (message)
+ (compute-sod-effective-method message class))
+ (sod-class-messages super)))
+ (sod-class-precedence-list class)))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'effective-methods)))
+ (setf (slot-value class 'effective-methods)
+ (compute-effective-methods class)))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout.
+
+;;; islots
+
+(defmethod print-object ((islots islots) stream)
+ (print-unreadable-object (islots stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (islots-subclass islots)
+ (islots-class islots)
+ (islots-slots islots))))
+
+(defmethod compute-islots ((class sod-class) (subclass sod-class))
+ (make-instance 'islots
+ :class class
+ :subclass subclass
+ :slots (mapcar (lambda (slot)
+ (compute-effective-slot subclass slot))
+ (sod-class-slots class))))
+
+;;; vtable-pointer
+;;; Do we need a construction protocol here?
+
+(defmethod print-object ((vtp vtable-pointer) stream)
+ (print-unreadable-object (vtp stream :type t)
+ (format stream "~A:~A"
+ (vtable-pointer-class vtp)
+ (sod-class-nickname (vtable-pointer-chain-head vtp)))))
+
+;;; ichain
+
+(defmethod print-object ((ichain ichain) stream)
+ (print-unreadable-object (ichain stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ichain-class ichain)
+ (sod-class-nickname (ichain-head ichain))
+ (ichain-body ichain))))
+
+(defmethod compute-ichain ((class sod-class) chain)
+ (let* ((chain-head (car chain))
+ (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+ :key #'sod-class-chain-head))
+ (vtable-pointer (make-instance 'vtable-pointer
+ :class class
+ :chain-head chain-head
+ :chain-tail chain-tail))
+ (islots (remove-if-not #'islots-slots
+ (mapcar (lambda (super)
+ (compute-islots super class))
+ chain))))
+ (make-instance 'ichain
+ :class class
+ :chain-head chain-head
+ :chain-tail chain-tail
+ :body (cons vtable-pointer islots))))
+
+;;; ilayout
+
+(defmethod print-object ((ilayout ilayout) stream)
+ (print-unreadable-object (ilayout stream :type t)
+ (format stream "~A ~_~:<~@{~S~^ ~_~}~:>"
+ (ilayout-class ilayout)
+ (ilayout-ichains ilayout))))
+
+(defmethod compute-ilayout ((class sod-class))
+ (make-instance 'ilayout
+ :class class
+ :ichains (mapcar (lambda (chain)
+ (compute-ichain class
+ (reverse chain)))
+ (sod-class-chains class))))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'ilayout)))
+ (setf (slot-value class 'ilayout)
+ (compute-ilayout class)))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+(defmethod print-object ((vtmsgs vtmsgs) stream)
+ (print-unreadable-object (vtmsgs stream :type t)
+ (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtmsgs-subclass vtmsgs)
+ (vtmsgs-class vtmsgs)
+ (vtmsgs-entries vtmsgs))))
+
+(defmethod compute-vtmsgs
+ ((class sod-class)
+ (subclass sod-class)
+ (chain-head sod-class)
+ (chain-tail sod-class))
+ (flet ((make-entry (message)
+ (let ((method (find message
+ (sod-class-effective-methods subclass)
+ :key #'effective-method-message)))
+ (make-method-entry method chain-head chain-tail))))
+ (make-instance 'vtmsgs
+ :class class
+ :subclass subclass
+ :chain-head chain-head
+ :chain-tail chain-tail
+ :entries (mapcar #'make-entry
+ (sod-class-messages class)))))
+
+;;; class-pointer
+
+(defmethod print-object ((cptr class-pointer) stream)
+ (print-unreadable-object (cptr stream :type t)
+ (format stream "~A:~A"
+ (class-pointer-metaclass cptr)
+ (sod-class-nickname (class-pointer-meta-chain-head cptr)))))
+
+(defmethod make-class-pointer
+ ((class sod-class) (chain-head sod-class)
+ (metaclass sod-class) (meta-chain-head sod-class))
+
+ ;; Slightly tricky. We don't necessarily want a pointer to the metaclass,
+ ;; but to its most specific subclass on the given chain. Fortunately, CL
+ ;; is good at this game.
+ (let* ((meta-chains (sod-class-chains metaclass))
+ (meta-chain-tails (mapcar #'car meta-chains))
+ (meta-chain-tail (find meta-chain-head meta-chain-tails
+ :key #'sod-class-chain-head)))
+ (make-instance 'class-pointer
+ :class class
+ :chain-head chain-head
+ :metaclass meta-chain-tail
+ :meta-chain-head meta-chain-head)))
+
+;;; base-offset
+
+(defmethod print-object ((boff base-offset) stream)
+ (print-unreadable-object (boff stream :type t)
+ (format stream "~A:~A"
+ (base-offset-class boff)
+ (sod-class-nickname (base-offset-chain-head boff)))))
+
+(defmethod make-base-offset ((class sod-class) (chain-head sod-class))
+ (make-instance 'base-offset
+ :class class
+ :chain-head chain-head))
+
+;;; chain-offset
+
+(defmethod print-object ((choff chain-offset) stream)
+ (print-unreadable-object (choff stream :type t)
+ (format stream "~A:~A->~A"
+ (chain-offset-class choff)
+ (sod-class-nickname (chain-offset-chain-head choff))
+ (sod-class-nickname (chain-offset-target-head choff)))))
+
+(defmethod make-chain-offset
+ ((class sod-class) (chain-head sod-class) (target-head sod-class))
+ (make-instance 'chain-offset
+ :class class
+ :chain-head chain-head
+ :target-head target-head))
+
+;;; vtable
+
+(defmethod print-object ((vtable vtable) stream)
+ (print-unreadable-object (vtable stream :type t)
+ (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>"
+ (vtable-class vtable)
+ (sod-class-nickname (vtable-chain-head vtable))
+ (vtable-body vtable))))
+
+;; Special variables used by `compute-vtable'.
+(defvar *done-metaclass-chains*)
+(defvar *done-instance-chains*)
+
+(defmethod compute-vtable-items
+ ((class sod-class) (super sod-class) (chain-head sod-class)
+ (chain-tail sod-class) (emit function))
+
+ ;; If this class introduces new metaclass chains, then emit pointers to
+ ;; them.
+ (let* ((metasuper (sod-class-metaclass super))
+ (metasuper-chains (sod-class-chains metasuper))
+ (metasuper-chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ metasuper-chains)))
+ (dolist (metasuper-chain-head metasuper-chain-heads)
+ (unless (member metasuper-chain-head *done-metaclass-chains*)
+ (funcall emit (make-class-pointer class
+ chain-head
+ metasuper
+ metasuper-chain-head))
+ (push metasuper-chain-head *done-metaclass-chains*))))
+
+ ;; If there are new instance chains, then emit offsets to them.
+ (let* ((chains (sod-class-chains super))
+ (chain-heads (mapcar (lambda (chain)
+ (sod-class-chain-head (car chain)))
+ chains)))
+ (dolist (head chain-heads)
+ (unless (member head *done-instance-chains*)
+ (funcall emit (make-chain-offset class chain-head head))
+ (push head *done-instance-chains*))))
+
+ ;; Finally, if there are interesting methods, emit those too.
+ (when (sod-class-messages super)
+ (funcall emit (compute-vtmsgs super class chain-head chain-tail))))
+
+(defmethod compute-vtable ((class sod-class) (chain list))
+ (let* ((chain-head (car chain))
+ (chain-tail (find chain-head (mapcar #'car (sod-class-chains class))
+ :key #'sod-class-chain-head))
+ (*done-metaclass-chains* nil)
+ (*done-instance-chains* (list chain-head))
+ (done-superclasses nil)
+ (items nil))
+ (flet ((emit (item)
+ (push item items)))
+
+ ;; Find the root chain in the metaclass and write a pointer.
+ (let* ((metaclass (sod-class-metaclass class))
+ (metaclass-root (find-root-metaclass class))
+ (metaclass-root-head (sod-class-chain-head metaclass-root)))
+ (emit (make-class-pointer class chain-head metaclass
+ metaclass-root-head))
+ (push metaclass-root-head *done-metaclass-chains*))
+
+ ;; Write an offset to the instance base.
+ (emit (make-base-offset class chain-head))
+
+ ;; Now walk the chain. As we ascend the chain, scan the class
+ ;; precedence list of each class in reverse to ensure that we have
+ ;; everything interesting.
+ (dolist (super chain)
+ (dolist (sub (reverse (sod-class-precedence-list super)))
+ (unless (member sub done-superclasses)
+ (compute-vtable-items class
+ sub
+ chain-head
+ chain-tail
+ #'emit)
+ (push sub done-superclasses))))
+
+ ;; We're through.
+ (make-instance 'vtable
+ :class class
+ :chain-head chain-head
+ :chain-tail chain-tail
+ :body (nreverse items)))))
+
+(defmethod compute-vtables ((class sod-class))
+ (mapcar (lambda (chain)
+ (compute-vtable class (reverse chain)))
+ (sod-class-chains class)))
+
+(defmethod slot-unbound
+ (clos-class (class sod-class) (slot-name (eql 'vtables)))
+ (setf (slot-value class 'vtables)
+ (compute-vtables class)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class construction protocol implementation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(defmethod guess-metaclass ((class sod-class))
+ "Default metaclass-guessing function for classes.
+
+ Return the most specific metaclass of any of the CLASS's direct
+ superclasses."
+ (do ((supers (sod-class-direct-superclasses class) (cdr supers))
+ (meta nil (let ((candidate (sod-class-metaclass (car supers))))
+ (cond ((null meta) candidate)
+ ((sod-subclass-p meta candidate) meta)
+ ((sod-subclass-p candidate meta) candidate)
+ (t (error "Unable to choose metaclass for `~A'"
+ class))))))
+ ((endp supers) meta)))
+
+(defmethod shared-initialize :after ((class sod-class) slot-names &key pset)
+ "Specific behaviour for SOD class initialization.
+
+ Properties inspected are as follows:
+
+ * `:metaclass' names the metaclass to use. If unspecified, nil is
+ stored, and (unless you intervene later) `guess-metaclass' will be
+ called by `finalize-sod-class' to find a suitable default.
+
+ * `:nick' provides a nickname for the class. If unspecified, a default
+ (the class's name, forced to lowercase) will be chosen in
+ `finalize-sod-class'.
+
+ * `:link' names the chained superclass. If unspecified, this class will
+ be left at the head of its chain."
+
+ ;; If no nickname, copy the class name. It won't be pretty, though.
+ (default-slot-from-property (class 'nickname slot-names)
+ (pset :nick :id)
+ (string-downcase (slot-value class 'name)))
+
+ ;; If no metaclass, guess one in a (Lisp) class-specific way.
+ (default-slot-from-property (class 'metaclass slot-names)
+ (pset :metaclass :id meta (find-sod-class meta))
+ (guess-metaclass class))
+
+ ;; If no chain-link, then start a new chain here.
+ (default-slot-from-property (class 'chain-link slot-names)
+ (pset :link :id link (find-sod-class link))
+ nil))
+
+;;;--------------------------------------------------------------------------
+;;; Slots.
+
+(defmethod make-sod-slot
+ ((class sod-class) name type pset &optional location)
+ (with-default-error-location (location)
+ (let ((slot (make-instance (get-property pset :lisp-class :symbol
+ 'sod-slot)
+ :class class
+ :name name
+ :type type
+ :location (file-location location)
+ :pset pset)))
+ (with-slots (slots) class
+ (setf slots (append slots (list slot))))
+ (check-unused-properties pset))))
+
+(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
+ "This method does nothing.
+
+ It only exists so that it isn't an error to provide a `:pset' initarg
+ to (make-instance 'sod-slot ...)."
+
+ (declare (ignore slot-names pset)))
+
+;;;--------------------------------------------------------------------------
+;;; Slot initializers.
+
+(defmethod make-sod-instance-initializer
+ ((class sod-class) nick name value-kind value-form pset
+ &optional location)
+ (with-default-error-location (location)
+ (let* ((slot (find-instance-slot-by-name class nick name))
+ (initializer (make-sod-initializer-using-slot
+ class slot 'sod-instance-initializer
+ value-kind value-form pset
+ (file-location location))))
+ (with-slots (instance-initializers) class
+ (setf instance-initializers
+ (append instance-initializers (list initializer))))
+ (check-unused-properties pset))))
+
+(defmethod make-sod-class-initializer
+ ((class sod-class) nick name value-kind value-form pset
+ &optional location)
+ (with-default-error-location (location)
+ (let* ((slot (find-class-slot-by-name class nick name))
+ (initializer (make-sod-initializer-using-slot
+ class slot 'sod-class-initializer
+ 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))))
+
+(defmethod make-sod-initializer-using-slot
+ ((class sod-class) (slot sod-slot)
+ init-class value-kind value-form pset location)
+ (make-instance (get-property pset :lisp-class :symbol init-class)
+ :class class
+ :slot slot
+ :value-kind value-kind
+ :value-form value-form
+ :location location
+ :pset pset))
+
+(defmethod shared-initialize :after
+ ((init sod-initializer) slot-names &key pset)
+ "This method does nothing.
+
+ It only exists so that it isn't an error to provide a `:pset' initarg
+ to (make-instance 'sod-initializer ...)."
+ (declare (ignore slot-names pset))
+ nil)
+
+;;;--------------------------------------------------------------------------
+;;; Messages.
+
+(defmethod make-sod-message
+ ((class sod-class) name type pset &optional location)
+ (with-default-error-location (location)
+ (let ((message (make-instance (get-property pset :lisp-class :symbol
+ 'standard-message)
+ :class class
+ :name name
+ :type type
+ :location (file-location location)
+ :pset pset)))
+ (with-slots (messages) class
+ (setf messages (append messages (list message))))
+ (check-unused-properties pset))))
+
+(defmethod shared-initialize :after
+ ((message sod-message) slot-names &key pset)
+ (declare (ignore slot-names pset))
+ (with-slots (type) message
+ (check-message-type message type)))
+
+(defmethod check-message-type ((message sod-message) (type c-function-type))
+ nil)
+
+(defmethod check-message-type ((message sod-message) (type c-type))
+ (error "Messages must have function type, not ~A" type))
+
+;;;--------------------------------------------------------------------------
+;;; Methods.
+
+(defmethod make-sod-method
+ ((class sod-class) nick name type body pset &optional location)
+ (with-default-error-location (location)
+ (let* ((message (find-message-by-name class nick name))
+ (method (make-sod-method-using-message message class
+ type body pset
+ (file-location location))))
+ (with-slots (methods) class
+ (setf methods (append methods (list method)))))
+ (check-unused-properties pset)))
+
+(defmethod make-sod-method-using-message
+ ((message sod-message) (class sod-class) type body pset location)
+ (make-instance (or (get-property pset :lisp-class :symbol)
+ (sod-message-method-class message class pset))
+ :message message
+ :class class
+ :type type
+ :body body
+ :location location
+ :pset pset))
+
+(defmethod sod-message-method-class
+ ((message sod-message) (class sod-class) pset)
+ (declare (ignore pset))
+ 'sod-method)
+
+(defmethod shared-initialize :after
+ ((method sod-method) slot-names &key pset)
+ (declare (ignore slot-names pset))
+
+ ;; Check that the arguments are named if we have a method body.
+ (with-slots (body type) method
+ (unless (or (not body)
+ (every #'argument-name (c-function-arguments type)))
+ (error "Abstract declarators not permitted in method definitions")))
+
+ ;; Check the method type.
+ (with-slots (message type) method
+ (check-method-type method message type)))
+
+(defmethod check-method-type
+ ((method sod-method) (message sod-message) (type c-type))
+ (error "Methods must have function type, not ~A" type))
+
+(defmethod check-method-type
+ ((method sod-method) (message sod-message) (type c-function-type))
+ (with-slots ((msgtype type)) message
+ (unless (c-type-equal-p (c-type-subtype msgtype)
+ (c-type-subtype type))
+ (error "Method return type ~A doesn't match message ~A"
+ (c-type-subtype msgtype) (c-type-subtype type)))
+ (unless (argument-lists-compatible-p (c-function-arguments msgtype)
+ (c-function-arguments type))
+ (error "Method arguments ~A don't match message ~A" type msgtype))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Code generation protocol implementation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Temporary names.
+
+(export '(temporary-argument temporary-function))
+(defclass temporary-argument (temporary-name) ())
+(defclass temporary-function (temporary-name) ())
+
+(export 'temporary-variable)
+(defclass temporary-variable (temporary-name)
+ ((in-use-p :initarg :in-use-p :initform nil
+ :type boolean :accessor var-in-use-p)))
+
+(defmethod commentify-argument-name ((name temporary-name))
+ nil)
+
+(export 'temporary-function)
+(defun temporary-function ()
+ "Return a temporary function name."
+ (make-instance 'temporary-function
+ :tag (prog1 *temporary-index* (incf *temporary-index*))))
+
+(defmethod format-temporary-name ((var temporary-name) stream)
+ (format stream "~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-argument) stream)
+ (format stream "sod__a~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-variable) stream)
+ (format stream "sod__v~A" (temp-tag var)))
+(defmethod format-temporary-name ((var temporary-function) stream)
+ (format stream "sod__f~A" (temp-tag var)))
+
+(defmethod print-object ((var temporary-name) stream)
+ (if *print-escape*
+ (print-unreadable-object (var stream :type t)
+ (prin1 (temp-tag var) stream))
+ (format-temporary-name var stream)))
+
+;;;--------------------------------------------------------------------------
+;;; Instruction types.
+
+;; Compound statements.
+
+(export '(if-inst make-if-inst
+ while-inst make-while-inst
+ do-inst make-do-inst
+ inst-condition inst-consequent inst-alternative inst-body))
+
+(definst if (stream) (condition consequent alternative)
+ (format-compound-statement (stream consequent alternative)
+ (format stream "if (~A)" condition))
+ (when alternative
+ (format-compound-statement (stream alternative)
+ (write-string "else" stream))))
+
+(definst while (stream) (condition body)
+ (format-compound-statement (stream body)
+ (format stream "while (~A)" condition)))
+
+(definst do-while (stream) (body condition)
+ (format-compound-statement (stream body :space)
+ (write-string "do" stream))
+ (format stream "while (~A);" condition))
+
+;; Special varargs hacks.
+
+(export '(va-start-inst make-va-start-inst
+ va-copy-inst make-va-copy-inst
+ va-end-inst make-va-end-inst
+ inst-ap inst-arg inst-to inst-from))
+
+(definst va-start (stream) (ap arg)
+ (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
+
+(definst va-copy (stream) (to from)
+ (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
+
+(definst va-end (stream) (ap)
+ (format stream "va_end(~A);" ap))
+
+;; Expressions.
+
+(export '(call-inst make-call-inst inst-func inst-args))
+
+(definst call (stream) (func args)
+ (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
+
+;;;--------------------------------------------------------------------------
+;;; Code generator objects.
+
+(defclass basic-codegen ()
+ ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
+ (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
+ (temp-index :initarg :temp-index :initform 0
+ :type fixnum :accessor codegen-temp-index))
+ (:documentation
+ "Base class for code generator state.
+
+ This contains the bare essentials for supporting the EMIT-INST and
+ ENSURE-VAR protocols; see the documentation for those generic functions
+ for more details.
+
+ This class isn't abstract. A full CODEGEN object uses instances of this
+ to keep track of pending functions which haven't been completed yet.
+
+ Just in case that wasn't clear enough: this is nothing to do with the
+ BASIC language."))
+
+(defmethod emit-inst ((codegen basic-codegen) inst)
+ (push inst (codegen-insts codegen)))
+
+(defmethod emit-insts ((codegen basic-codegen) insts)
+ (asetf (codegen-insts codegen) (revappend insts it)))
+
+(defmethod ensure-var ((codegen basic-codegen) name type &optional init)
+ (let* ((vars (codegen-vars codegen))
+ (var (find name vars :key #'inst-name :test #'equal)))
+ (cond ((not var)
+ (setf (codegen-vars codegen)
+ (cons (make-var-inst name type init) vars)))
+ ((not (c-type-equal-p type (inst-type var)))
+ (error "(Internal) Redefining type for variable ~A." name)))
+ name))
+
+(export 'codegen)
+(defclass codegen (basic-codegen)
+ ((functions :initform nil :type list :accessor codegen-functions)
+ (stack :initform nil :type list :accessor codegen-stack))
+ (:documentation
+ "A full-fat code generator which can generate and track functions.
+
+ This is the real deal. Subclasses may which to attach additional state
+ for convenience's sake, but this class is self-contained. It supports the
+ CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
+
+(defmethod codegen-push ((codegen codegen))
+ (with-slots (vars insts temp-index stack) codegen
+ (push (make-instance 'basic-codegen
+ :vars vars
+ :insts insts
+ :temp-index temp-index)
+ stack)
+ (setf vars nil insts nil temp-index 0)))
+
+(defmethod codegen-pop ((codegen codegen))
+ (with-slots (vars insts temp-index stack) codegen
+ (multiple-value-prog1
+ (values (nreverse vars) (nreverse insts))
+ (let ((sub (pop stack)))
+ (setf vars (codegen-vars sub)
+ insts (codegen-insts sub)
+ temp-index (codegen-temp-index sub))))))
+
+(defmethod codegen-add-function ((codegen codegen) function)
+ (with-slots (functions) codegen
+ (setf functions (nconc functions (list function)))))
+
+(defmethod temporary-var ((codegen basic-codegen) type)
+ (with-slots (vars temp-index) codegen
+ (or (some (lambda (var)
+ (let ((name (inst-name var)))
+ (if (and (not (var-in-use-p name))
+ (c-type-equal-p type (inst-type var)))
+ name
+ nil)))
+ vars)
+ (let* ((name (make-instance 'temporary-variable
+ :in-use-p t
+ :tag (prog1 temp-index
+ (incf temp-index)))))
+ (push (make-var-inst name type nil) vars)
+ name))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Implementation of lexical analysis protocol.
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Basic lexical analyser.
+
+(defstruct (pushed-token
+ (:constructor make-pushed-token (type value location)))
+ "A token that has been pushed back into a lexer for later processing."
+ type value location)
+
+;;; Class definition.
+
+(export 'basic-lexer)
+(defclass basic-lexer ()
+ ((stream :initarg :stream :type stream :reader lexer-stream)
+ (char :initform nil :type (or character null) :reader lexer-char)
+ (pushback-chars :initform nil :type list)
+ (token-type :initform nil :accessor token-type)
+ (token-value :initform nil :accessor token-value)
+ (location :initform nil :reader file-location)
+ (pushback-tokens :initform nil :type list))
+ (:documentation
+ "Base class for lexical analysers.
+
+ The lexer reads characters from STREAM, which, for best results, wants to
+ be a POSITION-AWARE-INPUT-STREAM.
+
+ The lexer provides one-character lookahead by default: the current
+ lookahead character is available to subclasses in the slot CHAR. Before
+ beginning lexical analysis, the lookahead character needs to be
+ established with NEXT-CHAR. If one-character lookahead is insufficient,
+ the analyser can push back an arbitrary number of characters using
+ PUSHBACK-CHAR.
+
+ The NEXT-TOKEN function scans and returns the next token from the STREAM,
+ and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token
+ lookahead. A parser using the lexical analyser can push back tokens using
+ PUSHBACK-TOKENS.
+
+ For convenience, the lexer implements a FILE-LOCATION method (delegated to
+ the underlying stream)."))
+
+;;; Reading and pushing back characters.
+
+(defmethod next-char ((lexer basic-lexer))
+ (with-slots (stream char pushback-chars) lexer
+ (setf char (if pushback-chars
+ (pop pushback-chars)
+ (read-char stream nil)))))
+
+(defmethod pushback-char ((lexer basic-lexer) new-char)
+ (with-slots (char pushback-chars) lexer
+ (push char pushback-chars)
+ (setf char new-char)))
+
+(defmethod fixup-stream* ((lexer basic-lexer) thunk)
+ (with-slots (stream char pushback-chars) lexer
+ (when pushback-chars
+ (error "Lexer has pushed-back characters."))
+ (when (slot-boundp lexer 'char)
+ (unread-char char stream))
+ (unwind-protect
+ (funcall thunk stream)
+ (setf char (read-char stream nil)))))
+
+;;; Reading and pushing back tokens.
+
+(defmethod next-token :around ((lexer basic-lexer))
+ (unless (slot-boundp lexer 'char)
+ (next-char lexer)))
+
+(defmethod next-token ((lexer basic-lexer))
+ (with-slots (pushback-tokens token-type token-value location) lexer
+ (setf (values token-type token-value)
+ (if pushback-tokens
+ (let ((pushback (pop pushback-tokens)))
+ (setf location (pushed-token-location pushback))
+ (values (pushed-token-type pushback)
+ (pushed-token-value pushback)))
+ (scan-token lexer)))))
+
+(defmethod scan-token :around ((lexer basic-lexer))
+ (with-default-error-location (lexer)
+ (call-next-method)))
+
+(defmethod pushback-token ((lexer basic-lexer) new-token-type
+ &optional new-token-value new-location)
+ (with-slots (pushback-tokens token-type token-value location) lexer
+ (push (make-pushed-token token-type token-value location)
+ pushback-tokens)
+ (when new-location (setf location new-location))
+ (setf token-type new-token-type
+ token-value new-token-value)))
+
+;;; Utilities.
+
+(defmethod skip-spaces ((lexer basic-lexer))
+ (do ((ch (lexer-char lexer) (next-char lexer)))
+ ((not (whitespace-char-p ch)) ch)))
+
+;;;--------------------------------------------------------------------------
+;;; Our main lexer.
+
+(export 'sod-lexer)
+(defclass sod-lexer (basic-lexer)
+ ()
+ (:documentation
+ "Lexical analyser for the SOD lanuage.
+
+ See the LEXER class for the gory details about the lexer protocol."))
+
+(defmethod scan-token ((lexer sod-lexer))
+ (with-slots (stream char keywords location) lexer
+ (prog (ch)
+
+ consider
+
+ ;; Stash the position of this token so that we can report it later.
+ (setf ch (skip-spaces lexer)
+ location (file-location stream))
+
+ ;; Now work out what it is that we're dealing with.
+ (cond
+
+ ;; End-of-file brings its own peculiar joy.
+ ((null ch) (return (values :eof t)))
+
+ ;; Strings.
+ ((or (char= ch #\") (char= ch #\'))
+ (let* ((quote ch)
+ (string
+ (with-output-to-string (out)
+ (loop
+ (flet ((getch ()
+ (setf ch (next-char lexer))
+ (when (null ch)
+ (cerror* "Unexpected end of file in ~
+ ~:[string~;character~] constant"
+ (char= quote #\'))
+ (return))))
+ (getch)
+ (cond ((char= ch quote) (return))
+ ((char= ch #\\) (getch)))
+ (write-char ch out))))))
+ (setf ch (next-char lexer))
+ (ecase quote
+ (#\" (return (values :string string)))
+ (#\' (case (length string)
+ (0 (cerror* "Empty character constant")
+ (return (values :char #\?)))
+ (1 (return (values :char (char string 0))))
+ (t (cerror* "Multiple characters in character constant")
+ (return (values :char (char string 0)))))))))
+
+ ;; Pick out identifiers and keywords.
+ ((or (alpha-char-p ch) (char= ch #\_))
+
+ ;; Scan a sequence of alphanumerics and underscores. We could
+ ;; allow more interesting identifiers, but it would damage our C
+ ;; lexical compatibility.
+ (let ((id (with-output-to-string (out)
+ (loop
+ (write-char ch out)
+ (setf ch (next-char lexer))
+ (when (or (null ch)
+ (not (or (alphanumericp ch)
+ (char= ch #\_))))
+ (return))))))
+
+ ;; Done.
+ (return (values :id id))))
+
+ ;; Pick out numbers. Currently only integers, but we support
+ ;; multiple bases.
+ ((digit-char-p ch)
+
+ ;; Sort out the prefix. If we're looking at `0b', `0o' or `0x'
+ ;; (maybe uppercase) then we've got a funny radix to deal with.
+ ;; Otherwise, a leading zero signifies octal (daft, I know), else
+ ;; we're left with decimal.
+ (multiple-value-bind (radix skip-char)
+ (if (char/= ch #\0)
+ (values 10 nil)
+ (case (and (setf ch (next-char lexer))
+ (char-downcase ch))
+ (#\b (values 2 t))
+ (#\o (values 8 t))
+ (#\x (values 16 t))
+ (t (values 8 nil))))
+
+ ;; If we last munched an interesting letter, we need to skip over
+ ;; it. That's what the SKIP-CHAR flag is for.
+ ;;
+ ;; Danger, Will Robinson! If we're just about to eat a radix
+ ;; letter, then the next thing must be a digit. For example,
+ ;; `0xfatenning' parses as a hex number followed by an identifier
+ ;; `0xfa ttening', but `0xturning' is an octal number followed by
+ ;; an identifier `0 xturning'.
+ (when skip-char
+ (let ((peek (next-char lexer)))
+ (unless (digit-char-p peek radix)
+ (pushback-char lexer ch)
+ (return-from scan-token (values :integer 0)))
+ (setf ch peek)))
+
+ ;; Scan an integer. While there are digits, feed them into the
+ ;; accumulator.
+ (do ((accum 0 (+ (* accum radix) digit))
+ (digit (and ch (digit-char-p ch radix))
+ (and ch (digit-char-p ch radix))))
+ ((null digit) (return-from scan-token
+ (values :integer accum)))
+ (setf ch (next-char lexer)))))
+
+ ;; A slash might be the start of a comment.
+ ((char= ch #\/)
+ (setf ch (next-char lexer))
+ (case ch
+
+ ;; Comment up to the end of the line.
+ (#\/
+ (loop
+ (setf ch (next-char lexer))
+ (when (or (null ch) (char= ch #\newline))
+ (go scan))))
+
+ ;; Comment up to the next `*/'.
+ (#\*
+ (tagbody
+ top
+ (case (setf ch (next-char lexer))
+ (#\* (go star))
+ ((nil) (go done))
+ (t (go top)))
+ star
+ (case (setf ch (next-char lexer))
+ (#\* (go star))
+ (#\/ (setf ch (next-char lexer))
+ (go done))
+ ((nil) (go done))
+ (t (go top)))
+ done)
+ (go consider))
+
+ ;; False alarm. (The next character is already set up.)
+ (t
+ (return (values #\/ t)))))
+
+ ;; A dot: might be `...'. Tread carefully! We need more lookahead
+ ;; than is good for us.
+ ((char= ch #\.)
+ (setf ch (next-char lexer))
+ (cond ((eql ch #\.)
+ (setf ch (next-char lexer))
+ (cond ((eql ch #\.) (return (values :ellipsis nil)))
+ (t (pushback-char lexer #\.)
+ (return (values #\. t)))))
+ (t
+ (return (values #\. t)))))
+
+ ;; Anything else is a lone delimiter.
+ (t
+ (return (multiple-value-prog1
+ (values ch t)
+ (next-char lexer)))))
+
+ scan
+ ;; Scan a new character and try again.
+ (setf ch (next-char lexer))
+ (go consider))))
+
+;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; Infrastructure for effective method generation
+;;; Method combination implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; 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
(cl:in-package #:sod)
-;;;--------------------------------------------------------------------------
-;;; Function type protocol.
-
-(defgeneric sod-message-argument-tail (message)
- (:documentation
- "Return the argument tail for the message, with invented argument names.
-
- No `me' argument is prepended; any :ELLIPSIS is left as it is."))
-
-(defgeneric sod-message-no-varargs-tail (message)
- (:documentation
- "Return the argument tail for the message with :ELLIPSIS substituted.
-
- As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
- However, an :ELLIPSIS is replaced by an argument of type `va_list', named
- `sod__ap'."))
-
-(defgeneric sod-method-function-type (method)
- (:documentation
- "Return the C function type for the direct method.
-
- This is called during initialization of a direct method object, and the
- result is cached.
-
- A default method is provided (by BASIC-DIRECT-METHOD) which simply
- prepends an appropriate `me' argument to the user-provided argument list.
- Fancy method classes may need to override this behaviour."))
-
-(defgeneric sod-method-next-method-type (method)
- (:documentation
- "Return the C function type for the next-method trampoline.
-
- This is called during initialization of a direct method object, and the
- result is cached. It should return a function type, not a pointer type.
-
- A default method is provided (by DELEGATING-DIRECT-METHOD) which should do
- the right job. Very fancy subclasses might need to do something
- different."))
-
-(defgeneric sod-method-function-name (method)
- (:documentation
- "Return the C function name for the direct method."))
-
-(defgeneric method-entry-function-type (entry)
- (:documentation
- "Return the C function type for a method entry."))
-
;;;--------------------------------------------------------------------------
;;; Message classes.
+(export 'basic-message)
(defclass basic-message (sod-message)
((argument-tail :type list :reader sod-message-argument-tail)
(no-varargs-tail :type list :reader sod-message-no-varargs-tail))
This is a separate class so that `special effect' messages can avoid
inheriting its default behaviour.
- The function type protocol is implemented on BASIC-MESSAGE using slot
+ The function type protocol is implemented on `basic-message' using slot
reader methods. The actual values are computed on demand in methods
- defined on SLOT-UNBOUND."))
-
-;;; Function type protocol.
+ defined on `slot-unbound'."))
(defmethod slot-unbound (class
(message basic-message)
(slot-name (eql 'argument-tail)))
(let ((seq 0))
- (mapcar (lambda (arg)
- (if (or (eq arg :ellipsis) (argument-name arg))
- arg
- (make-argument (make-instance 'temporary-argument
- :tag (prog1 seq (incf seq)))
- (argument-type arg))))
- (c-function-arguments (sod-message-type message)))))
+ (setf (slot-value message 'argument-tail)
+ (mapcar (lambda (arg)
+ (if (or (eq arg :ellipsis) (argument-name arg)) arg
+ (make-argument (make-instance 'temporary-argument
+ :tag (prog1 seq
+ (incf seq)))
+ (argument-type arg))))
+ (c-function-arguments (sod-message-type message))))))
(defmethod slot-unbound (class
(message basic-message)
(slot-name (eql 'no-varargs-tail)))
- (mapcar (lambda (arg)
- (if (eq arg :ellipsis)
- (make-argument *sod-ap* (c-type va-list))
- arg))
- (sod-message-argument-tail message)))
-
-;;; Method class selection.
+ (setf (slot-value message 'no-varargs-tail)
+ (mapcar (lambda (arg)
+ (if (eq arg :ellipsis)
+ (make-argument *sod-ap* (c-type va-list))
+ arg))
+ (sod-message-argument-tail message))))
(defmethod sod-message-method-class
((message basic-message) (class sod-class) pset)
((nil) (error "How odd: a primary method slipped through the net"))
(t (error "Unknown method role ~A" role)))))
-;;; Utility functions.
+(export 'simple-message)
+(defclass simple-message (basic-message)
+ ()
+ (:documentation
+ "Base class for messages with `simple' method combinations.
-(defun varargs-message-p (message)
- "Answer whether the MESSAGE accepts a variable-length argument list.
+ A simple method combination is one which has only one method role other
+ than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
+ We call these `primary' methods, and the programmer designates them by not
+ specifying an explicit role.
- We need to jump through some extra hoops in order to cope with varargs
- messages, so this is useful to know."
- (member :ellipsis (sod-message-argument-tail message)))
+ If the programmer doesn't define any primary methods then the effective
+ method is null -- i.e., the method entry pointer shows up as a null
+ pointer."))
+
+(defmethod sod-message-method-class
+ ((message simple-message) (class sod-class) pset)
+ (if (get-property pset :role :keyword nil)
+ (call-next-method)
+ (primary-method-class message)))
;;;--------------------------------------------------------------------------
;;; Direct method classes.
+(export 'basic-direct-method)
(defclass basic-direct-method (sod-method)
((role :initarg :role :type symbol :reader sod-method-role)
(function-type :type c-function-type :reader sod-method-function-type))
inheriting its default behaviour and slots.
A basic method can be assigned a `role', which may be set either as an
- initarg or using the :ROLE property. Roles are used for method
+ initarg or using the `:role' property. Roles are used for method
categorization.
- The function type protocol is implemented on BASIC-DIRECT-METHOD using
+ The function type protocol is implemented on `basic-direct-method' using
slot reader methods. The actual values are computed on demand in methods
- defined on SLOT-UNBOUND."))
+ defined on `slot-unbound'."))
(defmethod shared-initialize :after
((method basic-direct-method) slot-names &key pset)
(sod-class-nickname (sod-message-class message))
(sod-message-name message))))
+(export 'daemon-direct-method)
(defclass daemon-direct-method (basic-direct-method)
()
(:documentation
In C terms, a daemon method must return `void', and is not passed a
`next_method' pointer."))
-(defmethod check-method-type
- ((method daemon-direct-method)
- (message sod-message)
- (type c-function-type))
+(defmethod check-method-type ((method daemon-direct-method)
+ (message sod-message)
+ (type c-function-type))
(with-slots ((msgtype type)) message
(unless (c-type-equal-p (c-type-subtype type) (c-type void))
(error "Method return type ~A must be `void'" (c-type-subtype type)))
(c-function-arguments type))
(error "Method arguments ~A don't match message ~A" type msgtype))))
+(export 'delegating-direct-method)
(defclass delegating-direct-method (basic-direct-method)
((next-method-type :type c-function-type
:reader sod-method-next-method-type))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
-(defgeneric effective-method-basic-argument-names (method)
- (:documentation
- "Return a list of argument names to be passed to direct methods.
-
- The argument names are constructed from the message's arguments returned
- by SOD-MESSAGE-NO-VARARGS-TAIL. The basic arguments are the ones
- immediately derived from the programmer's explicitly stated arguments; the
- `me' argument is not included, and neither are more exotic arguments added
- as part of the method delegation protocol."))
-
+(export 'basic-effective-method)
(defclass basic-effective-method (effective-method)
((around-methods :initarg :around-methods :initform nil
:type list :reader effective-method-around-methods)
`around' methods and provides behaviour for invoking these methods
correctly.
- The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using
- a slot reader method. The actual values are computed on demand in methods
- defined on SLOT-UNBOUND."))
+ The argument names protocol is implemented on `basic-effective-method'
+ using a slot reader method. The actual values are computed on demand in
+ methods defined on `slot-unbound'."))
(defmethod slot-unbound (class
(method basic-effective-method)
(mapcar #'argument-name
(sod-message-no-varargs-tail message))))))
-;;;--------------------------------------------------------------------------
-;;; Method categorization.
-
-(defmacro categorize ((itemvar items &key bind) categories &body body)
- "Categorize ITEMS into lists and invoke BODY.
-
- The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
- will contain the current item. The BIND argument is a list of LET*-like
- clauses. The CATEGORIES are a list of clauses of the form (SYMBOL
- PREDICATE).
-
- The behaviour of the macro is as follows. ITEMVAR is assigned (not
- bound), in turn, each item in the list ITEMS. The PREDICATEs in the
- CATEGORIES list are evaluated in turn, in an environment containing
- ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
- At this point, the item is assigned to the category named by the
- corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an
- error is signalled; a PREDICATE consisting only of T will (of course)
- match anything; it is detected specially so as to avoid compiler warnings.
-
- Once all of the ITEMS have been categorized in this fashion, the BODY is
- evaluated as an implicit PROGN. For each SYMBOL naming a category, a
- variable named after that symbol will be bound in the BODY's environment
- to a list of the items in that category, in the same order in which they
- were found in the list ITEMS. The final values of the macro are the final
- values of the BODY."
-
- (let* ((cat-names (mapcar #'car categories))
- (cat-match-forms (mapcar #'cadr categories))
- (cat-vars (mapcar (lambda (name) (gensym (symbol-name name)))
- cat-names))
- (items-var (gensym "ITEMS")))
- `(let ((,items-var ,items)
- ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
- (dolist (,itemvar ,items-var)
- (let* ,bind
- (cond ,@(mapcar (lambda (cat-match-form cat-var)
- `(,cat-match-form
- (push ,itemvar ,cat-var)))
- cat-match-forms cat-vars)
- ,@(and (not (member t cat-match-forms))
- `((t (error "Failed to categorize ~A" ,itemvar)))))))
- (let ,(mapcar (lambda (name var)
- `(,name (nreverse ,var)))
- cat-names cat-vars)
- ,@body))))
+(defmethod effective-method-function-name ((method effective-method))
+ (let* ((class (effective-method-class method))
+ (message (effective-method-message method))
+ (message-class (sod-message-class message)))
+ (format nil "~A__emethod_~A__~A"
+ class
+ (sod-class-nickname message-class)
+ (sod-message-name message))))
-;;;--------------------------------------------------------------------------
-;;; Code generation.
+(defmethod slot-unbound
+ (class (method basic-effective-method) (slot-name (eql 'functions)))
+ (setf (slot-value method 'functions)
+ (compute-method-entry-functions method)))
-(defclass method-codegen (codegen)
- ((message :initarg :message :type sod-message :reader codegen-message)
- (class :initarg :class :type sod-class :reader codegen-class)
- (method :initarg :method :type effective-method :reader codegen-method)
- (target :initarg :target :reader codegen-target))
+(export 'simple-effective-method)
+(defclass simple-effective-method (basic-effective-method)
+ ((primary-methods :initarg :primary-methods :initform nil
+ :type list :reader effective-method-primary-methods))
(:documentation
- "Augments CODEGEN with additional state regarding an effective method.
+ "Effective method counterpart to `simple-message'."))
- We store the effective method, and also its target class and owning
- message, so that these values are readily available to the code-generating
- functions."))
+(defmethod shared-initialize :after
+ ((method simple-effective-method) slot-names &key direct-methods)
+ (declare (ignore slot-names))
+ (categorize (method direct-methods :bind ((role (sod-method-role method))))
+ ((primary (null role))
+ (before (eq role :before))
+ (after (eq role :after))
+ (around (eq role :around)))
+ (with-slots (primary-methods before-methods after-methods around-methods)
+ method
+ (setf primary-methods primary
+ before-methods before
+ after-methods (reverse after)
+ around-methods around))))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
(defmethod shared-initialize :after
((codegen method-codegen) slot-names &key)
:void
:return))))
-(defgeneric compute-effective-method-body (method codegen target)
- (:documentation
- "Generates the body of an effective method.
-
- Writes the function body to the code generator. It can (obviously)
- generate auxiliary functions if it needs to.
-
- The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an
- additional argument `sod__obj' of type pointer-to-ilayout. The code
- should deliver the result (if any) to the TARGET."))
-
-(defun invoke-method (codegen target arguments-tail direct-method)
- "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
-
- The code is generated in the context of CODEGEN, which can be any instance
- of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN. The
- DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument
- expressions), preceded by a `me' argument of type pointer-to-CLASS where
- CLASS is the class on which the method was defined.
-
- If the message accepts a variable-length argument list then a copy of the
- prevailing master argument pointer is provided in place of the :ELLIPSIS."
-
- (let* ((message (sod-method-message direct-method))
- (class (sod-method-class direct-method))
- (function (sod-method-function-name direct-method))
- (arguments (cons (format nil "&sod__obj.~A.~A"
- (sod-class-nickname
- (sod-class-chain-head class))
- (sod-class-nickname class))
- arguments-tail)))
- (if (varargs-message-p message)
- (convert-stmts codegen target
- (c-type-subtype (sod-method-type direct-method))
- (lambda (var)
- (ensure-var codegen *sod-ap* (c-type va-list))
- (emit-inst codegen
- (make-va-copy-inst *sod-ap*
- *sod-master-ap*))
- (deliver-expr codegen var
- (make-call-inst function arguments))
- (emit-inst codegen
- (make-va-end-inst *sod-ap*))))
- (deliver-expr codegen target (make-call-inst function arguments)))))
-
-(definst convert-to-ilayout (stream) (class chain-head expr)
- (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
- class (sod-class-nickname chain-head) expr))
-
-(defun ensure-ilayout-var (codegen super)
- "Define a variable `sod__obj' pointing to the class's ilayout structure.
-
- CODEGEN is a METHOD-CODEGEN. The class in question is CODEGEN's class,
- i.e., the target class for the effective method. SUPER is one of the
- class's superclasses; it is assumed that `me' is a pointer to a SUPER
- (i.e., to SUPER's ichain within the ilayout)."
-
- (let* ((class (codegen-class codegen))
- (super-head (sod-class-chain-head super)))
- (ensure-var codegen "sod__obj"
- (c-type (* (struct (ilayout-struct-tag class))))
- (make-convert-to-ilayout-inst class super-head "me"))))
-
-(defun make-trampoline (codegen super body)
- "Construct a trampoline function and return its name.
-
- CODEGEN is a METHOD-CODEGEN. SUPER is a superclass of the CODEGEN class.
- We construct a new trampoline function (with an unimaginative name)
- suitable for being passed to a direct method defined on SUPER as its
- `next_method'. In particular, it will have a `me' argument whose type is
- pointer-to-SUPER.
-
- The code of the function is generated by BODY, which will be invoked with
- a single argument which is the TARGET to which it should deliver its
- result.
-
- The return value is the name of the generated function."
-
- (let* ((message (codegen-message codegen))
- (message-type (sod-message-type message))
- (return-type (c-type-subtype message-type))
- (arguments (mapcar (lambda (arg)
- (if (eq (argument-name arg) *sod-ap*)
- (make-argument *sod-master-ap*
- (c-type va-list))
- arg))
- (sod-message-no-varargs-tail message))))
- (codegen-push codegen)
- (ensure-ilayout-var codegen super)
- (funcall body (codegen-target codegen))
- (codegen-pop-function codegen (temporary-function)
- (c-type (fun (lisp return-type)
- ("me" (* (class super)))
- . arguments)))))
-
-(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
- "Invoke a chain of delegating methods.
-
- CODEGEN is a METHOD-CODEGEN. BASIC-TAIL is a list of argument expressions
- to provide to the methods. The result of the delegation chain will be
- delivered to TARGET.
-
- The CHAIN is a list of DELEGATING-DIRECT-METHOD objects. The behaviour is
- as follows. The first method in the chain is invoked with the necessary
- arguments (see below) including a `next_method' pointer. If KERNEL is nil
- and there are no more methods in the chain then the `next_method' pointer
- will be null; otherwise it will point to a `trampoline' function, whose
- behaviour is to call the remaining methods on the chain as a delegation
- chain. The method may choose to call this function with its arguments.
- It will finally return a value, which will be delivered to the TARGET.
-
- If the chain is empty, then the code generated by KERNEL (given a TARGET
- argument) will be invoked. It is an error if both CHAIN and KERNEL are
- nil."
-
- (let* ((message (codegen-message codegen))
- (argument-tail (if (varargs-message-p message)
- (cons *sod-master-ap* basic-tail)
- basic-tail)))
- (labels ((next-trampoline (method chain)
- (if (or kernel chain)
- (make-trampoline codegen (sod-method-class method)
- (lambda (target)
- (invoke chain target)))
- 0))
- (invoke (chain target)
- (if (null chain)
- (funcall kernel target)
- (let* ((trampoline (next-trampoline (car chain)
- (cdr chain))))
- (invoke-method codegen target
- (cons trampoline argument-tail)
- (car chain))))))
- (invoke chain target))))
+;;;--------------------------------------------------------------------------
+;;; Invoking direct methods.
+(export 'basic-effective-method-body)
(defun basic-effective-method-body (codegen target method body)
"Build the common method-invocation structure.
around-methods #'method-kernel)))))
;;;--------------------------------------------------------------------------
-;;; Effective method entry points.
-
-(defgeneric compute-method-entry-functions (method)
- (:documentation
- "Construct method entry functions.
-
- Builds the effective method function (if there is one) and the necessary
- method entries. Returns a list of functions (i.e., FUNCTION-INST objects)
- which need to be defined in the generated source code."))
+;;; Method entry points.
(defparameter *method-entry-inline-threshold* 200
"Threshold below which effective method bodies are inlined into entries.
fold the method body into the entry functions; otherwise we split the
effective method out into its own function.")
-(defgeneric effective-method-function-name (method)
- (:documentation
- "Returns the function name of an effective method."))
-
-(defgeneric method-entry-function-name (method chain-head)
- (:documentation
- "Returns the function name of a method entry.
-
- The method entry is given as an effective method/chain-head pair, rather
- than as a method entry object because we want the function name before
- we've made the entry object."))
-
-(defmethod effective-method-function-name ((method effective-method))
- (let* ((class (effective-method-class method))
- (message (effective-method-message method))
- (message-class (sod-message-class message)))
- (format nil "~A__emethod_~A__~A"
- class
- (sod-class-nickname message-class)
- (sod-message-name message))))
-
(defmethod method-entry-function-name
((method effective-method) (chain-head sod-class))
(let* ((class (effective-method-class method))
(message (effective-method-message method))
(message-class (sod-message-class message)))
- (format nil "~A__mentry_~A__~A__chain_~A"
- class
- (sod-class-nickname message-class)
- (sod-message-name message)
- (sod-class-nickname chain-head))))
+ (if (or (not (slot-boundp method 'functions))
+ (slot-value method 'functions))
+ (format nil "~A__mentry_~A__~A__chain_~A"
+ class
+ (sod-class-nickname message-class)
+ (sod-message-name message)
+ (sod-class-nickname chain-head))
+ 0)))
+
+(defmethod method-entry-function-type ((entry method-entry))
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (type (sod-message-type message)))
+ (c-type (fun (lisp (c-type-subtype type))
+ ("me" (* (class (method-entry-chain-tail entry))))
+ . (sod-message-argument-tail message)))))
+
+(defmethod make-method-entry ((method basic-effective-method)
+ (chain-head sod-class) (chain-tail sod-class))
+ (make-instance 'method-entry
+ :method method
+ :chain-head chain-head
+ :chain-tail chain-tail))
(defmethod compute-method-entry-functions ((method basic-effective-method))
(return prev))))
(entry-target (codegen-target codegen)))
- (labels ((setup-entry (tail)
- (let ((head (sod-class-chain-head tail)))
- (codegen-push codegen)
- (ensure-var codegen "sod__obj" ilayout-type
- (make-convert-to-ilayout-inst class
- head "me"))))
- (varargs-prologue ()
- (ensure-var codegen *sod-master-ap* (c-type va-list))
- (emit-inst codegen
- (make-va-start-inst *sod-master-ap* parm-n)))
- (varargs-epilogue ()
- (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
- (finish-entry (tail)
- (let* ((head (sod-class-chain-head tail))
- (name (method-entry-function-name method head))
- (type (c-type (fun (lisp return-type)
- ("me" (* (class tail)))
- . entry-args))))
- (codegen-pop-function codegen name type))))
+ (flet ((setup-entry (tail)
+ (let ((head (sod-class-chain-head tail)))
+ (codegen-push codegen)
+ (ensure-var codegen "sod__obj" ilayout-type
+ (make-convert-to-ilayout-inst class
+ head "me"))))
+ (varargs-prologue ()
+ (ensure-var codegen *sod-master-ap* (c-type va-list))
+ (emit-inst codegen
+ (make-va-start-inst *sod-master-ap* parm-n)))
+ (varargs-epilogue ()
+ (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
+ (finish-entry (tail)
+ (let* ((head (sod-class-chain-head tail))
+ (name (method-entry-function-name method head))
+ (type (c-type (fun (lisp return-type)
+ ("me" (* (class tail)))
+ . entry-args))))
+ (codegen-pop-function codegen name type))))
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
(codegen-functions codegen))))
-(defmethod slot-unbound
- (class (method basic-effective-method) (slot-name (eql 'functions)))
- (setf (slot-value method 'functions)
- (compute-method-entry-functions method)))
+(defmethod compute-method-entry-functions
+ ((method simple-effective-method))
+ (if (effective-method-primary-methods method)
+ (call-next-method)
+ nil))
+
+(defmethod compute-effective-method-body
+ ((method simple-effective-method) codegen target)
+ (with-slots (message basic-argument-names primary-methods) method
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target)))))
-(defmethod method-entry-function-type ((entry method-entry))
- (let* ((method (method-entry-effective-method entry))
- (message (effective-method-message method))
- (type (sod-message-type message)))
- (c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (method-entry-chain-tail entry))))
- . (sod-message-argument-tail message)))))
+;;;--------------------------------------------------------------------------
+;;; Standard method combination.
-(defmethod make-method-entry ((method basic-effective-method)
- (chain-head sod-class) (chain-tail sod-class))
- (make-instance 'method-entry
- :method method
- :chain-head chain-head
- :chain-tail chain-tail))
+(export 'standard-message)
+(defclass standard-message (simple-message)
+ ()
+ (:documentation
+ "Message class for standard method combination.
-;;;--------------------------------------------------------------------------
-;;; Output.
-
-(defmethod add-output-hooks progn
- ((method basic-effective-method) (reason (eql :c)) sequencer)
- (with-slots (class functions) method
- (sequence-output (stream sequencer)
- ((class :effective-methods)
- (dolist (func functions)
- (write func :stream stream :escape nil :circle nil))))))
+ Standard method combination is a simple method combination where the
+ primary methods are invoked as a delegation chain, from most- to
+ least-specific."))
+
+(export 'standard-effective-method)
+(defclass standard-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `standard-message'."))
+
+(defmethod primary-method-class ((message standard-message))
+ 'delegating-direct-method)
+
+(defmethod message-effective-method-class ((message standard-message))
+ 'standard-effective-method)
+
+(defmethod simple-method-body
+ ((method standard-effective-method) codegen target)
+ (invoke-delegation-chain codegen
+ target
+ (effective-method-basic-argument-names method)
+ (effective-method-primary-methods method)
+ nil))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Module protocol implementation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Module basics.
+
+(defmethod module-import ((module module))
+ (dolist (item (module-items module))
+ (module-import item)))
+
+(defmethod add-to-module ((module module) item)
+ (setf (module-items module)
+ (nconc (module-items module) (list item)))
+ (module-import item))
+
+(defmethod shared-initialize :after ((module module) slot-names &key pset)
+ "Tick off known properties on the property set."
+ (declare (ignore slot-names))
+ (dolist (prop '(:guard))
+ (get-property pset prop nil)))
+
+(defmethod finalize-module ((module module))
+ (let* ((pset (module-pset module))
+ (class (get-property pset :lisp-class :symbol 'module)))
+
+ ;; Always call `change-class', even if it's the same one; this will
+ ;; exercise the property-set fiddling in `shared-initialize' and we can
+ ;; catch unknown-property errors.
+ (change-class module class :state t :pset pset)
+ (check-unused-properties pset)
+ module))
+
+;;;--------------------------------------------------------------------------
+;;; Module objects.
+
+(defparameter *module-map* (make-hash-table :test #'equal)
+ "Hash table mapping true names to module objects.")
+
+(defun build-module
+ (name thunk &key (truename (probe-file name)) location)
+ "Construct a new module.
+
+ This is the functionality underlying `define-module'."
+
+ (let ((*module* (make-instance 'module
+ :name (pathname name)
+ :state (file-location location))))
+ (when truename
+ (setf (gethash truename *module-map*) *module*))
+ (unwind-protect
+ (call-with-module-environment (lambda ()
+ (module-import *builtin-module*)
+ (funcall thunk)
+ (finalize-module *module*)))
+ (when (and truename (not (eq (module-state *module*) t)))
+ (remhash truename *module-map*)))))
+
+;;;--------------------------------------------------------------------------
+;;; Type definitions.
+
+(export 'type-item)
+(defclass type-item ()
+ ((name :initarg :name :type string :reader type-name))
+ (:documentation
+ "A note that a module exports a type.
+
+ We can only export simple types, so we only need to remember the name.
+ The magic simple-type cache will ensure that we get the same type object
+ when we do the import."))
+
+(defmethod module-import ((item type-item))
+ (let* ((name (type-name item))
+ (def (gethash name *module-type-map*))
+ (type (make-simple-type name)))
+ (cond ((not def)
+ (setf (gethash name *module-type-map*) type))
+ ((not (eq def type))
+ (error "Conflicting types `~A'" name)))))
+
+(defmethod module-import ((class sod-class))
+ (record-sod-class class))
+
+;;;--------------------------------------------------------------------------
+;;; Code fragments.
+
+(export 'c-fragment)
+(defclass c-fragment ()
+ ((location :initarg :location :type file-location
+ :accessor c-fragment-location)
+ (text :initarg :text :type string :accessor c-fragment-text))
+ (:documentation
+ "Represents a fragment of C code to be written to an output file.
+
+ A C fragment is aware of its original location, and will bear proper #line
+ markers when written out."))
+
+(defun output-c-excursion (stream location thunk)
+ "Invoke THUNK surrounding it by writing #line markers to STREAM.
+
+ The first marker describes LOCATION; the second refers to the actual
+ output position in STREAM. If LOCATION doesn't provide a line number then
+ no markers are output after all. If the output stream isn't
+ position-aware then no final marker is output."
+
+ (let* ((location (file-location location))
+ (line (file-location-line location))
+ (filename (file-location-filename location)))
+ (cond (line
+ (format stream "~&#line ~D~@[ ~S~]~%" line filename)
+ (funcall thunk)
+ (when (typep stream 'position-aware-stream)
+ (fresh-line stream)
+ (format stream "~&#line ~D ~S~%"
+ (1+ (position-aware-stream-line stream))
+ (namestring (stream-pathname stream)))))
+ (t
+ (funcall thunk)))))
+
+(defmethod print-object ((fragment c-fragment) stream)
+ (let ((text (c-fragment-text fragment))
+ (location (c-fragment-location fragment)))
+ (if *print-escape*
+ (print-unreadable-object (fragment stream :type t)
+ (when location
+ (format stream "~A " location))
+ (cond ((< (length text) 40)
+ (prin1 text stream) stream)
+ (t
+ (prin1 (subseq text 0 37) stream)
+ (write-string "..." stream))))
+ (output-c-excursion stream location
+ (lambda () (write-string text stream))))))
+
+(defmethod make-load-form ((fragment c-fragment) &optional environment)
+ (make-load-form-saving-slots fragment :environment environment))
+
+(export 'code-fragment-item)
+(defclass code-fragment-item ()
+ ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+ (reason :initarg :reason :type keyword :reader code-fragment-reason)
+ (name :initarg :name :type t :reader code-fragment-name)
+ (constraints :initarg :constraints :type list
+ :reader code-fragment-constraints))
+ (:documentation
+ "A plain fragment of C to be dropped in at top-level."))
+
+(defmacro define-fragment ((reason name) &body things)
+ (categorize (thing things)
+ ((constraints (listp thing))
+ (frags (typep thing '(or string c-fragment))))
+ (when (null frags)
+ (error "Missing code fragment"))
+ (when (cdr frags)
+ (error "Multiple code fragments"))
+ `(add-to-module
+ *module*
+ (make-instance 'code-fragment-item
+ :fragment ',(car frags)
+ :name ,name
+ :reason ,reason
+ :constraints (list ,@(mapcar (lambda (constraint)
+ (cons 'list constraint))
+ constraints))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output scheduling protocol implementation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(defmethod print-object ((item sequencer-item) stream)
+ (print-unreadable-object (item stream :type t)
+ (prin1 (sequencer-item-name item) stream)))
+
+(defmethod ensure-sequencer-item ((sequencer sequencer) name)
+ (with-slots (table) sequencer
+ (or (gethash name table)
+ (setf (gethash name table)
+ (make-instance 'sequencer-item :name name)))))
+
+(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list))
+ (let ((converted-constraint
+ (mapcar (lambda (name)
+ (ensure-sequencer-item sequencer name))
+ constraint)))
+ (with-slots (constraints) sequencer
+ (pushnew converted-constraint constraints :test #'equal))))
+
+(defmethod add-sequencer-item-function ((sequencer sequencer) name function)
+ (let ((item (ensure-sequencer-item sequencer name)))
+ (pushnew function (sequencer-item-functions item))))
+
+(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments)
+ (dolist (item (merge-lists (reverse (sequencer-constraints sequencer))))
+ (dolist (function (reverse (sequencer-item-functions item)))
+ (apply function arguments))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Implementation for property sets
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Property representation.
+
+(defmethod file-location ((prop property))
+ (file-location (p-location prop)))
+
+;;; Keywords.
+
+(defmethod coerce-property-value
+ ((value symbol) (type (eql :symbol)) (wanted (eql :keyword)))
+ value)
+
+(defmethod coerce-property-value
+ ((value string) (type (eql :id)) (wanted (eql :keyword)))
+ (string-to-symbol value :package :keyword))
+
+(defmethod coerce-property-value
+ ((value string) (type (eql :string)) (wanted (eql :keyword)))
+ (string-to-symbol value :package :keyword :swap-hyphen nil))
+
+;;; Symbols.
+
+(defmethod coerce-property-value
+ ((value string) (type (eql :id)) (wanted (eql :symbol)))
+ (string-to-symbol value))
+
+(defmethod coerce-property-value
+ ((value string) (type (eql :string)) (wanted (eql :symbol)))
+ (string-to-symbol value :swap-hyphen nil))
+
+;;; Identifiers.
+
+(defmethod coerce-property-value
+ ((value string) (type (eql :string)) (wanted (eql :id)))
+ value)
+
+(defmethod coerce-property-value
+ ((value symbol) (type (eql :symbol)) (wanted (eql :id)))
+ (frob-identifier (symbol-name value)))
+
+;;;--------------------------------------------------------------------------
+;;; Property sets.
+
+(defmethod print-object ((pset pset) stream)
+ (print-unreadable-object (pset stream :type t)
+ (pprint-logical-block (stream nil)
+ (let ((firstp t))
+ (pset-map (lambda (prop)
+ (cond (firstp (setf firstp nil))
+ (t (write-char #\space stream)
+ (pprint-newline :linear stream)))
+ (format stream "~:@<~S ~@_~S ~@_~S~:>"
+ (p-name prop) (p-type prop) (p-value prop)))
+ pset)))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+(cl:in-package #:sod)
+
+(defun play-fetch-token (string)
+ (with-parser-context (string-parser :string string)
+ (labels ((digit (radix)
+ (parse (filter (lambda (ch)
+ (digit-char-p ch radix)))))
+ (number (radix &optional (initial 0))
+ (parse (many (a initial (+ (* radix a) it))
+ (digit radix))))
+ (numeric (radix sigil)
+ (parse (seq ((first (peek (seq ((nil (funcall sigil))
+ (d (digit radix)))
+ d)))
+ (result (number radix first)))
+ result))))
+ (multiple-value-call #'values
+ (loop
+ (parse :whitespace)
+
+ (cond-parse ()
+
+ ;; Give up at end-of-file.
+ (:eof
+ (return (values :eof nil)))
+
+ ;; Pick out comments.
+ ((peek (and #\/ #\*))
+ (parse (skip-many () ; this may fail at eof; don't worry
+ (and (skip-many () (not #\*))
+ (skip-many (:min 1) #\*))
+ (not #\/)))
+ (if-parse :eof ()
+ (cerror* "Unterminated comment")
+ (parse :any)))
+ ((and (peek (seq (#\/ #\/)))
+ (skip-many () (not #\newline))
+ (or :eof #\newline)))
+
+ ;; Quoted strings and characters.
+ ((or #\' #\")
+ (let ((quote it)
+ (out (make-string-output-stream)))
+ (parse (skip-many ()
+ (or (seq ((ch (satisfies (lambda (ch)
+ (and (char/= ch #\\)
+ (char/= ch quote))))))
+ (write-char ch out))
+ (seq (#\\ (ch :any))
+ (write-char ch out)))))
+ (if-parse :eof ()
+ (cerror* "Unterminated ~:[string~;character~] constant"
+ (char= quote #\'))
+ (parse :any))
+ (let ((string (get-output-stream-string out)))
+ (ecase quote
+ (#\" (return (values :string string)))
+ (#\' (case (length string)
+ (0 (cerror* "Empty character constant")
+ (return (values :char #\?)))
+ (1 (return (values :char (char string 0))))
+ (t (cerror* "Multiple characters in ~
+ character constant")
+ (return (values :char (char string 0))))))))))
+
+ ;; Identifiers.
+ ((seq ((first (satisfies (lambda (ch)
+ (or (char= ch #\_)
+ (alpha-char-p ch)))))
+ (ident (many (out (let ((s (make-string-output-stream)))
+ (write-char first s)
+ s)
+ (progn (write-char it out) out)
+ :final (get-output-stream-string out))
+ (satisfies (lambda (ch)
+ (or (char= ch #\_)
+ (alphanumericp ch)))))))
+ (return (values :id ident))))
+
+ ;; Numbers -- uses the machinery in the labels above.
+ ((or (seq (#\0
+ (i (or (numeric 8 (parser () (or #\o #\O)))
+ (numeric 16 (parser () (or #\x #\X)))
+ (number 8))))
+ i)
+ (seq ((first (digit 10))
+ (rest (number 10 first)))
+ rest))
+ (return (values :integer it)))
+
+ ;; Special separator tokens.
+ ("..."
+ (return (values :ellipsis :ellipsis)))
+
+ ;; Anything else is a standalone delimiter character.
+ (:any
+ (return (values it it)))))
+ (parse (list () :any))))))
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output for classes
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(defmethod hook-output progn ((class sod-class) (reason (eql :h))
+ sequencer)
+
+ ;; Main output sequencing.
+ (sequence-output (stream sequencer)
+
+ :constraint
+ ((:classes :start)
+ (class :banner)
+ (class :islots :start) (class :islots :slots) (class :islots :end)
+ (class :vtmsgs :start) (class :vtmsgs :end)
+ (class :vtables :start) (class :vtables :end)
+ (class :vtable-externs) (class :vtable-externs-after)
+ (class :methods :start) (class :methods) (class :methods :end)
+ (class :ichains :start) (class :ichains :end)
+ (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
+ (class :conversions)
+ (class :object)
+ (:classes :end))
+
+ (:typedefs
+ (format stream "typedef struct ~A ~A;~%"
+ (ichain-struct-tag class (sod-class-chain-head class)) class))
+
+ ((class :banner)
+ (banner (format nil "Class ~A" class) stream))
+ ((class :vtable-externs-after)
+ (terpri stream))
+
+ ((class :vtable-externs)
+ (format stream "/* Vtable structures. */~%"))
+
+ ((class :object)
+ (let ((metaclass (sod-class-metaclass class))
+ (metaroot (find-root-metaclass class)))
+ (format stream "/* The class object. */~@
+ extern const struct ~A ~A__classobj;~@
+ #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
+ (ilayout-struct-tag metaclass) class
+ (sod-class-nickname (sod-class-chain-head metaroot))
+ (sod-class-nickname metaroot)))))
+
+ ;; Maybe generate an islots structure.
+ (when (sod-class-slots class)
+ (dolist (slot (sod-class-slots class))
+ (hook-output slot 'islots sequencer))
+ (sequence-output (stream sequencer)
+ ((class :islots :start)
+ (format stream "/* Instance slots. */~@
+ struct ~A {~%"
+ (islots-struct-tag class)))
+ ((class :islots :end)
+ (format stream "};~2%"))))
+
+ ;; Declare the direct methods.
+ (when (sod-class-methods class)
+ (sequence-output (stream sequencer)
+ ((class :methods :start)
+ (format stream "/* Direct methods. */~%"))
+ ((class :methods :end)
+ (terpri stream))))
+
+ ;; Provide upcast macros which do the right thing.
+ (when (sod-class-direct-superclasses class)
+ (sequence-output (stream sequencer)
+ ((class :conversions)
+ (let ((chain-head (sod-class-chain-head class)))
+ (format stream "/* Conversion macros. */~%")
+ (dolist (super (cdr (sod-class-precedence-list class)))
+ (let ((super-head (sod-class-chain-head super)))
+ (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
+ ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
+ class (sod-class-nickname super) super
+ (eq chain-head super-head)
+ (sod-class-nickname super-head))))
+ (terpri stream)))))
+
+ ;; Generate vtmsgs structure for all superclasses.
+ (hook-output (car (sod-class-vtables class))
+ 'vtmsgs
+ sequencer))
+
+(defmethod hook-output progn ((class sod-class) reason sequencer)
+ (with-slots (ilayout vtables methods effective-methods) class
+ (hook-output ilayout reason sequencer)
+ (dolist (method methods) (hook-output method reason sequencer))
+ (dolist (method effective-methods)
+ (hook-output method reason sequencer))
+ (dolist (vtable vtables) (hook-output vtable reason sequencer))))
+
+;;;--------------------------------------------------------------------------
+;;; Instance structure.
+
+(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
+ sequencer)
+ (sequence-output (stream sequencer)
+ (((sod-slot-class slot) :islots :slots)
+ (pprint-logical-block (stream nil :prefix " " :suffix ";")
+ (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
+ (terpri stream))))
+
+(defmethod hook-output progn ((ilayout ilayout) reason sequencer)
+ (with-slots (ichains) ilayout
+ (dolist (ichain ichains) (hook-output ichain reason sequencer))))
+
+(defmethod hook-output progn ((ichain ichain) reason sequencer)
+ (dolist (item (ichain-body ichain))
+ (hook-output item reason sequencer)))
+
+(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
+ sequencer)
+ (with-slots (class ichains) ilayout
+ (sequence-output (stream sequencer)
+ ((class :ilayout :start)
+ (format stream "/* Instance layout. */~@
+ struct ~A {~%"
+ (ilayout-struct-tag class)))
+ ((class :ilayout :end)
+ (format stream "};~2%")))
+ (dolist (ichain ichains)
+ (hook-output ichain 'ilayout sequencer))))
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head chain-tail) ichain
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :ichains :start)
+ (class :ichain chain-head :start)
+ (class :ichain chain-head :slots)
+ (class :ichain chain-head :end)
+ (class :ichains :end))
+ ((class :ichain chain-head :start)
+ (format stream "/* Instance chain structure. */~@
+ struct ~A {~%"
+ (ichain-struct-tag chain-tail chain-head)))
+ ((class :ichain chain-head :end)
+ (format stream "};~2%")
+ (format stream "/* Union of equivalent superclass chains. */~@
+ union ~A {~@
+ ~:{ struct ~A ~A;~%~}~
+ };~2%"
+ (ichain-union-tag chain-tail chain-head)
+
+ ;; Make sure the most specific class is first: only the
+ ;; first element of a union can be statically initialized in
+ ;; C90.
+ (mapcar (lambda (super)
+ (list (ichain-struct-tag super chain-head)
+ (sod-class-nickname super)))
+ (sod-class-chain chain-tail))))))))
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
+ sequencer)
+ (with-slots (class chain-head chain-tail) ichain
+ (sequence-output (stream sequencer)
+ ((class :ilayout :slots)
+ (format stream " union ~A ~A;~%"
+ (ichain-union-tag chain-tail chain-head)
+ (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head chain-tail) vtptr
+ (sequence-output (stream sequencer)
+ ((class :ichain chain-head :slots)
+ (format stream " const struct ~A *_vt;~%"
+ (vtable-struct-tag chain-tail chain-head))))))
+
+(defmethod hook-output progn ((islots islots) reason sequencer)
+ (dolist (slot (islots-slots islots))
+ (hook-output slot reason sequencer)))
+
+(defmethod hook-output progn ((islots islots) (reason (eql :h))
+ sequencer)
+ (with-slots (class subclass slots) islots
+ (sequence-output (stream sequencer)
+ ((subclass :ichain (sod-class-chain-head class) :slots)
+ (format stream " struct ~A ~A;~%"
+ (islots-struct-tag class)
+ (sod-class-nickname class))))))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable structure.
+
+(defmethod hook-output progn ((vtable vtable) reason sequencer)
+ (with-slots (body) vtable
+ (dolist (item body) (hook-output item reason sequencer))))
+
+(defmethod hook-output progn ((method sod-method) (reason (eql :h))
+ sequencer)
+ (with-slots (class) method
+ (sequence-output (stream sequencer)
+ ((class :methods)
+ (let ((type (sod-method-function-type method)))
+ (princ "extern " stream)
+ (pprint-c-type (commentify-function-type type) stream
+ (sod-method-function-name method))
+ (format stream ";~%"))))))
+
+(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head chain-tail) vtable
+ (when (eq class chain-tail)
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtables :start)
+ (class :vtable chain-head :start)
+ (class :vtable chain-head :slots)
+ (class :vtable chain-head :end)
+ (class :vtables :end))
+ ((class :vtable chain-head :start)
+ (format stream "/* Vtable structure. */~@
+ struct ~A {~%"
+ (vtable-struct-tag chain-tail chain-head)))
+ ((class :vtable chain-head :end)
+ (format stream "};~2%"))))
+ (sequence-output (stream sequencer)
+ ((class :vtable-externs)
+ (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
+ (vtable-struct-tag chain-tail chain-head)
+ class (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
+ sequencer)
+ (with-slots (class subclass chain-head chain-tail) vtmsgs
+ (sequence-output (stream sequencer)
+ ((subclass :vtable chain-head :slots)
+ (format stream " struct ~A ~A;~%"
+ (vtmsgs-struct-tag subclass class)
+ (sod-class-nickname class))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
+ sequencer)
+ (when (vtmsgs-entries vtmsgs)
+ (with-slots (class subclass) vtmsgs
+ (sequence-output (stream sequencer)
+ :constraint ((subclass :vtmsgs :start)
+ (subclass :vtmsgs class :start)
+ (subclass :vtmsgs class :slots)
+ (subclass :vtmsgs class :end)
+ (subclass :vtmsgs :end))
+ ((subclass :vtmsgs class :start)
+ (format stream "/* Messages protocol from class ~A */~@
+ struct ~A {~%"
+ class
+ (vtmsgs-struct-tag subclass class)))
+ ((subclass :vtmsgs class :end)
+ (format stream "};~2%"))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
+ (with-slots (entries) vtmsgs
+ (dolist (entry entries) (hook-output entry reason sequencer))))
+
+(defmethod hook-output progn ((entry method-entry) reason sequencer)
+ (with-slots (method) entry
+ (hook-output method reason sequencer)))
+
+(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
+ sequencer)
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (class (effective-method-class method))
+ (type (method-entry-function-type entry))
+ (commented-type (commentify-function-type type)))
+ (sequence-output (stream sequencer)
+ ((class :vtmsgs (sod-message-class message) :slots)
+ (pprint-logical-block (stream nil :prefix " " :suffix ";")
+ (pprint-c-type commented-type stream (sod-message-name message)))
+ (terpri stream)))))
+
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head metaclass meta-chain-head) cptr
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
+ metaclass
+ (if (sod-class-direct-superclasses meta-chain-head)
+ (sod-class-nickname meta-chain-head)
+ nil))))))
+
+(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head) boff
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (write-line " size_t _base;" stream)))))
+
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
+ sequencer)
+ (with-slots (class chain-head target-head) choff
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :slots)
+ (format stream " ptrdiff_t _off_~A;~%"
+ (sod-class-nickname target-head))))))
+
+;;;--------------------------------------------------------------------------
+;;; Implementation output.
+
+(defvar *instance-class*)
+
+(defmethod hook-output progn ((class sod-class) (reason (eql :c))
+ sequencer)
+ (sequence-output (stream sequencer)
+
+ :constraint
+ ((:classes :start)
+ (class :banner)
+ (class :direct-methods :start) (class :direct-methods :end)
+ (class :effective-methods)
+ (class :vtables :start) (class :vtables :end)
+ (class :object :prepare) (class :object :start) (class :object :end)
+ (:classes :end))
+
+ ((class :banner)
+ (banner (format nil "Class ~A" class) stream))
+
+ ((class :object :start)
+ (format stream "~
+/* The class object. */
+const struct ~A ~A__classobj = {~%"
+ (ilayout-struct-tag (sod-class-metaclass class))
+ class))
+ ((class :object :end)
+ (format stream "};~2%")))
+
+ (let ((*instance-class* class))
+ (hook-output (sod-class-ilayout (sod-class-metaclass class))
+ 'class
+ sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Direct methods.
+
+(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
+ sequencer)
+ (with-slots (class body) method
+ (unless body
+ (return-from hook-output))
+ (sequence-output (stream sequencer)
+ ((class :direct-method method :start)
+ (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
+ (mapcar #'argument-name
+ (c-function-arguments (sod-method-next-method-type
+ method)))))
+ ((class :direct-method method :end)
+ (format stream "#undef CALL_NEXT_METHOD~%")))))
+
+(defmethod hook-output progn ((method sod-method) (reason (eql :c))
+ sequencer)
+ (with-slots (class body) method
+ (unless body
+ (return-from hook-output))
+ (sequence-output (stream sequencer)
+ :constraint ((class :direct-methods :start)
+ (class :direct-method method :start)
+ (class :direct-method method :body)
+ (class :direct-method method :end)
+ (class :direct-methods :end))
+ ((class :direct-method method :body)
+ (pprint-c-type (sod-method-function-type method)
+ stream
+ (sod-method-function-name method))
+ (format stream "~&{~%")
+ (write body :stream stream :pretty nil :escape nil)
+ (format stream "~&}~%"))
+ ((class :direct-method method :end)
+ (terpri stream)))))
+
+(defmethod hook-output progn ((method basic-effective-method) (reason (eql :c))
+ sequencer)
+ (with-slots (class functions) method
+ (sequence-output (stream sequencer)
+ ((class :effective-methods)
+ (dolist (func functions)
+ (write func :stream stream :escape nil :circle nil))))))
+
+;;;--------------------------------------------------------------------------
+;;; Vtables.
+
+(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
+ sequencer)
+ (with-slots (class chain-head chain-tail) vtable
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtables :start)
+ (class :vtable chain-head :start)
+ (class :vtable chain-head :end)
+ (class :vtables :end))
+ ((class :vtable chain-head :start)
+ (format stream "/* Vtable for ~A chain. */~@
+ static const struct ~A ~A = {~%"
+ chain-head
+ (vtable-struct-tag chain-tail chain-head)
+ (vtable-name chain-tail chain-head)))
+ ((class :vtable chain-head :end)
+ (format stream "};~2%")))))
+
+(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
+ sequencer)
+ (with-slots (class chain-head metaclass meta-chain-head) cptr
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtable chain-head :start)
+ (class :vtable chain-head :class-pointer metaclass)
+ (class :vtable chain-head :end))
+ ((class :vtable chain-head :class-pointer metaclass)
+ (format stream " &~A__classobj.~A.~A,~%"
+ (sod-class-metaclass class)
+ (sod-class-nickname meta-chain-head)
+ (sod-class-nickname metaclass))))))
+
+(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
+ sequencer)
+ (with-slots (class chain-head) boff
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtable chain-head :start)
+ (class :vtable chain-head :base-offset)
+ (class :vtable chain-head :end))
+ ((class :vtable chain-head :base-offset)
+ (format stream " offsetof(struct ~A, ~A),~%"
+ (ilayout-struct-tag class)
+ (sod-class-nickname chain-head))))))
+
+(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
+ sequencer)
+ (with-slots (class chain-head target-head) choff
+ (sequence-output (stream sequencer)
+ :constraint ((class :vtable chain-head :start)
+ (class :vtable chain-head :chain-offset target-head)
+ (class :vtable chain-head :end))
+ ((class :vtable chain-head :chain-offset target-head)
+ (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
+ (ilayout-struct-tag class)
+ (sod-class-nickname chain-head)
+ (sod-class-nickname target-head))))))
+
+(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
+ sequencer)
+ (with-slots (class subclass chain-head) vtmsgs
+ (sequence-output (stream sequencer)
+ :constraint ((subclass :vtable chain-head :start)
+ (subclass :vtable chain-head :vtmsgs class :start)
+ (subclass :vtable chain-head :vtmsgs class :slots)
+ (subclass :vtable chain-head :vtmsgs class :end)
+ (subclass :vtable chain-head :end))
+ ((subclass :vtable chain-head :vtmsgs class :start)
+ (format stream " { /* Method entries for ~A messages. */~%"
+ class))
+ ((subclass :vtable chain-head :vtmsgs class :end)
+ (format stream " },~%")))))
+
+(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
+ sequencer)
+ (with-slots (method chain-head chain-tail) entry
+ (let* ((message (effective-method-message method))
+ (class (effective-method-class method))
+ (super (sod-message-class message)))
+ (sequence-output (stream sequencer)
+ ((class :vtable chain-head :vtmsgs super :slots)
+ (format stream " ~A,~%"
+ (method-entry-function-name method chain-head)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Filling in the class object.
+
+(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
+ sequencer)
+ (with-slots (class chain-head) ichain
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object :start)
+ (*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object chain-head :ichain :end)
+ (*instance-class* :object :end))
+ ((*instance-class* :object chain-head :ichain :start)
+ (format stream " { { /* ~A ichain */~%"
+ (sod-class-nickname chain-head)))
+ ((*instance-class* :object chain-head :ichain :end)
+ (format stream " } },~%")))))
+
+(defmethod hook-output progn ((islots islots) (reason (eql 'class))
+ sequencer)
+ (with-slots (class) islots
+ (let ((chain-head (sod-class-chain-head class)))
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object class :slots :start)
+ (*instance-class* :object class :slots)
+ (*instance-class* :object class :slots :end)
+ (*instance-class* :object chain-head :ichain :end))
+ ((*instance-class* :object class :slots :start)
+ (format stream " { /* Class ~A */~%" class))
+ ((*instance-class* :object class :slots :end)
+ (format stream " },~%"))))))
+
+(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
+ sequencer)
+ (with-slots (class chain-head chain-tail) vtptr
+ (sequence-output (stream sequencer)
+ :constraint ((*instance-class* :object chain-head :ichain :start)
+ (*instance-class* :object chain-head :vtable)
+ (*instance-class* :object chain-head :ichain :end))
+ ((*instance-class* :object chain-head :vtable)
+ (format stream " &~A__vtable_~A,~%"
+ class (sod-class-nickname chain-head))))))
+
+(defgeneric find-class-initializer (slot class)
+ (:method ((slot effective-slot) (class sod-class))
+ (let ((dslot (effective-slot-direct-slot slot)))
+ (or (some (lambda (super)
+ (find dslot (sod-class-class-initializers super)
+ :test #'sod-initializer-slot))
+ (sod-class-precedence-list class))
+ (effective-slot-initializer slot)))))
+
+(defgeneric output-class-initializer (slot instance stream)
+ (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
+ (let ((func (effective-slot-initializer-function slot)))
+ (if func
+ (format stream " ~A,~%" (funcall func instance))
+ (call-next-method))))
+ (:method ((slot effective-slot) (instance sod-class) stream)
+ (let ((init (find-class-initializer slot instance)))
+ (ecase (sod-initializer-value-kind init)
+ (:simple (format stream " ~A,~%"
+ (sod-initializer-value-form init)))
+ (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
+ (sod-initializer-value-form init)))))))
+
+(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
+ sequencer)
+ (let ((instance *instance-class*)
+ (func (effective-slot-prepare-function slot)))
+ (when func
+ (sequence-output (stream sequencer)
+ ((instance :object :prepare)
+ (funcall func instance stream))))))
+
+(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
+ sequencer)
+ (with-slots (class (dslot slot)) slot
+ (let ((instance *instance-class*)
+ (super (sod-slot-class dslot)))
+ (sequence-output (stream sequencer)
+ ((instance :object super :slots)
+ (output-class-initializer slot instance stream))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Package definition for SOD utility
+;;;
+;;; (c) 2009 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:defpackage #:sod
+ (:use #:common-lisp
+ #:sod-utilities
+ #:sod-parser))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parser for C types
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Declaration specifiers.
+
+(defclass declspec ()
+ ((label :type keyword :initarg :label :reader ds-label)
+ (name :type string :initarg :name :reader ds-name)
+ (kind :type (member type sign size qualifier tagged)
+ :initarg :kind :reader ds-kind)))
+
+(defmethod shared-initialize :after ((ds declspec) slot-names &key)
+ (default-slot (ds 'name slot-names)
+ (string-downcase (ds-label ds))))
+
+(defclass declspecs ()
+ ((type :initform nil :initarg :type :reader ds-type)
+ (sign :initform nil :initarg :sign :reader ds-sign)
+ (size :initform nil :initarg :size :reader ds-size)
+ (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers)))
+
+(defparameter *declspec-map*
+ (let ((map (make-hash-table :test #'equal)))
+ (dolist (item '((type :void :char :int :float :double)
+ (size :short :long (:long-long "long long"))
+ (sign :signed :unsigned)
+ (qualifier :const :restrict :volatile)
+ (tagged :enum :struct :union)))
+ (let ((kind (car item)))
+ (dolist (spec (cdr item))
+ (multiple-value-bind (label name)
+ (if (consp spec)
+ (values (car spec) (cadr spec))
+ (values spec (string-downcase spec)))
+ (let ((ds (make-instance 'declspec
+ :label label :name name :kind kind)))
+ (setf (gethash name map) ds
+ (gethash label map) ds))))))
+ map))
+
+(defmethod ds-label ((ty c-type)) :c-type)
+(defmethod ds-name ((ty c-type)) (princ-to-string ty))
+(defmethod ds-kind ((ty c-type)) 'type)
+
+(defparameter *good-declspecs*
+ '(((:int) (:signed :unsigned) (:short :long :long-long))
+ ((:char) (:signed :unsigned) ())
+ ((:double) () (:long))
+ (t () ()))
+ "List of good collections of declaration specifiers.
+
+ Each item is a list of the form (TYPES SIGNS SIZES). Each of TYPES, SIGNS
+ and SIZES is either a list of acceptable specifiers of the appropriate
+ kind, or T, which matches any specifier.")
+
+(defun scan-declspec (scanner)
+ "Scan a DECLSPEC from SCANNER.
+
+ Value on success is either a DECLSPEC object or a C-TYPE object."
+
+ ;; Turns out to be easier to do this by hand.
+ (let ((ds (and (eq (token-type scanner) :id)
+ (let ((kw (token-value scanner)))
+ (or (gethash kw *declspec-map*)
+ (gethash kw *module-type-map*))))))
+ (cond ((not ds)
+ (values (list :declspec) nil nil))
+ ((eq (ds-kind ds) :tagged)
+ (scanner-step scanner)
+ (if (eq (token-type scanner) :id)
+ (let ((ty (make-c-tagged-type (ds-label ds)
+ (token-value scanner))))
+ (scanner-step scanner)
+ (values ty t t))
+ (values :tag nil t)))
+ (t
+ (scanner-step scanner)
+ (values ds t t)))))
+
+(defun good-declspecs-p (specs)
+ "Are SPECS a good collection of declaration specifiers?"
+ (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs))))
+ (some (lambda (it)
+ (every (lambda (spec pat)
+ (or (eq pat t) (null spec)
+ (member (ds-label spec) pat)))
+ speclist it))
+ *good-declspecs*)))
+
+(defun combine-declspec (specs ds)
+ "Combine the declspec DS with the existing SPECS.
+
+ Returns new DECLSPECS if they're OK, or `nil' if not. The old SPECS are
+ not modified."
+ (let* ((kind (ds-kind ds))
+ (old (slot-value specs kind)))
+ (multiple-value-bind (ok new)
+ (case kind
+ (qualifier (values t (adjoin ds old)))
+ (size (cond ((not old) (values t ds))
+ ((and (eq (ds-label old) :long) (eq ds old))
+ (values t (gethash :long-long *declspec-map*)))
+ (t (values nil nil))))
+ (t (values (not old) ds)))
+ (if ok
+ (let ((copy (copy-instance specs)))
+ (setf (slot-value copy kind) new)
+ (and (good-declspecs-p copy) copy))
+ nil))))
+
+(defun scan-and-merge-declspec (scanner specs)
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (if-parse (:consumedp consumedp) (scan-declspec scanner)
+ (aif (combine-declspec specs it)
+ (values it t consumedp)
+ (values (list :declspec) nil consumedp)))))
+
+(defun declspecs-type (specs)
+ (let ((type (ds-type specs))
+ (size (ds-size specs))
+ (sign (ds-sign specs)))
+ (cond ((or type size sign)
+ (when (and (eq (ds-label sign) :signed)
+ (eq (ds-label type) :int))
+ (setf sign nil))
+ (cond ((and (or (null type) (eq (ds-label type) :int))
+ (or size sign))
+ (setf type nil))
+ ((null type)
+ (setf type (gethash :int *declspec-map*))))
+ (make-simple-type (format nil "~{~@[~A~^ ~]~}"
+ (mapcar #'ds-label
+ (remove nil
+ (list sign size type))))
+ (mapcar #'ds-label (ds-qualifiers specs))))
+ (t
+ nil))))
+
+(defun parse-c-type (scanner)
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (if-parse (:result specs :consumedp cp)
+ (many (specs (make-instance 'declspecs) it :min 1)
+ (scan-and-merge-declspec scanner specs))
+ (let ((type (declspecs-type specs)))
+ (if type (values type t cp)
+ (values (list :declspec) nil cp))))))
+
+
+
+
+
+
+
+
+
+
+
+ ;; This is rather complicated, but extracting all the guts into a structure
+ ;; and passing it around makes matters worse rather than better.
+ ;;
+ ;; We categorize declaration specifiers into four kinds.
+ ;;
+ ;; * `Type specifiers' describe the actual type, whether that's integer,
+ ;; character, floating point, or some tagged or user-named type.
+ ;;
+ ;; * `Size specifiers' distinguish different sizes of the same basic
+ ;; type. This is how we tell the difference between `int' and `long'.
+ ;;
+ ;; * `Sign specifiers' distinguish different signednesses. This is how
+ ;; we tell the difference between `int' and `unsigned'.
+ ;;
+ ;; * `Qualifiers' are our old friends `const', `restrict' and `volatile'.
+ ;;
+ ;; These groupings are for our benefit here, in determining whether a
+ ;; particular declaration specifier is valid in the current context. We
+ ;; don't accept `function specifiers' (of which the only current example is
+ ;; `inline') since it's meaningless to us.
+ ;;
+ ;; Our basic strategy is to parse declaration specifiers while they're
+ ;; valid, and keep track of what we've read. When we've reached the end,
+ ;; we'll convert what we've got into a `canonical form', and then convert
+ ;; that into a C type object of the appropriate kind.
+
+ (let ((specs (make-instance 'declspecs)))
+
+
+ (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
+ (labels ((goodp (ty sg sz)
+ "Are (TY SG SZ) a good set of declaration specifiers?"
+ (some (lambda (it)
+ (every (lambda (spec pat)
+ (or (eq pat t) (eq spec nil)
+ (member spec pat)))
+ decls it))
+ *good-declspecs*))
+
+ (scan-declspec ()
+ "Scan a declaration specifier."
+ (flet ((win (value &optional (consumedp t))
+ (when consumedp (scanner-step scanner))
+ (return-from scan-declspec
+ (values value t consumedp)))
+ (lose (wanted &optional (consumedp nil))
+ (values wanted nil consumedp)))
+ (unless (eq (token-type scanner) :id) (lose :declspec))
+ (let* ((id (token-value scanner))
+ (ds (or (gethash id *declspec-map*)
+ (gethash id *module-type-map*))))
+ (unless ds (lose :declspec))
+ (let ((label (ds-label ds)))
+ (ecase (ds-kind ds)
+ (:qualifier
+ (push (ds-label ds) quals)
+ (win ds))
+ (:size
+ (cond ((and (not size) (goodp type label sign))
+ (setf size label)
+ (win ds))
+ (t
+ (lose :declspec))))
+ (:sign
+ (cond ((and (not sign) (goodp type size label))
+ (setf sign label)
+ (win ds))
+ (t
+ (lose :declspec))))
+ (:type
+ (when (and (eq type :long) (eq label :long))
+ (setf label :long-long))
+ (cond ((and (or (not type) (eq type :long))
+ (goodp label size sign))
+ (setf type label)
+ (win ds))
+ (t
+ (lose :declspec))))
+ (:tagged
+ (unless (and (not type) (goodp label size sign))
+ (lose :declspec))
+ (scanner-step scan)
+ (unless (eq (token-type scanner) :id)
+ (lose :tagged t))
+ (setf type
+ (make-c-tagged-type label
+ (token-value scanner)))
+ (win type))))))))
+
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (many (nil nil nil :min 1)
+ (scan-declspec))
+
+
+
+
+ (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil))
+ (labels ((check (ty sz sg)
+ (case ty
+ ((nil :int) t)
+ (:char (null sz))
+ (:double (and (null sg) (or (null sz) (eq sz :long))))
+ (t (and (null sg) (null sz)))))
+ (set-type (ty)
+ (when ))
+ (set-size (sz)
+ (when (and (eq sz :long) (eq size :long))
+ (setf sz :long-long))
+ (when (and (or (null size) (eq sz :long-long))
+ (check type sz sign))
+ (setf size sz)))
+ (set-sign (sg)
+ (when (and (null sign) (check type size sg))
+ (setf sign sg)))
+ (parse-declspec ()
+ (multiple-value-bind (kind value)
+ (categorize-declspec scanner)
+ (if (ecase kind
+ (:qualifier (push value quals))
+ (:type (and (null type) (check value size sign)
+ (setf type value)))
+ (:size (let ((sz (if (and (eq size :long)
+ (eq value :long))
+ :long-long value)))
+ (and (or (null size) (eq sz :long-long))
+ (check type value sign)
+ (setf size value))))
+ (:sign (and (null sign) (check type size value)
+ (setf sign value)))
+
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Lexical analysis for input parser
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Class definition.
+
+(export 'sod-token-scanner)
+(defclass sod-token-scanner (token-scanner)
+ ((char-scanner :initarg :char-scanner :reader token-scanner-char-scanner))
+ (:documentation
+ "A token scanner for SOD input files.
+
+ Not a lot here, apart from a character scanner to read from and the
+ standard token scanner infrastructure."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun show-char (stream char &optional colonp atsignp)
+ "Format CHAR to STREAM in a readable way.
+
+ Usable in `format''s ~/.../ command."
+ (declare (ignore colonp atsignp))
+ (cond ((null char) (write-string "<eof>" stream))
+ ((and (graphic-char-p char) (char/= char #\space))
+ (format stream "`~C'" char))
+ (t (format stream "<~(~:C~)>" char))))
+
+(defun scan-comment (scanner)
+ "Scan a comment (either `/* ... */' or `// ...') from SCANNER.
+
+ The result isn't interesting."
+ (with-parser-context (character-scanner-context :scanner scanner)
+ (parse (or (and "/*"
+ (and (skip-many ()
+ (and (skip-many () (not #\*))
+ (label "*/" (skip-many (:min 1) #\*)))
+ (not #\/))
+ #\/))
+ (and "//"
+ (skip-many () (not #\newline))
+ (? #\newline))))))
+
+;;;--------------------------------------------------------------------------
+;;; Error reporting.
+
+(export 'syntax-error)
+(defun syntax-error (scanner expected &key (continuep t))
+ "Signal a (maybe) continuable syntax error."
+ (labels ((show-token (type value)
+ (if (characterp type)
+ (format nil "~/sod::show-char/" type)
+ (case type
+ (:id (format nil "<identifier~@[ `~A'~]>" value))
+ (:string "<string-literal>")
+ (:char "<character-literal>")
+ (:eof "<end-of-file>")
+ (:ellipsis "`...'")
+ (t (format nil "<? ~S~@[ ~S~]>" type value)))))
+ (show-expected (thing)
+ (cond ((atom thing) (show-token thing nil))
+ ((eq (car thing) :id)
+ (format nil "`~A'" (cadr thing)))
+ (t (format nil "<? ~S>" thing)))))
+ (funcall (if continuep #'cerror* #'error)
+ "Syntax error: ~
+ expected ~{#[<bug>~;~A~;~A or ~A~:;~A, ~]~} ~
+ but found ~A"
+ (mapcar #'show-expected expected)
+ (show-token (token-type scanner) (token-value scanner)))))
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner protocol implementation.
+
+(defmethod scanner-token ((scanner sod-token-scanner))
+ (with-slots (char-scanner line column) scanner
+ (with-parser-context (character-scanner-context :scanner char-scanner)
+
+ (flet ((scan-digits (&key (radix 10) (min 1) (init 0))
+ ;; Scan an return a sequence of digits.
+ (parse (many (acc init (+ (* acc radix) it) :min min)
+ (label (list :digit radix)
+ (filter (lambda (ch)
+ (digit-char-p ch radix)))))))
+
+ (lexer-error (expected consumedp)
+ ;; Report a lexical error.
+ (cerror* "Lexical error: ~
+ expected ~{~#[<bug>~;~A~;~A or ~A~;:~A, ~]~} ~
+ but found ~/sod::show-char/~
+ ~@[ at ~A~]"
+ (mapcar (lambda (exp)
+ (typecase exp
+ (character
+ (format nil "~/sod::show-char/" exp))
+ (string (format nil "`~A'" exp))
+ ((cons (eql :digit) *)
+ (format nil "<radix-~A digit>"
+ (cadr exp)))
+ ((eql :eof) "<end-of-file>")
+ ((eql :any) "<character>")
+ (t (format nil "<? ~S>" exp))))
+ expected)
+ (and (not (scanner-at-eof-p char-scanner))
+ (scanner-current-char char-scanner))
+ (and consumedp (file-location char-scanner)))))
+
+ ;; Skip initial junk, and remember the place.
+ (loop
+ (setf (scanner-line scanner) (scanner-line char-scanner)
+ (scanner-column scanner) (scanner-column char-scanner))
+ (cond-parse (:consumedp cp :expected exp)
+ ((satisfies whitespace-char-p) (parse :whitespace))
+ ((scan-comment char-scanner))
+ (t (if cp (lexer-error exp cp) (return)))))
+
+ ;; Now parse something.
+ (cond-parse (:consumedp cp :expected exp)
+
+ ;; Alphanumerics mean we read an identifier.
+ ((or #\_ (satisfies alpha-char-p))
+ (values :id (with-output-to-string (out)
+ (write-char it out)
+ (parse (many (nil nil (write-char it out))
+ (or #\_ (satisfies alphanumericp)))))))
+
+ ;; Quotes introduce a literal.
+ ((seq ((quote (or #\" #\'))
+ (contents (many (out (make-string-output-stream)
+ (progn (write-char it out) out)
+ :final (get-output-stream-string out))
+ (or (and #\\ :any) (not quote))))
+ (nil (char quote)))
+ (ecase quote
+ (#\" contents)
+ (#\' (case (length contents)
+ (1 (char contents 0))
+ (0 (cerror* "Empty character literal") #\?)
+ (t (cerror* "Too many characters in literal")
+ (char contents 0))))))
+ (values (etypecase it
+ (character :char)
+ (string :string))
+ it))
+
+ ;; Zero introduces a chosen-radix integer.
+ ((and #\0
+ (or (and (or #\b #\B) (scan-digits :radix 2))
+ (and (or #\o #\O) (scan-digits :radix 8))
+ (and (or #\x #\X) (scan-digits :radix 16))
+ (scan-digits :radix 8 :min 0)))
+ (values :int it))
+
+ ;; Any other digit forces radix-10.
+ ((seq ((d (filter digit-char-p))
+ (i (scan-digits :radix 10 :min 0 :init d)))
+ i)
+ (values :int it))
+
+ ;; Some special punctuation sequences are single tokens.
+ ("..." (values :ellipsis nil))
+
+ ;; Any other character is punctuation.
+ (:any (values it nil))
+
+ ;; End of file means precisely that.
+ (:eof (values :eof nil))
+
+ ;; Report errors and try again. Because we must have consumed some
+ ;; input in order to get here (we've matched both :any and :eof) we
+ ;; must make progress on every call.
+ (t (assert cp) (lexer-error exp cp) (scanner-token scanner)))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Implementation of file-location protocol
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; File location objects.
+
+(let ((null-file-location (make-file-location nil nil nil)))
+ (defmethod file-location ((thing t)) null-file-location))
+
+(defmethod file-location ((stream stream))
+ (make-file-location (stream-pathname stream) nil nil))
+
+(defmethod print-object ((object file-location) stream)
+ (maybe-print-unreadable-object (object stream :type t)
+ (format stream "~:[<unknown>~;~:*~A~]~@[:~D~]~@[:~D~]"
+ (file-location-filename object)
+ (file-location-line object)
+ (file-location-column object))))
+
+(defmethod make-load-form ((object file-location) &optional environment)
+ (make-load-form-saving-slots object :environment environment))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parsers for expressions with binary operators
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol implementation.
+
+(defclass expression-parse-state ()
+ ((opstack :initform nil :type list)
+ (valstack :initform nil :type list)
+ (nesting :initform 0 :type fixnum))
+ (:documentation
+ "State for the expression parser. Largely passive."))
+
+(defmethod push-value (value (state expression-parse-state))
+ (with-slots (valstack) state
+ (push value valstack)))
+
+(defmethod push-operator (operator (state expression-parse-state))
+ (with-slots (opstack) state
+ (loop
+ (when (null opstack) (return))
+ (let ((head (car opstack)))
+ (ecase (operator-push-action head operator)
+ (:push (return))
+ (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~
+ operators aren't associative"
+ head operator))
+ (:apply (apply-operator head state)
+ (setf opstack (cdr opstack))))))
+ (push operator opstack)))
+
+(defgeneric apply-pending-operators (state)
+ (:documentation
+ "Apply all of the pending operators to their arguments.
+
+ The return value is the final result of the parse. By the time all of the
+ operators have been applied, of course, there ought to be exactly one
+ operand remaining.")
+ (:method ((state expression-parse-state))
+ (with-slots (opstack valstack) state
+ (dolist (operator opstack)
+ (apply-operator operator state))
+ (assert (and (consp valstack) (null (cdr valstack))))
+ (pop valstack))))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator implementation.
+
+(defmethod operator-push-action (left right)
+ (let ((lprec (operator-right-precedence left))
+ (rprec (operator-left-precedence right)))
+ (cond ((< lprec rprec) :push)
+ ((> lprec rprec) :apply)
+ (t (let ((lassoc (operator-associativity left))
+ (rassoc (operator-associativity right)))
+ (cond ((not (eq lassoc rassoc))
+ (cerror* "Parse error: ... ~A ... ~A ...: ~
+ inconsistent associativity: ~
+ ~(~A~) versus ~(~A~))"
+ left right
+ (or lassoc "none") (or rassoc "none"))
+ :apply)
+ ((not lassoc)
+ (cerror* "Parse error: ... ~A ... ~A ...: ~
+ operators are not associative"
+ left right)
+ :apply)
+ ((eq lassoc :left) :apply)
+ ((eq lassoc :right) :push)
+ (t (error "Invalid associativity ~S ~
+ for operators ~A and ~A"
+ lassoc left right))))))))
+
+(defmethod print-object ((operator simple-operator) stream)
+ (maybe-print-unreadable-object (operator stream :type t)
+ (princ (operator-name operator) stream)))
+
+(defmethod shared-initialize :after
+ ((operator simple-binary-operator) slot-names &key)
+ (when (slot-boundp operator 'lprec)
+ (default-slot (operator 'rprec slot-names)
+ (slot-value operator 'lprec))))
+
+(defmethod shared-initialize :after
+ ((operator simple-binary-operator) slot-names &key)
+ (when (slot-boundp operator 'lprec)
+ (default-slot (operator 'rprec slot-names)
+ (slot-value operator 'lprec))))
+
+(defmethod push-operator
+ ((operator prefix-operator) (state expression-parse-state))
+
+ ;; It's not safe to apply stacked operators here. Already-stacked prefix
+ ;; operators won't have their operands yet, so we'll end up in an
+ ;; inconsistent state.
+ (with-slots (opstack) state
+ (push operator opstack)))
+
+(defmethod apply-operator
+ ((operator simple-unary-operator) (state expression-parse-state))
+ (with-slots (function) operator
+ (with-slots (valstack) state
+ (assert (not (null valstack)))
+ (push (funcall function (pop valstack)) valstack))))
+
+(defmethod apply-operator
+ ((operator simple-binary-operator) (state expression-parse-state))
+ (with-slots (function) operator
+ (with-slots (valstack) state
+ (assert (not (or (null valstack)
+ (null (cdr valstack)))))
+ (let ((second (pop valstack))
+ (first (pop valstack)))
+ (push (funcall function first second) valstack)))))
+
+;;;--------------------------------------------------------------------------
+;;; Parenthesis protocol implementation.
+
+(defmethod push-operator :after
+ ((paren open-parenthesis) (state expression-parse-state))
+ (with-slots (nesting) state
+ (incf nesting)))
+
+(defmethod push-operator
+ ((paren close-parenthesis) (state expression-parse-state))
+ (with-slots (opstack nesting) state
+ (with-slots (tag) paren
+ (flet ((fail ()
+ (cerror* "Parse error: spurious `~A'" tag)
+ (return-from push-operator)))
+ (loop
+ (when (null opstack) (fail))
+ (let ((head (car opstack)))
+ (cond ((not (typep head 'open-parenthesis))
+ (apply-operator head state))
+ ((not (eq (slot-value head 'tag) tag))
+ (fail))
+ (t
+ (return)))
+ (setf opstack (cdr opstack))))
+ (setf opstack (cdr opstack))
+ (decf nesting)))))
+
+(defmethod apply-operator
+ ((paren open-parenthesis) (state expression-parse-state))
+ (with-slots (tag) paren
+ (cerror* "Parse error: missing `~A'" tag)))
+
+(defmethod operator-push-action (left (right open-parenthesis))
+ :push)
+
+(defmethod operator-push-action ((left open-parenthesis) right)
+ :push)
+
+;;;--------------------------------------------------------------------------
+;;; Main expression parser implementation.
+
+(defun parse-expression (p-operand p-binop p-preop p-postop)
+ (let ((state (make-instance 'expression-parse-state))
+ (consumed-any-p nil))
+
+ (labels ((fail (expected)
+ (return-from parse-expression
+ (values expected nil consumed-any-p)))
+
+ (parse (parser)
+ (unless parser
+ (return-from parse (values nil nil)))
+ (multiple-value-bind (value winp consumedp)
+ (funcall parser (plusp (slot-value state 'nesting)))
+ (when consumedp (setf consumed-any-p t))
+ (unless (or winp (not consumedp)) (fail value))
+ (values value winp)))
+
+ (get-operand ()
+ (loop (multiple-value-bind (value winp) (parse p-preop)
+ (unless winp (return))
+ (push-operator value state)))
+ (multiple-value-bind (value winp) (parse p-operand)
+ (unless winp (fail value))
+ (push-value value state))
+ (loop (multiple-value-bind (value winp) (parse p-postop)
+ (unless winp (return))
+ (push-operator value state)))))
+
+ (get-operand)
+ (loop
+ (multiple-value-bind (value winp) (parse p-binop)
+ (unless winp (return))
+ (push-operator value state))
+ (get-operand))
+
+ (values (apply-pending-operators state) t consumed-any-p))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Pluggable extensable parser
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;;
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parser protocol implementation.
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Hairy functions used by parser syntax expanders.
+
+(declaim (inline %many))
+(defun %many (update final parser &key (min 0) max)
+ "Helper function for the `many' parser syntax.
+
+ This deals with simple repetition, without separators. See the parser
+ syntax documentation for details."
+
+ (let ((consumed-any-p nil))
+ (do ((i 0 (1+ i)))
+ ((and max (>= i max)))
+ (multiple-value-bind (value winp consumep) (funcall parser)
+ (when consumep (setf consumed-any-p t))
+ (cond (winp (funcall update value))
+ ((or consumep (< i min))
+ (return-from %many (values value nil consumed-any-p)))
+ (t (return)))))
+ (values (funcall final) t consumed-any-p)))
+
+(defun %many-sep (update final parser sep &key (min 1) max (commitp t))
+ "Helper function for the `many' parser syntax.
+
+ This deals with the hairy separator and commit stuff. See the parser
+ syntax documentation for details."
+
+ (let ((consumed-any-p nil)
+ (i 0))
+ (block nil
+ (flet ((sep ()
+ (multiple-value-bind (value winp consumep) (funcall sep)
+ (when consumep (setf consumed-any-p t))
+ (unless winp
+ (if (and (>= i min) (not consumep)) (return)
+ (return-from %many-sep
+ (values value nil consumed-any-p))))))
+
+ (main (mustp)
+ (multiple-value-bind (value winp consumep) (funcall parser)
+ (when consumep (setf consumed-any-p t))
+ (cond (winp (funcall update value))
+ ((or mustp consumep (< i min))
+ (return-from %many-sep
+ (values value nil consumed-any-p)))
+ (t (return))))
+ (incf i)))
+
+ (when (eql max 0) (return))
+
+ (main nil)
+
+ (if commitp
+ (loop (when (and max (>= i max)) (return)) (sep) (main t))
+ (loop (sep) (when (and max (>= i max)) (return)) (main nil)))))
+
+ (values (funcall final) t consumed-any-p)))
+
+;;;--------------------------------------------------------------------------
+;;; Token parser implementation.
+
+(defmethod parser-at-eof-p ((context token-parser-context))
+ `(eq ,(parser-token-type context) :eof))
+
+;;;--------------------------------------------------------------------------
+;;; Simple list-based parser; useful for testing.
+
+(export 'list-parser)
+(defclass list-parser ()
+ ((var :initarg :var :type symbol :reader parser-var)))
+
+(defmethod parser-at-eof-p ((context list-parser))
+ `(not ,(parser-var context)))
+
+(defmethod parser-capture-place ((context list-parser))
+ `,(parser-var context))
+
+(defmethod parser-restore-place ((context list-parser) place)
+ `(setf ,(parser-var context) ,place))
+
+(defmethod expand-parser-spec ((context list-parser) parser)
+ (if (atom parser)
+ (expand-parser-form context 'quote (list parser))
+ (call-next-method)))
+
+(defparse quote (:context (context list-parser) object)
+ `(if (and ,(parser-var context)
+ (eql (car ,(parser-var context)) ',object))
+ (progn (pop ,(parser-var context)) (values ',object t t))
+ (values (list ',object) nil nil)))
+
+(defparse type (:context (context list-parser) type)
+ `(if (and ,(parser-var context)
+ (typep (car ,(parser-var context)) ',type))
+ (values (pop ,(parser-var context)) t t)
+ (values (list ',type) nil nil)))
+
+(defmethod parser-places-must-be-released-p ((context list-parser)) nil)
+
+;;;--------------------------------------------------------------------------
+;;; Simple string-based parser; useful for testing.
+
+(export 'string-parser)
+(defclass string-parser (character-parser-context)
+ ((string :initarg :string :reader parser-string)
+ (index :initarg :index :initform 0 :reader parser-index)
+ (length :initform (gensym "LEN-") :reader parser-length)))
+
+(defmethod wrap-parser ((context string-parser) form)
+ (with-slots (string index length) context
+ `(let* (,@(unless (symbolp string)
+ (let ((s string))
+ (setf string (gensym "STRING-"))
+ `((,string ,s))))
+ ,@(unless (symbolp index)
+ (let ((i index))
+ (setf index (gensym "INDEX-"))
+ `((,index ,i))))
+ (,length (length ,string)))
+ ,form)))
+
+(defmethod parser-at-eof-p ((context string-parser))
+ `(>= ,(parser-index context) ,(parser-length context)))
+
+(defmethod parser-current-char ((context string-parser))
+ `(char ,(parser-string context) ,(parser-index context)))
+
+(defmethod parser-step ((context string-parser))
+ `(incf ,(parser-index context)))
+
+(defmethod parser-capture-place ((context string-parser))
+ `,(parser-index context))
+
+(defmethod parser-restore-place ((context string-parser) place)
+ `(setf ,(parser-index context) ,place))
+
+(defmethod parser-places-must-be-released-p ((context string-parser)) nil)
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Efficient buffering character scanner
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Infrastructure types.
+
+(defconstant charbuf-size 4096
+ "Number of characters in a character buffer.")
+
+(deftype charbuf ()
+ "Type of character buffers."
+ `(simple-string ,charbuf-size))
+
+(deftype charbuf-index ()
+ "Type of indices into character buffers."
+ `(integer 0 ,charbuf-size))
+
+(declaim (inline make-charbuf))
+(defun make-charbuf ()
+ "Return a fresh uninitialized character buffer."
+ (make-array charbuf-size :element-type 'character))
+
+(defstruct charbuf-chain-link
+ "A link in the charbuf scanner's buffer chain.
+
+ Usually the scanner doesn't bother maintaining a buffer chain; but if
+ we've rewound to a captured place then we need to be able to retrace our
+ steps on to later buffers.
+
+ It turns out to be easier to have an explicit link to the next structure
+ in the chain than to maintain a spine of cons cells, so we do that; the
+ only other things we need are the buffer itself and its length, which
+ might be shorter than `charbuf-size', e.g., if we hit end-of-file."
+ (next nil :type (or charbuf-chain-link null))
+ (buf nil :type (or charbuf (member nil :eof)) :read-only t)
+ (size 0 :type charbuf-index :read-only t))
+
+(export 'charbuf-scanner-place-p)
+(defstruct charbuf-scanner-place
+ "A captured place we can return to later.
+
+ We remember the buffer-chain link, so that we can retrace our steps up to
+ the present. We also need the index at which we continue reading
+ characters; and the line and column numbers to resume from."
+ (link nil :type charbuf-chain-link :read-only t)
+ (index 0 :type charbuf-index :read-only t)
+ (line 0 :type fixnum :read-only t)
+ (column 0 :type fixnum :read-only t))
+
+;;;--------------------------------------------------------------------------
+;;; Main class.
+
+(export 'charbuf-scanner)
+(defclass charbuf-scanner (character-scanner)
+ ((stream :initarg :stream :type stream)
+ (buf :initform nil :type (or charbuf (member nil :eof)))
+ (size :initform 0 :type (integer 0 #.charbuf-size))
+ (index :initform 0 :type (integer 0 #.charbuf-size))
+ (captures :initform 0 :type (and fixnum unsigned-byte))
+ (tail :initform nil :type (or charbuf-chain-link null))
+ (unread :initform nil :type (or charbuf-chain-link nil))
+ (filename :initarg :filename :type (or string null)
+ :reader scanner-filename)
+ (line :initarg line :initform 1 :type fixnum :reader scanner-line)
+ (column :initarg :column :initform 0 :type fixnum :reader scanner-column))
+ (:documentation
+ "An efficient rewindable scanner for character streams.
+
+ The scanner should be used via the parser protocol. The following notes
+ describe the class's slots and the invariants maintained by the class.
+
+ The scanner reads characters from STREAM. It reads in chunks,
+ `charbuf-size' characters at a time, into freshly allocated arrays. At
+ the beginning of time, BUF is nil; and SIZE is 0, indicating that a new
+ buffer needs to be read in; this anomalous situation is remedied during
+ instance initialization. At all times thereafter:
+
+ * If SIZE > 0 then BUF is a `charbuf' containing characters.
+
+ * (<= 0 INDEX SIZE charbuf-size).
+
+ When the current buffer is finished with, another one is fetched. If
+ we've rewound the scanner to a captured place, then there'll be a chain of
+ buffers starting at TAIL (which corresponds to the current buffer); and we
+ should use its NEXT buffer when we've finished this one.
+
+ If there is no next buffer then we should acquire a new one and fill it
+ from the input stream. If there is an outstanding captured place then we
+ must also create a buffer chain entry for this new buffer and link it onto
+ the chain. If there aren't outstanding captures then we don't need to
+ bother with any of that -- earlier places certainly can't be captured and
+ a capture of the current position can allocate its own buffer chain
+ entry.
+
+ Which leaves us with the need to determine whether there are outstanding
+ captures. We simply maintain a counter, and rely on the client releasing
+ captured places properly when he's finished. In practice, this is usually
+ done using the `peek' parser macro so there isn't a problem."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defgeneric charbuf-scanner-fetch (scanner)
+ (:documentation
+ "Refill the scanner buffer.
+
+ This is an internal method, which is really only a method so that the
+ compiler will optimize slot references.
+
+ Replace the current buffer with the next one, either from the buffer chain
+ (if we're currently rewound) or with a new buffer from the stream."))
+
+(defmethod charbuf-scanner-fetch ((scanner charbuf-scanner))
+ (with-slots (stream buf size index tail captures) scanner
+ (loop
+ (acond
+
+ ;; If we've hit the end of the line, stop.
+ ((eq buf :eof)
+ (return nil))
+
+ ;; If there's another buffer, we should check it out.
+ ((and tail (charbuf-chain-link-next tail))
+ (setf tail it
+ buf (charbuf-chain-link-buf it)
+ size (charbuf-chain-link-size it)
+ index 0))
+
+ ;; No joy: try reading more stuff from the input stream.
+ (t
+ (let* ((new (make-charbuf))
+ (n (read-sequence new stream :start 0 :end charbuf-size)))
+
+ ;; If there's nothing coming in then store a magical marker.
+ (when (zerop n) (setf new :eof))
+
+ ;; If there's someone watching, link a new entry onto the chain.
+ ;; There must, under these circumstances, be a `tail'.
+ (if (plusp captures)
+ (let ((next (make-charbuf-chain-link :buf new :size n)))
+ (setf (charbuf-chain-link-next tail) next
+ tail next))
+ (setf tail nil))
+
+ ;; Store the new state.
+ (setf buf new
+ size n
+ index 0))))
+
+ ;; If there's stuff in the current buffer, we're done.
+ (when (< index size)
+ (return t)))))
+
+(export 'charbuf-scanner-map)
+(defgeneric charbuf-scanner-map (scanner func &optional fail)
+ (:documentation
+ "Read characters from the SCANNER's raw buffers.
+
+ This is intended to be an efficient and versatile interface for reading
+ characters from a scanner in bulk. The FUNC is invoked repeatedly with
+ three arguments: a simple string BUF and two nonnegative fixnums START and
+ END, indicating that the subsequence of BUF between START (inclusive) and
+ END (exclusive) should be processed. The FUNC returns two values: a
+ generalized boolean DONEP and a nonnegative fixnum USED. If DONEP is
+ false then USED is ignored: the function has consumed the entire buffer
+ and wishes to read more. If DONEP is true then the condition (<= START
+ USED END) must hold; the FUNC has consumed the buffer as far as USED
+ (exclusive) and has completed successfully; the values DONEP and `t' are
+ returned as the result of CHARBUF-SCANNER-MAP.
+
+ If end-of-file is encountered before FUNC completes successfully then FAIL
+ is called with no arguments, and CHARBUF-SCANNER-MAP returns whatever
+ FAIL returns.
+
+ Observe that, if FAIL returns a second value of nil, then
+ `charbuf-scanner-map' is usable as a parser expression."))
+
+(defmethod charbuf-scanner-map
+ ((scanner charbuf-scanner) func &optional fail)
+ (with-slots (buf index size) scanner
+ (flet ((offer (buf start end)
+
+ ;; Pass the buffer to the function, and see what it thought.
+ (multiple-value-bind (donep used) (funcall func buf start end)
+
+ ;; Update the position as far as the function read.
+ (with-slots (line column) scanner
+ (let ((l line) (c column) (limit (if donep used end)))
+ (do ((i start (1+ i)))
+ ((>= i limit))
+ (setf (values l c)
+ (update-position (char buf i) l c)))
+ (setf line l column c)))
+
+ ;; If the function is finished then update our state and
+ ;; return.
+ (when donep
+ (setf index used)
+ (when (>= index size)
+ (charbuf-scanner-fetch scanner))
+ (return-from charbuf-scanner-map (values donep t))))))
+
+ ;; If there's anything in the current buffer, offer it to the function.
+ (when (< index size)
+ (offer buf index size))
+
+ ;; Repeatedly fetch new buffers and offer them to the function.
+ ;; Because the buffers are fresh, we know that we must process them
+ ;; from the beginning. Note that `offer' will exit if FUNC has
+ ;; finished, so we don't need to worry about that.
+ (loop
+ (unless (charbuf-scanner-fetch scanner)
+ (return (if fail (funcall fail) (values nil nil))))
+ (offer buf 0 size)))))
+
+;;;--------------------------------------------------------------------------
+;;; Initialization.
+
+(defmethod shared-initialize :after
+ ((scanner charbuf-scanner) slot-names &key)
+
+ ;; Grab the filename from the underlying stream if we don't have a better
+ ;; guess.
+ (default-slot (scanner 'filename slot-names)
+ (with-slots (stream) scanner
+ (aif (stream-pathname stream) (namestring it) nil)))
+
+ ;; Get ready with the first character.
+ (charbuf-scanner-fetch scanner))
+
+;;;--------------------------------------------------------------------------
+;;; Scanner protocol implementation.
+
+(defmethod scanner-at-eof-p ((scanner charbuf-scanner))
+ (with-slots (buf) scanner
+ (eq buf :eof)))
+
+(defmethod scanner-current-char ((scanner charbuf-scanner))
+ (with-slots (buf index) scanner
+ (schar buf index)))
+
+(defmethod scanner-step ((scanner charbuf-scanner))
+ (with-slots (buf size index line column) scanner
+
+ ;; If there's a current character then update the position from it. When
+ ;; is there a current character? When the index is valid.
+ (when (< index size)
+ (setf (values line column)
+ (update-position (schar buf index) line column)))
+
+ ;; Now move the position on. If there's still a character left then we
+ ;; win; otherwise fetch another buffer.
+ (or (< (incf index) size)
+ (charbuf-scanner-fetch scanner))))
+
+(defmethod scanner-unread ((scanner charbuf-scanner) char)
+ (with-slots (buf index size unread tail line column) scanner
+ (cond
+
+ ;; First, let's rewind the buffer index. This isn't going to work if
+ ;; the index is already zero. (Note that this implies that INDEX is
+ ;; zero in the remaining cases.)
+ ((plusp index)
+ (decf index))
+
+ ;; Plan B. Maybe we've been here before, in which case we'll have left
+ ;; the appropriate state kicking about already. Note that, according
+ ;; to the `unread' rules, the character must be the same as last time,
+ ;; so we can just reuse the whole thing unchanged. Also, note that
+ ;; the NEXT field in UNREAD is not nil due to the way that we construct
+ ;; the link below.
+ ((and unread (eql (charbuf-chain-link-next unread) tail))
+ (setf tail unread size 1
+ buf (charbuf-chain-link-buf unread)))
+
+ ;; Nope, we've not been here, at least not recently. We'll concoct a
+ ;; new buffer and put the necessary stuff in it. Store it away for
+ ;; later so that repeated read/unread oscillations at this position
+ ;; don't end up consing enormous arrays too much.
+ (t
+ (let* ((next (or tail (make-charbuf-chain-link :buf buf :size size)))
+ (fake (make-charbuf))
+ (this (make-charbuf-chain-link :buf fake :size 1 :next next)))
+ (setf (schar fake 0) char buf fake size 1
+ tail this unread this))))
+
+ ;; That's that sorted; now we have to fiddle the position.
+ (setf (values line column) (backtrack-position char line column))))
+
+(defmethod scanner-capture-place ((scanner charbuf-scanner))
+ (with-slots (buf size index captures tail line column) scanner
+ (incf captures)
+ (unless tail
+ (setf tail (make-charbuf-chain-link :buf buf :size size)))
+ (make-charbuf-scanner-place :link tail :index index
+ :line line :column column)))
+
+(defmethod scanner-restore-place ((scanner charbuf-scanner) place)
+ (with-slots (buf size index tail line column) scanner
+ (let ((link (charbuf-scanner-place-link place)))
+ (setf buf (charbuf-chain-link-buf link)
+ size (charbuf-chain-link-size link)
+ index (charbuf-scanner-place-index place)
+ line (charbuf-scanner-place-line place)
+ column (charbuf-scanner-place-column place)
+ tail link))))
+
+(defmethod scanner-release-place ((scanner charbuf-scanner) place)
+ (with-slots (captures) scanner
+ (decf captures)))
+
+(defstruct (charbuf-slice
+ (:constructor make-charbuf-slice
+ (buf &optional (start 0) %end
+ &aux (end (or %end (length buf))))))
+ (buf nil :type (or charbuf (eql :eof)) :read-only t)
+ (start 0 :type (and fixnum unsigned-byte) :read-only t)
+ (end 0 :type (and fixnum unsigned-byte) :read-only t))
+
+(declaim (inline charbuf-slice-length))
+(defun charbuf-slice-length (slice)
+ (- (charbuf-slice-end slice) (charbuf-slice-start slice)))
+
+(defun concatenate-charbuf-slices (slices)
+ (let* ((len (reduce #'+ slices
+ :key #'charbuf-slice-length
+ :initial-value 0))
+ (string (make-array len :element-type 'character))
+ (i 0))
+ (dolist (slice slices)
+ (let ((buf (charbuf-slice-buf slice))
+ (end (charbuf-slice-end slice)))
+ (do ((j (charbuf-slice-start slice) (1+ j)))
+ ((>= j end))
+ (setf (schar string i) (schar buf j))
+ (incf i))))
+ string))
+
+(defmethod scanner-interval
+ ((scanner charbuf-scanner) place-a &optional place-b)
+ (let* ((slices nil)
+ (place-b (or place-b
+ (with-slots (index tail) scanner
+ (make-charbuf-scanner-place :link tail
+ :index index))))
+ (last-link (charbuf-scanner-place-link place-b)))
+ (flet ((bad ()
+ (error "Incorrect places ~S and ~S to SCANNER-INTERVAL."
+ place-a place-b)))
+ (do ((link (charbuf-scanner-place-link place-a)
+ (charbuf-chain-link-next link))
+ (start (charbuf-scanner-place-index place-a) 0))
+ ((eq link last-link)
+ (let ((end (charbuf-scanner-place-index place-b)))
+ (when (< end start)
+ (bad))
+ (push (make-charbuf-slice (charbuf-chain-link-buf link)
+ start end)
+ slices)
+ (concatenate-charbuf-slices (nreverse slices))))
+ (when (null link) (bad))
+ (push (make-charbuf-slice (charbuf-chain-link-buf link)
+ start
+ (charbuf-chain-link-size link))
+ slices)))))
+
+;;;--------------------------------------------------------------------------
+;;; Specialized streams.
+
+(export 'charbuf-scanner-stream)
+(defclass charbuf-scanner-stream (character-scanner-stream)
+ ((scanner :initarg :scanner :type charbuf-scanner)))
+
+(defmethod stream-read-sequence
+ ((stream charbuf-scanner-stream) (seq string) &optional (start 0) end)
+ (with-slots (scanner) stream
+ (unless end (setf end (length seq)))
+ (let ((i start) (n (- end start)))
+ (labels ((copy (i buf start end)
+ (do ((j i (1+ j))
+ (k start (1+ k)))
+ ((>= k end))
+ (setf (char seq j) (schar buf k))))
+ (snarf (buf start end)
+ (let ((m (- end start)))
+ (cond ((< m n)
+ (copy i buf start end) (decf n m) (incf i m)
+ (values nil 0))
+ (t
+ (copy i buf start (+ start n)) (incf i n)
+ (values t n))))))
+ (charbuf-scanner-map scanner #'snarf)
+ i))))
+
+(defmethod stream-read-line ((stream charbuf-scanner-stream))
+ (with-slots (scanner) stream
+ (let ((slices nil))
+ (flet ((snarf (buf start end)
+ (let ((pos (position #\newline buf :start start :end end)))
+ (push (make-charbuf-slice buf start (or pos end)) slices)
+ (if pos
+ (values (concatenate-charbuf-slices (nreverse slices))
+ (1+ pos))
+ (values nil 0))))
+ (fail ()
+ (values (concatenate-charbuf-slices (nreverse slices)) t)))
+ (charbuf-scanner-map scanner #'snarf #'fail)))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parser contexts for scanners
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic scanner behaviour.
+
+;; Basic scanners.
+
+(defmethod parser-step ((context scanner-context))
+ `(scanner-step ,(parser-scanner context)))
+
+(defmethod parser-at-eof-p ((context scanner-context))
+ `(scanner-at-eof-p ,(parser-scanner context)))
+
+(defmethod parser-capture-place ((context scanner-context))
+ `(scanner-capture-place ,(parser-scanner context)))
+
+(defmethod parser-restore-place ((context scanner-context) place)
+ `(scanner-restore-place ,(parser-scanner context) ,place))
+
+(defmethod parser-release-place ((context scanner-context) place)
+ `(scanner-release-place ,(parser-scanner context) ,place))
+
+;; Character scanners.
+
+(defmethod parser-current-char ((context character-scanner-context))
+ `(scanner-current-char ,(parser-scanner context)))
+
+;; Token scanners.
+
+(defmethod parser-token-type ((context token-scanner-context))
+ `(token-type ,(parser-scanner context)))
+
+(defmethod parser-token-value ((context token-scanner-context))
+ `(token-value ,(parser-scanner context)))
+
+;;;--------------------------------------------------------------------------
+;;; Contexts for specific scanner classes.
+
+;; String scanner.
+
+(defclass string-scanner-context (character-scanner-context)
+ ()
+ (:documentation
+ "Specialized parser context for scanning strings.
+
+ Most notably, string positions don't need to be released, which means that
+ the expanded code doesn't need to do install `unwind-protect' handlers."))
+
+(defmethod parser-places-must-be-released-p
+ ((context string-scanner-context))
+ nil)
+
+;; List scanner.
+
+(defclass list-scanner-context (token-scanner-context)
+ ()
+ (:documentation
+ "Specialized scanner contexts for the list scanner."))
+
+(defmethod parser-places-must-be-released-p ((context list-scanner-context))
+ nil)
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Tokenizing scanner
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner implementation.
+
+(defmethod shared-initialize :after
+ ((scanner token-scanner) slot-names &key)
+ (declare (ignore slot-names))
+ (scanner-step scanner))
+
+(defmethod scanner-at-eof-p ((scanner token-scanner))
+ (with-slots (type) scanner
+ (eq type :eof)))
+
+(defmethod scanner-step ((scanner token-scanner))
+ (with-slots (type value tail captures line column) scanner
+ (cond (tail
+ (let ((next (token-scanner-place-next tail)))
+ (setf type (token-scanner-place-type next)
+ value (token-scanner-place-value next)
+ line (token-scanner-place-line next)
+ column (token-scanner-place-column next)
+ tail next)))
+ (t
+ (multiple-value-bind (ty val) (scanner-token scanner)
+ (setf type ty
+ value val)
+ (when (plusp captures)
+ (let ((next (make-token-scanner-place
+ :type ty :value val :line line :column column)))
+ (setf (token-scanner-place-next tail) next
+ tail next))))))))
+
+(defmethod scanner-capture-place ((scanner token-scanner))
+ (with-slots (type value captures tail line column) scanner
+ (incf captures)
+ (or tail
+ (setf tail (make-token-scanner-place
+ :type type :value value :line line :column column)))))
+
+(defmethod scanner-restore-place ((scanner token-scanner) place)
+ (with-slots (type value tail line column) scanner
+ (setf type (token-scanner-place-type place)
+ value (token-scanner-place-value place)
+ line (token-scanner-place-line place)
+ column (token-scanner-place-column place)
+ tail place)))
+
+(defmethod scanner-release-place ((scanner token-scanner) place)
+ (with-slots (captures) scanner
+ (decf captures)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Basic scanner interface
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Common scanner implementation..
+
+(defmethod file-location ((scanner character-scanner))
+ (scanner-file-location scanner))
+
+;;;--------------------------------------------------------------------------
+;;; Streams on character scanners.
+
+(defmethod stream-read-char ((stream character-scanner-stream))
+ (with-slots (scanner) stream
+ (if (scanner-at-eof-p scanner)
+ :eof
+ (prog1 (scanner-current-char scanner)
+ (scanner-step scanner)))))
+
+(defmethod stream-unread-char ((stream character-scanner-stream) char)
+ (with-slots (scanner) stream
+ (scanner-unread scanner char)))
+
+(defmethod stream-peek-char ((stream character-scanner-stream))
+ (with-slots (scanner) stream
+ (scanner-current-char scanner)))
+
+;;;--------------------------------------------------------------------------
+;;; String scanner.
+
+;; This is much more convenient for testing lexers than the full character
+;; buffer scanner.
+
+(export '(string-scanner make-string-scanner string-scanner-p))
+(defstruct (string-scanner
+ (:constructor make-string-scanner
+ (string &key (start 0) end
+ &aux (index start)
+ (limit (or end (length string))))))
+ "Scanner structure for a simple string scanner."
+ (string "" :type string :read-only t)
+ (index 0 :type (and fixnum unsigned-byte))
+ (limit nil :type (and fixnum unsigned-byte) :read-only t))
+
+(defmethod scanner-at-eof-p ((scanner string-scanner))
+ (>= (string-scanner-index scanner) (string-scanner-limit scanner)))
+
+(defmethod scanner-current-char ((scanner string-scanner))
+ (char (string-scanner-string scanner) (string-scanner-index scanner)))
+
+(defmethod scanner-step ((scanner string-scanner))
+ (incf (string-scanner-index scanner)))
+
+(defmethod scanner-capture-place ((scanner string-scanner))
+ (string-scanner-index scanner))
+
+(defmethod scanner-restore-place ((scanner string-scanner) place)
+ (setf (string-scanner-index scanner) place))
+
+(defmethod scanner-interval
+ ((scanner string-scanner) place-a &optional place-b)
+ (with-slots (string index) scanner
+ (subseq string place-a (or place-b index))))
+
+;;;--------------------------------------------------------------------------
+;;; List scanner.
+
+(export 'list-scanner)
+(defstruct (list-scanner
+ (:constructor make-list-scanner (list)))
+ "Simple token scanner for lists.
+
+ The list elements are the token semantic values; the token types are the
+ names of the elements' classes. This is just about adequate for testing
+ purposes, but is far from ideal for real use."
+ (list nil :type list))
+
+(defmethod scanner-step ((scanner list-scanner))
+ (pop (list-scanner-list scanner)))
+
+(defmethod scanner-at-eof-p ((scanner list-scanner))
+ (null (list-scanner-list scanner)))
+
+(defmethod token-type ((scanner list-scanner))
+ (class-name (class-of (car (list-scanner-list scanner)))))
+
+(defmethod token-value ((scanner list-scanner))
+ (car (list-scanner-list scanner)))
+
+(defmethod scanner-capture-place ((scanner list-scanner))
+ (list-scanner-list scanner))
+
+(defmethod scanner-restore-place ((scanner list-scanner) place)
+ (setf (list-scanner-list scanner) place))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Additional streams.
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Compatibility hacking.
+
+;; ECL is different and strange. In early versions (0.9j and thereabouts)
+;; the Gray streams functions are in the SI package; CLOSE and STREAM-
+;; ELEMENT-TYPE are not generic, and call the generic functions SI:STREAM-
+;; CLOSE and SI:STREAM-ELT-TYPE if they find that they can't handle their
+;; argument. The STREAM-CLOSE generic function doesn't have a method for the
+;; built-in streams. In later versions (9.6.1 and thereabouts) the Gray
+;; streams functions are in the GRAY package; CLOSE and STREAM-ELEMENT-TYPE
+;; are still not generic, but now they call correspondingly-named generic
+;; functions in GRAY, and the generic versions do cover the built-in streams.
+;;
+;; The right thing to, then, seems to be as follows.
+;;
+;; * ECL is the weird system, so we'll hack it to be less weird. Hacking
+;; non-weird platforms seems wrong-headed.
+;;
+;; * Since SI:STREAM-CLOSE is missing a method which works on standard
+;; streams, we should add one if we're running that version of ECL.
+;;
+;; * Then we can shadow CLOSE and drop SI:STREAM-CLOSE or GRAY:CLOSE over
+;; the top. In the latter case, we can just do a SHADOWING-IMPORT; in
+;; the latter, we'll need to mess with FDEFINITION.
+;;
+;; * We'll do something similar for STREAM-ELEMENT-TYPE.
+;;
+;; Note that the following are all separate top-level forms so that later
+;; ones will be read with different symbols than earlier ones. This also
+;; means that we can use the *FEATURES* mechanism and avoid lots of the
+;; tedious messing about with FIND-SYMBOL.
+
+#+ecl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (if (find-package '#:gray)
+ (push :sod-ecl-broken-gray-streams *features*)))
+
+#+(and ecl (not sod-ecl-broken-gray-streams))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (shadowing-import '(gray:close gray:stream-element-type)))
+
+#+(and ecl sod-ecl-broken-gray-streams)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (shadow '(close stream-element-type)))
+#+(and ecl sod-ecl-broken-gray-streams)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (fdefinition 'close) #'si:stream-close
+ (fdefinition 'stream-element-type #'si:stream-elt-type)))
+
+;;;--------------------------------------------------------------------------
+;;; Proxy streams.
+
+;; Base classes for proxy streams.
+
+(defclass proxy-stream (fundamental-stream)
+ ((ustream :initarg :stream :type stream
+ :reader position-aware-stream-underlying-stream))
+ (:documentation
+ "Base class for proxy streams.
+
+ A proxy stream is one that works by passing most of its work to an
+ underlying stream. We provide some basic functionality for the later
+ classes."))
+
+(defmethod close ((stream proxy-stream) &key abort)
+ (with-slots (ustream) stream
+ (close ustream :abort abort)))
+
+(defmethod stream-element-type ((stream proxy-stream))
+ (with-slots (ustream) stream
+ (stream-element-type ustream)))
+
+(defmethod stream-file-position
+ ((stream proxy-stream) &optional (position nil posp))
+ (with-slots (ustream) stream
+ (if posp
+ (file-position ustream position)
+ (file-position ustream))))
+
+(defmethod stream-pathname ((stream proxy-stream))
+ (with-slots (ustream) stream
+ (stream-pathname ustream)))
+
+;; Base class for input streams.
+
+(defclass proxy-input-stream (proxy-stream fundamental-input-stream)
+ ()
+ (:documentation
+ "Base class for proxy input streams."))
+
+(defmethod stream-clear-input ((stream proxy-input-stream))
+ (with-slots (ustream) stream
+ (clear-input ustream)))
+
+(defmethod stream-read-sequence
+ ((stream proxy-input-stream) seq &optional (start 0) end)
+ (with-slots (ustream) stream
+ (read-sequence seq ustream :start start :end end)))
+
+;; Base class for output streams.
+
+(defclass proxy-output-stream (proxy-stream fundamental-output-stream)
+ ()
+ (:documentation
+ "Base class for proxy output streams."))
+
+(defmethod stream-clear-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (clear-output ustream)))
+
+(defmethod stream-finish-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (finish-output ustream)))
+
+(defmethod stream-force-output ((stream proxy-output-stream))
+ (with-slots (ustream) stream
+ (force-output ustream)))
+
+(defmethod stream-write-sequence
+ ((stream proxy-output-stream) seq &optional (start 0) end)
+ (with-slots (ustream) stream
+ (write-sequence seq ustream :start start :end end)))
+
+;; Character input streams.
+
+(defclass proxy-character-input-stream
+ (proxy-input-stream fundamental-character-input-stream)
+ ()
+ (:documentation
+ "A character-input-stream which is a proxy for an existing stream.
+
+ This doesn't actually change the behaviour of the underlying stream very
+ much, but it's a useful base to work on when writing more interesting
+ classes."))
+
+(defmethod stream-read-char ((stream proxy-character-input-stream))
+ (with-slots (ustream) stream
+ (read-char ustream nil :eof nil)))
+
+(defmethod stream-read-line ((stream proxy-character-input-stream))
+ (with-slots (ustream) stream
+ (read-line ustream nil "" nil)))
+
+(defmethod stream-unread-char ((stream proxy-character-input-stream) char)
+ (with-slots (ustream) stream
+ (unread-char char ustream)))
+
+;; Character output streams.
+
+(defclass proxy-character-output-stream
+ (proxy-stream fundamental-character-output-stream)
+ ()
+ (:documentation
+ "A character-output-stream which is a proxy for an existing stream.
+
+ This doesn't actually change the behaviour of the underlying stream very
+ much, but it's a useful base to work on when writing more interesting
+ classes."))
+
+(defmethod stream-line-column ((stream proxy-character-output-stream))
+ nil)
+
+(defmethod stream-line-length ((stream proxy-character-output-stream))
+ nil)
+
+(defmethod stream-terpri ((stream proxy-character-output-stream))
+ (with-slots (ustream) stream
+ (terpri ustream)))
+
+(defmethod stream-write-char ((stream proxy-character-output-stream) char)
+ (with-slots (ustream) stream
+ (write-char char ustream)))
+
+(defmethod stream-write-string
+ ((stream proxy-character-output-stream) string &optional (start 0) end)
+ (with-slots (ustream) stream
+ (write-string string ustream :start start :end end)))
+
+;;;--------------------------------------------------------------------------
+;;; The position-aware stream.
+
+;; Base class.
+
+(export '(position-aware-stream
+ position-aware-stream-line position-aware-stream-column))
+(defclass position-aware-stream (proxy-stream)
+ ((file :initarg :file :initform nil
+ :type pathname :accessor position-aware-stream-file)
+ (line :initarg :line :initform 1
+ :type fixnum :accessor position-aware-stream-line)
+ (column :initarg :column :initform 0
+ :type fixnum :accessor position-aware-stream-column))
+ (:documentation
+ "Character stream which keeps track of the line and column position.
+
+ A position-aware-stream wraps an existing character stream and tracks the
+ line and column position of the current stream position. A newline
+ character increases the line number by one and resets the column number to
+ zero; most characters advance the column number by one, but tab advances
+ to the next multiple of eight. (This is consistent with Emacs, at least.)
+ The position can be read using STREAM-LINE-AND-COLUMN.
+
+ This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
+ POSITION-AWARE-OUTPUT-STREAM."))
+
+(defgeneric stream-line-and-column (stream)
+ (:documentation
+ "Returns the current stream position of STREAM as line/column numbers.
+
+ Returns two values: the line and column numbers of STREAM's input
+ position.")
+ (:method ((stream stream))
+ (values nil nil))
+ (:method ((stream position-aware-stream))
+ (with-slots (line column) stream
+ (values line column))))
+
+(defmethod stream-pathname ((stream position-aware-stream))
+ "Return the pathname corresponding to a POSITION-AWARE-STREAM.
+
+ A POSITION-AWARE-STREAM can be given an explicit pathname, which is
+ returned in preference to the pathname of the underlying stream. This is
+ useful in two circumstances. Firstly, the pathname associated with a file
+ stream will have been subjected to TRUENAME, and may be less pleasant to
+ present back to a user. Secondly, a name can be attached to a stream
+ which doesn't actually have a file backing it."
+
+ (with-slots (file) stream
+ (or file (call-next-method))))
+
+(defmethod file-location ((stream position-aware-stream))
+ (multiple-value-bind (line column) (stream-line-and-column stream)
+ (make-file-location (stream-pathname stream) line column)))
+
+;; Utilities.
+
+(defmacro with-position ((stream) &body body)
+ "Convenience macro for tracking the read position.
+
+ Within the BODY, the macro (update CHAR) is defined to update the STREAM's
+ position according to the character CHAR.
+
+ The position is actually cached in local variables, but will be written
+ back to the stream even in the case of non-local control transfer from the
+ BODY. What won't work well is dynamically nesting WITH-POSITION forms."
+
+ (with-gensyms (line column char)
+ (once-only (stream)
+ `(let* ((,line (position-aware-stream-line ,stream))
+ (,column (position-aware-stream-column ,stream)))
+ (macrolet ((update (,char)
+ ;; This gets a little hairy. Hold tight.
+ `(multiple-value-setq (,',line ,',column)
+ (update-position ,,char ,',line ,',column))))
+ (unwind-protect
+ (progn ,@body)
+ (setf (position-aware-stream-line ,stream) ,line
+ (position-aware-stream-column ,stream) ,column)))))))
+
+;; Input stream.
+
+(export 'position-aware-input-stream)
+(defclass position-aware-input-stream
+ (position-aware-stream proxy-character-input-stream)
+ ()
+ (:documentation
+ "A character input stream which tracks the input position.
+
+ This is particularly useful for parsers and suchlike, which want to
+ produce accurate error-location information."))
+
+(defmethod stream-unread-char ((stream position-aware-input-stream) char)
+
+ ;; I could have written this as a :before or :after method, but I think
+ ;; this is the right answer. All of the other methods have to be primary
+ ;; (or around) methods, so at least it's consistent.
+ (with-slots (line column) stream
+ (setf (values line column) (backtrack-position char line column)))
+ (call-next-method))
+
+(defmethod stream-read-sequence
+ ((stream position-aware-input-stream) seq &optional (start 0) end)
+ (declare (ignore end))
+ (let ((pos (call-next-method)))
+ (with-position (stream)
+ (dosequence (ch seq :start start :end pos)
+ (update ch)))
+ pos))
+
+(defmethod stream-read-char ((stream position-aware-input-stream))
+ (let ((char (call-next-method)))
+ (with-position (stream)
+ (update char))
+ char))
+
+(defmethod stream-read-line ((stream position-aware-input-stream))
+ (multiple-value-bind (line eofp) (call-next-method)
+ (if eofp
+ (with-position (stream)
+ (dotimes (i (length line))
+ (update (char line i))))
+ (with-slots (line column) stream
+ (incf line)
+ (setf column 0)))
+ (values line eofp)))
+
+;; Output stream.
+
+(export 'position-aware-output-stream)
+(defclass position-aware-output-stream
+ (position-aware-stream proxy-character-output-stream)
+ ()
+ (:documentation
+ "A character output stream which tracks the output position.
+
+ This is particularly useful when generating C code: the position can be
+ used to generate `#line' directives referring to the generated code after
+ insertion of some user code."))
+
+(defmethod stream-write-sequence
+ ((stream position-aware-output-stream) seq &optional (start 0) end)
+ (with-position (stream)
+ (dosequence (ch seq :start start :end end)
+ (update ch))
+ (call-next-method)))
+
+(defmethod stream-line-column ((stream position-aware-output-stream))
+ (with-slots (column) stream
+ column))
+
+(defmethod stream-start-line-p ((stream position-aware-output-stream))
+ (with-slots (column) stream
+ (zerop column)))
+
+(defmethod stream-terpri ((stream position-aware-output-stream))
+ (with-slots (line column) stream
+ (incf line)
+ (setf column 0))
+ (call-next-method))
+
+(defmethod stream-write-char ((stream position-aware-output-stream) char)
+ (with-position (stream)
+ (update char))
+ (call-next-method))
+
+(defmethod stream-write-string
+ ((stream position-aware-output-stream) string &optional (start 0) end)
+ (with-position (stream)
+ (do ((i start (1+ i))
+ (end (or end (length string))))
+ ((>= i end))
+ (update (char string i))))
+ (call-next-method))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; operator precedence parser hacking
+
+(in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
;;; -*-lisp-*-
;;;
-;;; Package definition for SOD utility
+;;; Package definition for the Sod parser infrastructure
;;;
;;; (c) 2009 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; 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
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-(cl:defpackage #:sod
+(cl:defpackage #:sod-parser
(:use #:common-lisp
-
- ;; Find the meta-object protocol. Our demands are not particularly
- ;; heavy.
- #+sbcl #:sb-mop
- #+(or cmu clisp) #:mop
- #+ecl #:mop
+ #:sod-utilities
;; Try to find Gray streams support from somewhere. ECL tucks them
;; somewhere unhelpful.
#+clisp #:gray
#-(or sbcl cmu ecl clisp) ...))
-
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for file locations
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; File location objects.
+
+(export '(file-location make-file-location file-location-p
+ file-location-filename file-location-line file-location-column))
+(defstruct (file-location
+ (:constructor make-file-location
+ (%filename line column
+ &aux (filename
+ (etypecase %filename
+ ((or string null) %filename)
+ (pathname (namestring %filename)))))))
+ "A simple structure containing file location information.
+
+ Construct using MAKE-FILE-LOCATION; the main useful function is
+ ERROR-FILE-LOCATION."
+ (filename nil :type (or string null) :read-only t)
+ (line nil :type (or fixnum null) :read-only t)
+ (column nil :type (or fixnum null) :read-only t))
+
+(defgeneric file-location (thing)
+ (:documentation
+ "Convert THING into a FILE-LOCATION, if possible.
+
+ A THING which can be converted into a FILE-LOCATION is termed a
+ `file-location designator'.")
+ (:method ((thing file-location)) thing))
+
+;;;--------------------------------------------------------------------------
+;;; Enclosing conditions.
+
+(export '(enclosing-condition enclosed-condition))
+(define-condition enclosing-condition (condition)
+ ((enclosed-condition :initarg :condition :type condition
+ :reader enclosed-condition))
+ (:documentation
+ "A condition which encloses another condition
+
+ This is useful if one wants to attach additional information to an
+ existing condition. The enclosed condition can be obtained using the
+ ENCLOSED-CONDITION function.")
+ (:report (lambda (condition stream)
+ (princ (enclosed-condition condition) stream))))
+
+;;;--------------------------------------------------------------------------
+;;; Conditions with location information.
+
+(export 'condition-with-location)
+(define-condition condition-with-location (condition)
+ ((location :initarg :location :reader file-location :type file-location))
+ (:documentation
+ "A condition which has some location information attached."))
+
+(export 'enclosing-condition-with-location)
+(define-condition enclosing-condition-with-location
+ (condition-with-location enclosing-condition)
+ ())
+
+(export 'error-with-location)
+(define-condition error-with-location (condition-with-location error)
+ ())
+
+(export 'warning-with-location)
+(define-condition warning-with-location (condition-with-location warning)
+ ())
+
+(export 'enclosing-error-with-location)
+(define-condition enclosing-error-with-location
+ (enclosing-condition-with-location error)
+ ())
+
+(export 'enclosing-warning-with-location)
+(define-condition enclosing-warning-with-location
+ (enclosing-condition-with-location warning)
+ ())
+
+(export 'simple-condition-with-location)
+(define-condition simple-condition-with-location
+ (condition-with-location simple-condition)
+ ())
+
+(export 'simple-error-with-location)
+(define-condition simple-error-with-location
+ (error-with-location simple-error)
+ ())
+
+(export 'simple-warning-with-location)
+(define-condition simple-warning-with-location
+ (warning-with-location simple-warning)
+ ())
+
+;;;--------------------------------------------------------------------------
+;;; Reporting errors.
+
+(export 'make-condition-with-location)
+(defun make-condition-with-location (default-type floc datum &rest arguments)
+ "Construct a CONDITION-WITH-LOCATION given a condition designator.
+
+ The returned condition will always be a CONDITION-WITH-LOCATION. The
+ process consists of two stages. In the first stage, a condition is
+ constructed from the condition designator DATUM and ARGUMENTS with default
+ type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
+
+ * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
+ empty list.
+
+ * If DATUM is a symbol, then it must name a condition type. An instance
+ of this class is constructed using ARGUMENTS as initargs, i.e., as
+ if (apply #'make-condition ARGUMENTS); if the type is a subtype of
+ CONDITION-WITH-LOCATION then FLOC is attached as the location.
+
+ * If DATUM is a format control (i.e., a string or function), then the
+ condition is constructed as if, instead, DEFAULT-TYPE had been
+ supplied as DATUM, and the list (:format-control DATUM
+ :format-arguments ARGUMENTS) supplied as ARGUMENTS.
+
+ In the second stage, the condition constructed by the first stage is
+ converted into a CONDITION-WITH-LOCATION. If the condition already has
+ type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
+ wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
+ if the condition was a subtype of ERROR or WARNING then the resulting
+ condition will also be subtype of ERROR or WARNING as appropriate."
+
+ (labels ((wrap (condition)
+ (make-condition
+ (etypecase condition
+ (error 'enclosing-error-with-location)
+ (warning 'enclosing-warning-with-location)
+ (condition 'enclosing-condition-with-location))
+ :condition condition
+ :location (file-location floc)))
+ (make (type &rest initargs)
+ (if (subtypep type 'condition-with-location)
+ (apply #'make-condition type
+ :location (file-location floc)
+ initargs)
+ (wrap (apply #'make-condition type initargs)))))
+ (etypecase datum
+ (condition-with-location datum)
+ (condition (wrap datum))
+ (symbol (apply #'make arguments))
+ ((or string function) (make default-type
+ :format-control datum
+ :format-arguments arguments)))))
+
+(export 'error-with-location)
+(defun error-with-location (floc datum &rest arguments)
+ "Report an error with attached location information."
+ (error (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(export 'warn-with-location)
+(defun warn-with-location (floc datum &rest arguments)
+ "Report a warning with attached location information."
+ (warn (apply #'make-condition-with-location
+ 'simple-warning-with-location
+ floc datum arguments)))
+
+(export 'cerror-with-location)
+(defun cerror-with-location (floc continue-string datum &rest arguments)
+ "Report a continuable error with attached location information."
+ (cerror continue-string
+ (apply #'make-condition-with-location
+ 'simple-error-with-location
+ floc datum arguments)))
+
+(export 'cerror*)
+(defun cerror* (datum &rest arguments)
+ (apply #'cerror "Continue" datum arguments))
+
+(export 'cerror*-with-location)
+(defun cerror*-with-location (floc datum &rest arguments)
+ (apply #'cerror-with-location floc "Continue" datum arguments))
+
+;;;--------------------------------------------------------------------------
+;;; Stamping errors with location information.
+
+(defun with-default-error-location* (floc thunk)
+ "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
+ other conditions) which do not have file location information attached to
+ them already.
+
+ See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
+
+ (if floc
+ (handler-bind
+ ((condition-with-location
+ (lambda (condition)
+ (declare (ignore condition))
+ :decline))
+ (condition
+ (lambda (condition)
+ (signal (make-condition-with-location nil floc condition)))))
+ (funcall thunk))
+ (funcall thunk)))
+
+(export 'with-default-error-location)
+(defmacro with-default-error-location ((floc) &body body)
+ "Evaluate BODY, as an implicit progn, in a dynamic environment which
+ attaches FLOC to errors (and other conditions) which do not have file
+ location information attached to them already.
+
+ If a condition other than a CONDITION-WITH-LOCATION is signalled during
+ the evaluation of the BODY, then an instance of an appropriate subcalass
+ of ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the
+ original condition, and signalled. In particular, if the original
+ condition was a subtype of ERROR or WARNING, then the new condition will
+ also be a subtype of ERROR or WARNING as appropriate.
+
+ The FLOC argument is coerced to a FILE-LOCATION object each time a
+ condition is signalled. For example, if FLOC is a lexical analyser object
+ which reports its current position in response to FILE-LOCATION, then each
+ condition will be reported as arising at the lexer's current position at
+ that time, rather than all being reported at the same position.
+
+ If the new enclosing condition is not handled, the handler established by
+ this macro will decline to handle the original condition. Typically,
+ however, the new condition will be handled by COUNT-AND-REPORT-ERRORS.
+
+ As a special case, if FLOC is nil, then no special action is taken, and
+ BODY is simply evaluated, as an implicit progn."
+
+ `(with-default-error-location* ,floc (lambda () ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Front-end error reporting.
+
+(defun count-and-report-errors* (thunk)
+ "Invoke THUNK in a dynamic environment which traps and reports errors.
+
+ See the COUNT-AND-REPORT-ERRORS macro for more detais."
+
+ (let ((errors 0)
+ (warnings 0))
+ (handler-bind
+ ((error (lambda (error)
+ (let ((fatal (not (find-restart 'continue error))))
+ (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
+ (file-location error)
+ fatal
+ error)
+ (incf errors)
+ (if fatal
+ (return-from count-and-report-errors*
+ (values nil errors warnings))
+ (invoke-restart 'continue)))))
+ (warning (lambda (warning)
+ (format *error-output* "~&~A: Warning: ~A~%"
+ (file-location warning)
+ warning)
+ (incf warnings)
+ (invoke-restart 'muffle-warning))))
+ (values (funcall thunk)
+ errors
+ warnings))))
+
+(export 'count-and-report-errors)
+(defmacro count-and-report-errors (() &body body)
+ "Evaluate BODY in a dynamic environment which traps and reports errors.
+
+ The BODY is evaluated. If an error or warning is signalled, it is
+ reported (using its report function), and counted. Warnings are otherwise
+ muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
+ continued; non-continuable errors cause an immediate exit from the BODY.
+
+ The final value consists of three values: the primary value of the BODY
+ (or NIL if a non-continuable error occurred), the number of errors
+ reported, and the number of warnings reported."
+ `(count-and-report-errors* (lambda () ,@body)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Parsers for expressions with binary operators
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol.
+
+(export 'push-operator)
+(defgeneric push-operator (operator state)
+ (:documentation
+ "Push an OPERATOR onto the STATE's operator stack.
+
+ This should apply existing stacked operators as necessary to obey the
+ language's precedence rules."))
+
+(export 'push-vlaue)
+(defgeneric push-value (value state)
+ (:documentation
+ "Push VALUE onto the STATE's value stack.
+
+ The default message just does that without any fuss. It's unlikely that
+ this will need changing unless you invent some really weird values."))
+
+(export 'apply-operator)
+(defgeneric apply-operator (operator state)
+ (:documentation
+ "Apply the OPERATOR to argument on the STATE's value stack.
+
+ This should pop any necessary arguments, and push the result."))
+
+(export 'operator-push-action)
+(defgeneric operator-push-action (left right)
+ (:documentation
+ "Determine relative precedence between LEFT and RIGHT operators.
+
+ Returns one of three possible values:
+
+ * `:push' means to push the RIGHT operator onto the stack, above the
+ LEFT operator -- i.e., RIGHT has higher precedence than LEFT.
+
+ * `:apply' means to apply the LEFT operator to arguments immediately
+ and try again, comparing RIGHT to the new topmost operator -- i.e.,
+ LEFT has higher precedence than RIGHT.
+
+ * `:error' means that the situation is erroneous: a continuable error is
+ signalled and the situation resolved by applying the LEFT operator and
+ then pushing the RIGHT one -- i.e., treating them as having similar
+ precedence and left associativity).
+
+ There is a default method which decides between `:push' and `:apply' by
+ comparing numerical precedence values."))
+
+(export 'expr)
+(defparse expr ((&key (nestedp (gensym "NESTEDP-")))
+ operand binop preop postop)
+ "Parse an expression involving unary and binary operators."
+ (flet ((wrap (parser)
+ `(parser (,nestedp)
+ (declare (ignorable ,nestedp))
+ ,parser)))
+ `(parse-expression ,(wrap operand)
+ ,(wrap binop)
+ ,(wrap preop)
+ ,(wrap postop))))
+
+;;;--------------------------------------------------------------------------
+;;; Numerical precedence.
+
+(export '(operator-left-precedence operator-right-precedence))
+(defgeneric operator-left-precedence (operator)
+ (:documentation
+ "Return the OPERATOR's left-precedence.
+
+ Higher precedence numbers indicate tighter leftward binding. Under the
+ default method for `operator-push-action', the OPERATOR's left precedence
+ is compared to the existing operators' right precedences to determine the
+ parser's behaviour: if it is higher, then the OPERATOR is pushed;
+ otherwise the existing operator is applied. Thus, equal precedences cause
+ left-associative parsing."))
+(defgeneric operator-right-precedence (operator)
+ (:documentation
+ "Return the OPERATOR's right-precedence.
+
+ Higher precedence numbers indicate tighter rightward binding. Under the
+ default method for `operator-push-action', a new operator's left
+ precedence may be compared to the existing OPERATOR'S right precedences to
+ determine the parser's behaviour: if it is higher, then the new operator
+ is pushed; otherwise the existing OPERATOR is applied. Thus, equal
+ precedences cause left-associative parsing."))
+
+(defgeneric operator-associativity (operator)
+ (:documentation
+ "Returns an OPERATOR's associativity, as a symbol.
+
+ The return value is one of `:left', `:right' or `nil'. If two adjacent
+ operators have the same precedence, their associativities are compared.
+ If both associativities are `:left' then the left-hand operator is
+ considered to have higher precedence; if both are `:right' then the
+ right-hand operator is considered to have higher precedence. If they're
+ inconsistent or `nil', then an error is reported and the behaviour is as
+ if both were `:left'.")
+ (:method (operator) :left))
+
+;;;--------------------------------------------------------------------------
+;;; Basic operator protocol.
+
+(export 'prefix-operator)
+(defclass prefix-operator ()
+ ()
+ (:documentation
+ "Prefix operator base class.
+
+ Prefix operators are special because they are pushed at a time when the
+ existing topmost operator on the stack may not have its operand
+ available. It is therefore incorrect to attempt to apply any existing
+ operators without careful checking. This class provides a method on
+ `push-operator' which immediately pushes the new operator without
+ inspecting the existing stack."))
+
+(export 'simple-operator)
+(defclass simple-operator ()
+ ((function :initarg :function :reader operator-function)
+ (name :initarg :name :initform "<unnamed operator>"
+ :reader operator-name))
+ (:documentation
+ "A simple operator applies a FUNCTION to arguments when it is applied.
+
+ The precise details of the function are left to subclasses to sort out."))
+
+(export 'simple-unary-operator)
+(defclass simple-unary-operator (simple-operator)
+ ()
+ (:documentation
+ "A unary operator works on the topmost value on the value stack.
+
+ The topmost item is popped, the FUNCTION is applied to it, and the result
+ is pushed back on."))
+
+(export 'simple-binary-operator)
+(defclass simple-binary-operator (simple-operator)
+ ((lprec :initarg :left-precedence :initarg :precedence
+ :reader operator-left-precedence)
+ (rprec :initarg :right-precedence :reader operator-right-precedence)
+ (associativity :initarg :associative :initform :left
+ :reader operator-associativity))
+ (:documentation
+ "A binary operator works on the two topmost values on the value stack.
+
+ The function's arguments are the two topmost items in /reverse/ order --
+ so the topmost item is second. This is usually what you want.
+
+ The left and right precedences are settable independently. Usually (and
+ this is the default) you will set them equal, and use the `:associativity'
+ initarg to determine associativity; however, right-associativity can also
+ be obtained by setting the right-precedence lower than the left. Special
+ effects can be obtained by setting them in other ways. Use your
+ imagination."))
+
+(export 'simple-postfix-operator)
+(defclass simple-postfix-operator (simple-unary-operator)
+ ((lprec :initarg :left-precedence :initarg :precedence
+ :reader operator-left-precedence)
+ (rprec :initarg :right-precedence :reader operator-right-precedence))
+ (:documentation
+ "A postfix operator is applied to a single operand.
+
+ The left and right precedences are settable independently. Usually you
+ will want to set them equal (this is the default) and quite high. Special
+ effects can be obtained by doing other things instead; but note that you
+ will get an incorrect parse if the right precedence is lower than the left
+ precedence of a binary operator because the postfix operator will be
+ applied to the result of the binary operator."))
+
+(export 'simple-prefix-operator)
+(defclass simple-prefix-operator (prefix-operator simple-unary-operator)
+ ((rprec :initarg :precedence :reader operator-right-precedence))
+ (:documentation
+ "A prefix operator is applied to a single operand.
+
+ There is only one precedence value for a prefix operator: the
+ `prefix-operator' superclass arranges that the left precedence is
+ effectively minus infinity."))
+
+(export 'preop)
+(defmacro preop (name (x prec) &body body)
+ `(make-instance 'simple-prefix-operator
+ :name ,name
+ :precedence ,prec
+ :function (lambda (,x) ,@body)))
+
+(export 'postop)
+(defmacro postop (name (x prec &key rprec) &body body)
+ (once-only (name prec rprec)
+ `(make-instance 'simple-postfix-operator
+ :name ,name
+ :left-precedence ,prec
+ :right-precedence ,(or rprec prec)
+ :function (lambda (,x) ,@body))))
+
+(export 'binop)
+(defmacro binop (name (x y prec &key rprec (assoc :left)) &body body)
+ (once-only (name prec rprec assoc)
+ `(make-instance 'simple-binary-operator
+ :name ,name
+ :left-precedence ,prec
+ :right-precedence ,(or rprec prec)
+ :associative ,assoc
+ :function (lambda (,x ,y) ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Parentheses.
+
+(defclass parenthesis ()
+ ((tag :initarg :tag :initform nil))
+ (:documentation
+ "Base class for parenthesis operators."))
+
+(export 'open-parenthesis)
+(defclass open-parenthesis (parenthesis prefix-operator) ())
+
+(export 'close-parenthesis)
+(defclass close-parenthesis (parenthesis) ())
+
+(export '(lparen rparen))
+(defun lparen (tag)
+ (make-instance 'open-parenthesis :tag tag))
+(defun rparen (tag)
+ (make-instance 'close-parenthesis :tag tag))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for parsing.
+;;;
+;;; (c) 2009 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.
+
+;;;--------------------------------------------------------------------------
+;;; Parser protocol discussion.
+;;;
+;;; Other languages, notably Haskell and ML, have `parser combinator
+;;; libraries', which allow one to construct recursive descent parsers using
+;;; approximately pleasant syntax. While attempts have been made to
+;;; introduce the benefits of these libraries to Lisp, they've not been
+;;; altogether successful; this seems due to Lisp's lack of features such as
+;;; pattern matching, currying and lazy evaluation. Rather than fight with
+;;; Lisp's weaknesses, this library plays to its strength, making heavy use
+;;; of macros. Effectively, the `combinators' we build here are /compile-
+;;; time/ combinators, not run-time ones.
+;;;
+;;; A `parser' is simply an expression which returns three values.
+;;;
+;;; * If the second value is nil, then the parser is said to have /failed/,
+;;; and the first value is a list describing the things that the parser
+;;; expected to find but didn't. (The precise details of the list items
+;;; are important to error-reporting functions, but not to the low-level
+;;; machinery, and are left up to higher-level protocols to nail down
+;;; harder.)
+;;;
+;;; * If the second value is not nil, then the parser is said to have
+;;; /succeeded/, and the first value is its /result/.
+;;;
+;;; * The third value indicates whether the parser consumed any of its
+;;; input. Parsers don't backtrack implicitly (to avoid space leaks and
+;;; bad performance), so the `consumedp' return value is used to decide
+;;; whether the parser has `committed' to a particular branch. If the
+;;; parser context supports place-capture (many do) then `peek' can be
+;;; used to suppress consumption of input in the case of parser failure.
+;;;
+;;; The functions and macros here are simply ways of gluing together
+;;; expressions which obey this protocol.
+;;;
+;;; The main contribution of this file is a macro WITH-PARSER-CONTEXT which
+;;; embeds a parsing-specific S-expressions language entered using the new
+;;; macro PARSE. The behaviour of this macro is controlled by a pair of
+;;; compile-time generic functions EXPAND-PARSER-SPEC and EXPAND-PARSER-FORM.
+;;; As well as the parser expression they're meant to process, these
+;;; functions dispatch on a `context' argument, which is intended to help
+;;; `leaf' parsers find the terminal symbols which they're meant to process.
+;;;
+;;; Note that the context is a compile-time object, constructed by the PARSE
+;;; macro expansion function, though the idea is that it will contain the
+;;; name or names of variables holding the run-time parser state (which will
+;;; typically be a lexical analyser or an input stream or suchlike).
+
+(cl:in-package #:sod-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun combine-parser-failures (failures)
+ "Combine the failure indicators listed in FAILURES.
+
+ (Note that this means that FAILURES is a list of lists.)"
+
+ (reduce (lambda (f ff) (union f ff :test #'equal))
+ failures
+ :initial-value nil))
+
+;;;--------------------------------------------------------------------------
+;;; Basic protocol.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (export 'expand-parser-spec)
+ (defgeneric expand-parser-spec (context spec)
+ (:documentation
+ "Expand a parser specifier SPEC in a particular parser CONTEXT.")
+ (:method (context (spec list))
+ (expand-parser-form context (car spec) (cdr spec))))
+
+ (export 'expand-parser-form)
+ (defgeneric expand-parser-form (context head tail)
+ (:documentation
+ "Expand a parser list-form given by HEAD and TAIL, in CONTEXT.")
+ (:method (context head tail)
+ (cons head tail)))
+
+ (export 'wrap-parser)
+ (defgeneric wrap-parser (context form)
+ (:documentation
+ "Enclose FORM in whatever is necessary to make the parser work.")
+ (:method (context form) form)))
+
+(export 'defparse)
+(defmacro defparse (name bvl &body body)
+ "Define a new parser form.
+
+ The full syntax is hairier than it looks:
+
+ defparse NAME ( [[ :context (CTX SPEC) ]] . BVL )
+ { FORM }*
+
+ The macro defines a new parser form (NAME ...) which is expanded by the
+ 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
+ use this to override the built-in forms safely if they don't seem to be
+ doing the right thing for you. Also, the context -- which is probably
+ interesting to you if you've bothered to specialize -- is bound to the
+ variable CTX."
+
+ ;; BUG! misplaces declarations: if you declare the CONTEXT argument
+ ;; `special' it won't be bound properly. I'm really not at all sure I know
+ ;; how to fix this.
+
+ (with-gensyms (head tail context)
+ (let ((ctxclass t))
+ (loop
+ (unless (and bvl (keywordp (car bvl))) (return))
+ (ecase (pop bvl)
+ (:context (destructuring-bind (name spec) (pop bvl)
+ (setf ctxclass spec context name)))))
+ (multiple-value-bind (doc decls body) (parse-body body)
+ `(defmethod expand-parser-form
+ ((,context ,ctxclass) (,head (eql ',name)) ,tail)
+ ,@doc
+ (block ,name
+ (destructuring-bind ,bvl ,tail
+ ,@decls
+ ,@body)))))))
+
+(export '(with-parser-context parse))
+(defmacro with-parser-context ((class &rest initargs) &body body)
+ "Evaluate BODY with a macro `parse' which expands parser forms.
+
+ Evaluate BODY as an implicit progn. At compile time, a parser context is
+ constructed by (apply #'make-instance CLASS INITARGS). The BODY can make
+ use of the macro `parse':
+
+ parse SPEC
+
+ which parses the input in the manner described by SPEC, in the context of
+ the parser context."
+
+ (let ((context (apply #'make-instance class initargs)))
+ (wrap-parser context
+ `(macrolet ((parse (form)
+ (expand-parser-spec ',context form)))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Common parser context protocol.
+
+(export 'parser-at-eof-p)
+(defgeneric parser-at-eof-p (context)
+ (:documentation
+ "Return whether the parser has reached the end of its input.
+
+ Be careful: all of this is happening at macro expansion time."))
+
+(export 'parser-step)
+(defgeneric parser-step (context)
+ (:documentation
+ "Advance the parser to the next character.
+
+ Be careful: all of this is happening at macro-expansion time."))
+
+(defmethod expand-parser-spec (context (spec (eql :eof)))
+ "Tests succeeds if the parser has reached the end of its input.
+
+ The failure indicator is the keyword `:eof'."
+
+ `(if ,(parser-at-eof-p context)
+ (values :eof t nil)
+ (values '(:eof) nil nil)))
+
+;;;--------------------------------------------------------------------------
+;;; Useful macros for dealing with parsers.
+
+(export 'it)
+(export 'if-parse)
+(defmacro if-parse ((&key (result 'it) expected (consumedp (gensym "CP")))
+ parser consequent &optional (alternative nil altp))
+ "Conditional parsing construction.
+
+ If PARSER succeeds, then evaluate CONSEQUENT with RESULT bound to the
+ result; otherwise evaluate ALTERNATIVE with EXPECTED bound to the
+ expected-item list. If ALTERNATIVE is omitted, then propagate the failure
+ following the parser protocol."
+
+ (with-gensyms (value win)
+ `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+ (declare (ignorable ,consumedp))
+ (if ,win
+ (let ((,result ,value))
+ (declare (ignorable ,result))
+ ,consequent)
+ ,(cond ((not altp)
+ `(values ,value nil ,consumedp))
+ (expected
+ `(let ((,expected ,value)) ,alternative))
+ (t
+ alternative))))))
+
+(export 'when-parse)
+(defmacro when-parse ((&optional (result 'it)) parser &body body)
+ "Convenience macro for conditional parsing.
+
+ If PARSER succeeds then evaluate BODY with RESULT bound to the result;
+ otherwise propagate the failure."
+ `(if-parse (:result ,result) ,parser (progn ,@body)))
+
+(export 'cond-parse)
+(defmacro cond-parse ((&key (result 'it) expected
+ (consumedp (gensym "CP")))
+ &body clauses)
+ "Frightening conditional parsing construct.
+
+ Each of the CLAUSES has the form (PARSER &rest FORMS); the special `fake'
+ parser form `t' may be used to describe a default action. If the PARSER
+ succeeds then evaluate FORMS in order with RESULT bound to the parser
+ result (if there are no forms, then propagate the success); if the PARSER
+ fails without consuming input, then move onto the next clause.
+
+ If the default clause (if any) is reached, or a parser fails after
+ consuming input, then EXPECTED is bound to a list of failure indicators
+ and the default clause's FORMS are evaluated and with CONSUMEDP bound to a
+ generalized boolean indicating whether any input was consumed. If there
+ is no default clause, and either some parser fails after consuming input,
+ or all of the parsers fail without consuming, then a failure is reported
+ and the input-consumption indicator is propagated.
+
+ If a parser fails after consuming input, then the failure indicators are
+ whatever that parser reported; if all the parsers fail without consuming
+ then the failure indicators are the union of the indicators reported by
+ the various parsers."
+
+ (with-gensyms (block fail failarg)
+ (labels ((walk (clauses failures)
+ (cond ((null clauses)
+ (values `(,fail nil (list ,@(reverse failures)))
+ `(values (combine-parser-failures ,failarg)
+ nil
+ ,consumedp)))
+ ((eq (caar clauses) t)
+ (values `(,fail nil (list ,@(reverse failures)))
+ `(,@(if expected
+ `(let ((,expected
+ (combine-parser-failures
+ ,failarg))))
+ `(progn))
+ ,@(cdar clauses))))
+ (t
+ (with-gensyms (value win cp)
+ (multiple-value-bind (inner failbody)
+ (walk (cdr clauses) (cons value failures))
+ (values `(multiple-value-bind (,value ,win ,cp)
+ (parse ,(caar clauses))
+ (when ,win
+ (return-from ,block
+ (let ((,result ,value)
+ (,consumedp ,cp))
+ (declare (ignorable ,result
+ ,consumedp))
+ ,@(cdar clauses))))
+ (when ,cp
+ (,fail t (list ,value)))
+ ,inner)
+ failbody)))))))
+ (multiple-value-bind (inner failbody) (walk clauses nil)
+ `(block ,block
+ (flet ((,fail (,consumedp ,failarg)
+ (declare (ignorable ,consumedp ,failarg))
+ ,failbody))
+ ,inner))))))
+
+(export 'parser)
+(defmacro parser (bvl &body parser)
+ "Functional abstraction for parsers."
+ (multiple-value-bind (doc decls body) (parse-body parser)
+ `(lambda ,bvl ,@doc ,@decls (parse ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Standard parser forms.
+
+(export 'label)
+(defparse label (label parser)
+ "If PARSER fails, use LABEL as the expected outcome.
+
+ The LABEL is only evaluated if necessary."
+ (with-gensyms (value win consumedp)
+ `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+ (if ,win
+ (values ,value ,win ,consumedp)
+ (values (list ,label) nil ,consumedp)))))
+
+(defparse t (value)
+ "Succeed, without consuming input, with result VALUE."
+ `(values ,value t nil))
+
+(defparse when (cond &body parser)
+ "If CONDITION is true, then match PARSER; otherwise fail."
+ `(if ,cond (parse ,@parser) (values nil nil nil)))
+
+(defmethod expand-parser-spec (context (spec (eql t)))
+ "Always matches without consuming input."
+ '(values t t nil))
+
+(export 'seq)
+(defparse seq (binds &body body)
+ "Parse a sequence of heterogeneous items.
+
+ Syntax:
+
+ seq ( { ATOMIC-PARSER-FORM | ([VAR] PARSER-FORM) }* )
+ { FORM }*
+
+ The behaviour is similar to `let*'. The PARSER-FORMs are processed in
+ order, left to right. If a parser succeeds, then its value is bound to
+ the corresponding VAR, and available within Lisp forms enclosed within
+ subsequent PARSER-FORMs and/or the body FORMs. If any parser fails, then
+ the entire sequence fails. If all of the parsers succeeds, then the FORMs
+ are evaluated as an implicit progn, and the sequence will succeed with the
+ result computed by the final FORM."
+
+ (with-gensyms (block consumedp)
+ (labels ((walk (binds lets ignores)
+ (if (endp binds)
+ `(let* ((,consumedp nil)
+ ,@(nreverse lets))
+ ,@(and ignores
+ `((declare (ignore ,@(nreverse ignores)))))
+ (values (progn ,@body) t ,consumedp))
+ (destructuring-bind (x &optional (y nil yp))
+ (if (listp (car binds))
+ (car binds)
+ (list (car binds)))
+ (with-gensyms (var value win cp)
+ (multiple-value-bind (var parser ignores)
+ (if (and yp x)
+ (values x y ignores)
+ (values var (if yp y x) (cons var ignores)))
+ (walk (cdr binds)
+ (cons `(,var (multiple-value-bind
+ (,value ,win ,cp)
+ (parse ,parser)
+ (when ,cp (setf ,consumedp t))
+ (unless ,win
+ (return-from ,block
+ (values ,value ,nil
+ ,consumedp)))
+ ,value))
+ lets)
+ ignores)))))))
+ `(block ,block ,(walk binds nil nil)))))
+
+(export 'and)
+(defparse and (:context (context t) &rest parsers)
+ "Parse a sequence of heterogeneous items, but ignore their values.
+
+ This is just like (and is implemented using) `seq' with all the bindings
+ set to `nil'. The result is `nil'."
+ (with-gensyms (last)
+ (if (null parsers)
+ '(seq () nil)
+ (expand-parser-spec context
+ `(seq (,@(mapcar (lambda (parser)
+ `(nil ,parser))
+ (butlast parsers))
+ (,last ,(car (last parsers))))
+ ,last)))))
+
+(export 'lisp)
+(defparse lisp (&rest forms)
+ "Evaluate FORMs, which should obey the parser protocol."
+ `(progn ,@forms))
+
+(export 'many)
+(defparse many ((acc init update
+ &key (new 'it) (final acc) (min nil minp) max (commitp t))
+ parser &optional (sep nil sepp))
+ "Parse a sequence of homogeneous items.
+
+ The behaviour is similar to `do'. Initially an accumulator ACC is
+ established, and bound to the value of INIT. The PARSER is then evaluated
+ repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults
+ to `it') bound to the result of the parse, and the value returned by
+ UPDATE is stored back into ACC. If the PARSER fails, then the parse
+ ends. The scope of ACC includes the UPDATE and FINAL forms, and the
+ PARSER and SEP parsers; it is updated by side effects, not rebound.
+
+ If a SEP parser is provided, then the behaviour changes as follows.
+ Before each attempt to parse a new item using PARSER, the parser SEP is
+ invoked. If SEP fails then the parse ends; if SEP succeeds, and COMMITP
+ is true, then the PARSER must also succeed or the overall parse will
+ fail. If COMMITP is false then a trailing SEP is permitted and ignored.
+
+ If MAX (which will be evaluated) is not nil, then it must be a number: the
+ parse ends automatically after PARSER has succeeded MAX times. When the
+ parse has ended, if the PARSER succeeded fewer than MIN (which will be
+ evaluated) times then the parse fails. Otherwise, the FINAL form (which
+ defaults to simply returning ACC) is evaluated and its value becomes the
+ result of the parse. MAX defaults to nil -- i.e., no maximum; MIN
+ defaults to 1 if a SEP parser is given, or 0 if not.
+
+ Note that `many' cannot fail if MIN is zero."
+
+ ;; Once upon a time, this was a macro of almost infinite hairiness which
+ ;; tried to do everything itself, including inspecting its arguments for
+ ;; constant-ness to decide whether it could elide bits of code. This
+ ;; became unsustainable. Nowadays, it packages up its parser arguments
+ ;; into functions and calls some primitive functions to do the heavy
+ ;; lifting.
+ ;;
+ ;; The precise protocol between this macro and the backend functions is
+ ;; subject to change: don't rely on it.
+
+ (let* ((accvar (or acc (gensym "ACC-")))
+ (func (if sepp '%many-sep '%many)))
+ `(let ((,accvar ,init))
+ (declare (ignorable ,accvar))
+ (,func (lambda (,new)
+ (declare (ignorable ,new))
+ (setf ,accvar ,update))
+ (lambda ()
+ ,final)
+ (parser () ,parser)
+ ,@(and sepp (list `(parser () ,sep)))
+ ,@(and minp `(:min ,min))
+ ,@(and max `(:max ,max))
+ ,@(and (not (eq commitp t)) `(:commitp ,commitp))))))
+
+(export 'list)
+(defparse list ((&rest keys) parser &optional (sep nil sepp))
+ "Like MANY, but simply returns a list of the parser results."
+ (with-gensyms (acc)
+ `(parse (many (,acc nil (cons it ,acc) :final (nreverse ,acc) ,@keys)
+ ,parser ,@(and sepp (list sep))))))
+
+(export 'skip-many)
+(defparse skip-many ((&rest keys) parser &optional (sep nil sepp))
+ "Like MANY, but ignores the results."
+ `(parse (many (nil nil nil ,@keys)
+ ,parser ,@(and sepp (list sep)))))
+
+(export 'or)
+(defparse or (&rest parsers)
+ "Try a number of alternative parsers.
+
+ Each of the PARSERS in turn is tried. If any succeeds, then its result
+ becomes the result of the parse. If any parser fails after consuming
+ input, or if all of the parsers fail, then the overall parse fails, with
+ the union of the expected items from the individual parses."
+
+ (with-gensyms (fail cp failarg)
+ (labels ((walk (parsers failures)
+ (if (null parsers)
+ `(,fail nil (list ,@(reverse failures)))
+ (with-gensyms (value win consumedp)
+ `(multiple-value-bind (,value ,win ,consumedp)
+ (parse ,(car parsers))
+ (cond (,win
+ (values ,value ,win ,consumedp))
+ (,consumedp
+ (,fail t (list ,value)))
+ (t
+ ,(walk (cdr parsers)
+ (cons value failures)))))))))
+ `(flet ((,fail (,cp ,failarg)
+ (values (combine-parser-failures ,failarg) nil ,cp)))
+ ,(walk parsers nil)))))
+
+(export '?)
+(defparse ? (parser &optional (value nil))
+ "Matches PARSER or nothing; fails if PARSER fails after consuming input."
+ `(parse (or ,parser (t ,value))))
+
+;;;--------------------------------------------------------------------------
+;;; Pluggable parsers.
+
+(export 'call-pluggable-parser)
+(defun call-pluggable-parser (symbol &rest args)
+ "Call the pluggable parser denoted by SYMBOL.
+
+ A `pluggable parser' is an indirection point at which a number of
+ alternative parsers can be attached dynamically. The parsers are tried in
+ some arbitrary order, so one should be careful to avoid ambiguities; each
+ is paseed the given ARGS.
+
+ If any parser succeeds then it determines the result; if any parser fails
+ having consumed input then the pluggable parser fails immediately. If all
+ of the parsers fail without consuming input then the pluggable parser
+ fails with the union of the individual failure indicators."
+
+ (let ((expected nil))
+ (dolist (item (get symbol 'parser))
+ (multiple-value-bind (value winp consumedp) (apply (cdr item) args)
+ (when (or winp consumedp)
+ (return-from call-pluggable-parser (values value winp consumedp)))
+ (push value expected)))
+ (values (combine-parser-failures expected) nil nil)))
+
+(export 'plug)
+(defparse plug (symbol &rest args)
+ "Call the pluggable parser denoted by SYMBOL.
+
+ This is just like the function `call-pluggable-parser', but the SYMBOL is
+ not evaluated."
+ `(call-pluggable-parser ',symbol ,@args))
+
+(export 'pluggable-parser-add)
+(defun pluggable-parser-add (symbol tag parser)
+ "Adds an element to a pluggable parser.
+
+ The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'-
+ comparable object which identifies the element. The PARSER is a parser
+ function; it will be passed arguments via `pluggable-parser'.
+
+ If a parser with the given TAG is already attached to SYMBOL then the new
+ parser replaces the old one; otherwise it is added to the collection."
+
+ (let ((alist (get symbol 'parser)))
+ (aif (assoc tag alist)
+ (setf (cdr it) parser)
+ (setf (get symbol 'parser) (acons tag parser alist)))))
+
+(export 'define-pluggable-parser)
+(defmacro define-pluggable-parser (symbol tag (&rest bvl) &body body)
+ "Adds an element to a pluggable parser.
+
+ The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'-
+ comparable object which identifies the element. Neither SYMBOL nor TAG is
+ evaluated. The BODY is a parser expression; the BVL is a lambda list
+ describing how to bind the argumens supplied via `pluggable-parser'.
+
+ If a parser with the given TAG is already attached to SYMBOL then the new
+ parser replaces the old one; otherwise it is added to the collection."
+
+ `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Rewindable parser context protocol.
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+ (export 'parser-capture-place)
+ (defgeneric parser-capture-place (context)
+ (:documentation
+ "Capture the current position of a parser CONTEXT.
+
+ The return value may later be used with `parser-restore-place'. Be
+ careful: all of this is happening at macro-expansion time.")
+ (:method (context)
+ (error "Parser context ~S doesn't support rewinding." context)))
+
+ (export 'parser-restore-place)
+ (defgeneric parser-restore-place (context place)
+ (:documentation
+ "`Rewind' the parser CONTEXT back to the captured PLACE.
+
+ The place was previously captured by `parser-capture-place'. Be careful:
+ all of this is happening at macro-expansion time."))
+
+ (export 'parser-release-place)
+ (defgeneric parser-release-place (context place)
+ (:documentation
+ "Release a PLACE captured from the parser CONTEXT.
+
+ The place was previously captured by `parser-capture-place'. The
+ underlying scanner can use this call to determine whether there are
+ outstanding captured places, and thereby optimize its behaviour. Be
+ careful: all of this is happening at macro-expansion time.")
+ (:method (context place) nil))
+
+ (export 'parser-places-must-be-released-p)
+ (defgeneric parser-places-must-be-released-p (context)
+ (:documentation
+ "Answer whether places captured from the parser CONTEXT need releasing.
+
+ Some contexts -- well, actually, their run-time counterparts -- work
+ better if they can keep track of which places are captured, or at least if
+ there are captured places outstanding. If this function returns true
+ (which is the default) then `with-parser-place' (and hence parser macros
+ such as `peek') will expand to `unwind-protect' forms in order to perform
+ the correct cleanup. If it returns false, then the `unwind-protect' is
+ omitted so that the runtime code does't have to register cleanup
+ handlers.")
+ (:method (context) t)))
+
+(export 'with-parser-place)
+(defmacro with-parser-place ((place context) &body body)
+ "Evaluate BODY surrounded with a binding of PLACE to a captured place.
+
+ The surrounding code will release the PLACE properly on exit from the body
+ forms. This is all happening at macro-expansion time."
+ ;; ... which means that it's a bit hairy. Fortunately, the nested
+ ;; backquotes aren't that bad.
+ (once-only (context)
+ (with-gensyms (bodyfunc)
+ `(with-gensyms (,place)
+ (flet ((,bodyfunc () ,@body))
+ `(let ((,,place ,(parser-capture-place ,context)))
+ ,(if (parser-places-must-be-released-p ,context)
+ `(unwind-protect ,(,bodyfunc)
+ ,(parser-release-place ,context ,place))
+ (,bodyfunc))))))))
+
+(export 'peek)
+(defparse peek (:context (context t) parser)
+ "Attempt to run PARSER, but rewind the underlying source if it fails."
+ (with-gensyms (value win consumedp)
+ (with-parser-place (place context)
+ `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser)
+ (cond (,win
+ (values ,value ,win ,consumedp))
+ (t
+ ,(parser-restore-place context place)
+ (values ,value ,win nil)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Character parser context protocol.
+
+(export 'character-parser-context)
+(defclass character-parser-context ()
+ ()
+ (:documentation
+ "Base class for parsers which read one character at a time."))
+
+(export 'parser-current-char)
+(defgeneric parser-current-char (context)
+ (:documentation
+ "Return the parser's current character.
+
+ It is an error to invoke this operation if the parser is at end-of-file;
+ you must check this first. Be careful: all of this is happening at
+ macro-expansion time."))
+
+(defparse if-char (:context (context character-parser-context)
+ (&optional (char 'it)) condition consequent alternative)
+ "Basic character-testing parser.
+
+ If there is a current character, bind it to CHAR and evaluate the
+ CONDITION; if that is true, then step the parser and evaluate CONSEQUENT;
+ otherwise, if either we're at EOF or the CONDITION returns false, evaluate
+ ALTERNATIVE. The result of `if-char' are the values returned by
+ CONSEQUENT or ALTERNATIVE."
+
+ (with-gensyms (block)
+ `(block ,block
+ (unless ,(parser-at-eof-p context)
+ (let ((,char ,(parser-current-char context)))
+ (when ,condition
+ ,(parser-step context)
+ (return-from ,block ,consequent))))
+ ,alternative)))
+
+(defmethod expand-parser-spec
+ ((context character-parser-context) (spec (eql :any)))
+ "Matches any character; result is the character.
+
+ The failure indicator is the keyword `:any'."
+ (expand-parser-spec context
+ '(if-char () t
+ (values it t t)
+ (values '(:any) nil nil))))
+
+(export 'char)
+(defparse char (:context (context character-parser-context) char)
+ "Matches the character CHAR (evaluated); result is the character.
+
+ The failure indicator is CHAR."
+
+ (once-only (char)
+ (with-gensyms (it)
+ (expand-parser-spec context
+ `(if-char (,it) (char= ,it ,char)
+ (values ,it t t)
+ (values (list ,char) nil nil))))))
+
+(defmethod expand-parser-spec
+ ((context character-parser-context) (char character))
+ (expand-parser-spec context `(char ,char)))
+
+(export 'satisfies)
+(defparse satisfies (:context (context character-parser-context) predicate)
+ "Matches a character that satisfies the PREDICATE
+
+ The PREDICATE is a function designator. On success, the result is the
+ character. The failure indicator is PREDICATE; you probably want to apply
+ a `label'."
+
+ (with-gensyms (it)
+ (expand-parser-spec context
+ `(if-char (,it) (,predicate ,it)
+ (values ,it t t)
+ (values '(,predicate) nil nil)))))
+
+(export 'not)
+(defparse not (:context (context character-parser-context) char)
+ "Matches any character other than CHAR; result is the character.
+
+ The failure indicator is (not CHAR)."
+
+ (once-only (char)
+ (with-gensyms (it)
+ (expand-parser-spec context
+ `(if-char (,it) (char/= ,it ,char)
+ (values ,it t t)
+ (values `((not ,,char)) nil nil))))))
+
+(export 'filter)
+(defparse filter (:context (context character-parser-context) predicate)
+ "Matches a character that satisfies the PREDICATE; result is the output of
+ PREDICATE.
+
+ The failure indicator is PREDICATE; you probably want to apply a `label'."
+
+ ;; Can't do this one with `if-char'.
+ (with-gensyms (block value)
+ `(block ,block
+ (unless ,(parser-at-eof-p context)
+ (let ((,value (,predicate ,(parser-current-char context))))
+ (when ,value
+ ,(parser-step context)
+ (return-from ,block (values ,value t t)))))
+ (values '(,predicate) nil nil))))
+
+(defmethod expand-parser-spec
+ ((context character-parser-context) (spec (eql :whitespace)))
+ "Matches any sequence of whitespace; result is nil.
+
+ Cannot fail."
+
+ `(progn
+ (cond ((and (not ,(parser-at-eof-p context))
+ (whitespace-char-p ,(parser-current-char context)))
+ (loop
+ ,(parser-step context)
+ (when (or ,(parser-at-eof-p context)
+ (not (whitespace-char-p
+ ,(parser-current-char context))))
+ (return (values nil t t)))))
+ (t
+ (values nil t nil)))))
+
+(defmethod expand-parser-spec
+ ((context character-parser-context) (string string))
+ "Matches the constituent characters of STRING; result is the string.
+
+ The failure indicator is STRING; on failure, the input is rewound, so this
+ only works on rewindable contexts."
+
+ (with-gensyms (i)
+ (unless (typep string 'simple-string)
+ (setf string (make-array (length string) :initial-contents string)))
+ (with-parser-place (place context)
+ `(dotimes (,i ,(length string) (values ,string t
+ ,(plusp (length string))))
+ (when (or ,(parser-at-eof-p context)
+ (char/= ,(parser-current-char context)
+ (schar ,string ,i)))
+ ,(parser-restore-place context place)
+ (return (values '(,string) nil nil)))
+ ,(parser-step context)))))
+
+;;;--------------------------------------------------------------------------
+;;; Token parser context protocol.
+
+(export 'token-parser-context)
+(defclass token-parser-context ()
+ ()
+ (:documentation
+ "Base class for parsers which read tokens with associated semantic values.
+
+ A token, according to the model suggested by this class, has a /type/,
+ which classifies the token and is the main contributer to guiding the
+ parse, and a /value/, which carries additional semantic information.
+
+ This may seem redundant given Lisp's dynamic type system; but it's not
+ actually capable of drawing sufficiently fine distinctions easily. For
+ example, we can represent a symbol either as a string or a symbol; but
+ using strings conflicts with being able to represent string literals, and
+ using symbols looks ugly and they don't get GCed. Similarly, it'd be
+ convenient to represent punctuation as characters, but that conflicts with
+ using them for character literals. So, we introduce our own notion of
+ token type.
+
+ Token scanners are expected to signal end-of-file with a token of type
+ `:eof'."))
+
+(export 'parser-token-type)
+(defgeneric parser-token-type (context)
+ (:documentation
+ "Return the parser's current token type."))
+
+(export 'parser-token-value)
+(defgeneric parser-token-value (context)
+ (:documentation
+ "Return the parser's current token's semantic value."))
+
+(export 'token)
+(defparse token (:context (context token-parser-context)
+ type &optional (value nil valuep) &key peekp)
+ "Match tokens of a particular type.
+
+ A token matches under the following conditions:
+
+ * If the value of TYPE is `t' then the match succeeds if and only if the
+ parser it not at end-of-file.
+
+ * If the value of TYPE is not `eql' to the token type then the match
+ fails.
+
+ * If VALUE is specified, and the value of VALUE is not `equal' to the
+ token semantic value then the match fails.
+
+ * Otherwise the match succeeds.
+
+ If the match is successful and the parser is not at end-of-file, and the
+ value of PEEKP is nil then the parser advances to the next token; the
+ result of the match is the token's value.
+
+ If the match fails then the failure indicator is either TYPE or (TYPE
+ VALUE), depending on whether a VALUE was specified."
+
+ (once-only (type value peekp)
+ (with-gensyms (tokty tokval)
+ `(let ((,tokty ,(parser-token-type context))
+ (,tokval ,(parser-token-value context)))
+ (if ,(if (eq type t)
+ `(not (eq ,tokty :eof))
+ (flet ((check-value (cond)
+ (if valuep
+ `(and ,cond (equal ,tokval ,value))
+ cond)))
+ (if (constantp type)
+ (check-value `(eql ,tokty ,type))
+ `(if (eq ,type t)
+ (not (eq ,tokty :eof))
+ ,(check-value `(eql ,tokty ,type))))))
+ ,(let* ((result `(values ,tokval t ,(if (constantp peekp)
+ (not peekp)
+ `(not ,peekp))))
+ (step (parser-step context)))
+ (cond ((not (constantp peekp))
+ `(multiple-value-prog1 ,result
+ (unless ,peekp ,step)))
+ (peekp
+ result)
+ (t
+ `(multiple-value-prog1 ,result
+ ,step))))
+ (values (list ,(if valuep `(list ,type ,value) type))
+ nil nil))))))
+
+(defmethod expand-parser-spec ((context token-parser-context) spec)
+ (if (atom spec)
+ (expand-parser-spec context `(token ,spec))
+ (call-next-method)))
+
+(defmethod expand-parser-spec ((context token-parser-context) (spec string))
+ (expand-parser-spec context `(token :id ,spec)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Scanner protocol definitions.
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Scanner context protocol.
+
+(export 'parser-scanner)
+(defgeneric parser-scanner (context)
+ (:documentation
+ "Return the symbol naming the CONTEXT's run-time scanner."))
+
+(export 'scanner-context)
+(defclass scanner-context ()
+ ((scanner :initarg :scanner :type symbol :reader parser-scanner))
+ (:documentation
+ "Base class for scanner contexts.
+
+ A scanner is simply an object maintaining the run-time state of a parsing
+ operation, in the same way as a parser context maintains the compile-time
+ state. So the scanner context is a compile-time context which expands to
+ calls to use the run-time scanner. See?
+
+ This class provides common compile-time behaviour for PARSER-AT-EOF-P and
+ friends by invoking corresponding methods on the scanner object at
+ run-time."))
+
+;;;--------------------------------------------------------------------------
+;;; Basic scanner protocol.
+
+(export 'scanner-at-eof-p)
+(defgeneric scanner-at-eof-p (scanner)
+ (:documentation
+ "Answer whether the SCANNER is at end-of-file.
+
+ It is an error to query the current item when at end-of-file."))
+
+(export 'scanner-step)
+(defgeneric scanner-step (scanner)
+ (:documentation
+ "Advance the SCANNER to the next item.
+
+ The precise nature of the items isn't known at this level, so a protocol
+ for accessing them is left for later."))
+
+;;;--------------------------------------------------------------------------
+;;; Scanner place-capture protocol.
+
+(export 'scanner-capture-place)
+(defgeneric scanner-capture-place (scanner)
+ (:documentation
+ "Capture the SCANNER's current place and return it.")
+ (:method (scanner)
+ (error "Scanner ~S doesn't support rewinding." scanner)))
+
+(export 'scanner-restore-place)
+(defgeneric scanner-restore-place (scanner place)
+ (:documentation
+ "`Rewind' the SCANNER to the captured PLACE.
+
+ The place was previously captured by `scanner-capture-place'."))
+
+(export 'scanner-release-place)
+(defgeneric scanner-release-place (scanner place)
+ (:documentation
+ "Release a PLACE captured from the SCANNER.
+
+ The place was previously captured by `scanner-capture-place'.")
+ (:method (scanner place) nil))
+
+(export 'with-scanner-place)
+(defmacro with-scanner-place ((place scanner) &body body)
+ "Evaluate BODY with PLACE bound to the captured current place.
+
+ Automatically releases the place when the BODY finishes. Note that
+ if you wanted to circumvent the cleanup then you should have used
+ `with-parser-place', which does all of this in the meta-level."
+ (once-only (scanner)
+ `(let ((,place (scanner-capture-place ,scanner)))
+ (unwind-protect (progn ,@body)
+ (scanner-release-place ,scanner ,place)))))
+
+;;;--------------------------------------------------------------------------
+;;; Character scanner protocol.
+
+(export 'character-scanner)
+(defclass character-scanner ()
+ ()
+ (:documentation "Base class for character scanners."))
+
+(export 'character-scanner-context)
+(defclass character-scanner-context
+ (scanner-context character-parser-context)
+ ()
+ (:documentation
+ "A context for a richer character-oriented scanner."))
+
+(export 'scanner-current-char)
+(defgeneric scanner-current-char (scanner)
+ (:documentation
+ "Returns the SCANNER's current character.
+
+ You advance to the next one using `scanner-step'."))
+
+(export 'scanner-unread)
+(defgeneric scanner-unread (scanner char)
+ (:documentation
+ "Rewind SCANNER by one character, specifically CHAR.
+
+ CHAR must be the character most recently stepped over by `scanner-step' --
+ it is an error to unread before the first call to `scanner-step'. It is
+ also an error to unread after encountering end-of-file."))
+
+(export 'scanner-interval)
+(defgeneric scanner-interval (scanner place-a &optional place-b)
+ (:documentation
+ "Return the characters from PLACE-A up to (but not including) PLACE-B.
+
+ The characters are returned as a string. If PLACE-B is omitted, return
+ the characters up to (but not including) the current position. It is an
+ error if PLACE-B precedes PLACE-A or they are from different scanners."))
+
+(export '(scanner-filename scanner-line scanner-column))
+(defgeneric scanner-filename (scanner)
+ (:documentation "Return the filename backing the SCANNER.")
+ (:method (scanner) nil))
+(defgeneric scanner-line (scanner)
+ (:documentation "Return the SCANNER's current line number.")
+ (:method (scanner) nil))
+(defgeneric scanner-column (scanner)
+ (:documentation "Return the SCANNER's current column number.")
+ (:method (scanner) nil))
+
+(defun scanner-file-location (scanner)
+ "Capture the current location of the SCANNER.
+
+ This uses the generic functions `scanner-filename', `scanner-line' and
+ `scanner-column' to compute its result. There are default methods on
+ these functions which make up dummy results.
+
+ There is a method for `file-location' defined on `character-scanner' which
+ simply calls this function; but since some scanners are structure-objects
+ rather than standard-objects they can't include `character-scanner' as a
+ superclass."
+ (make-file-location (scanner-filename scanner)
+ (scanner-line scanner)
+ (scanner-column scanner)))
+
+;;;--------------------------------------------------------------------------
+;;; Token scanner protocol.
+
+;; A place marker.
+
+(export '(token-scanner-place token-scanner-place-p))
+(defstruct token-scanner-place
+ "A link in the chain of lookahead tokens; capturable as a place.
+
+ If the scanner's place is captured, it starts to maintain a list of
+ lookahead tokens. The list contains internal links -- it works out
+ slightly easier that way. This is basically a simpler version of the
+ charbuf scanner (q.v.); most significantly, the chain links here do double
+ duty as place markers.
+
+ The details of this structure are not a defined part of the token scanner
+ protocol."
+
+ (next nil :type (or token-scanner-place null))
+ (type nil :read-only t)
+ (value nil :read-only t)
+ (line 1 :type fixnum :read-only t)
+ (column 0 :type fixnum :read-only t))
+
+;; The token scanner base class and parser context.
+
+(export '(token-scanner token-type token-value))
+(defclass token-scanner ()
+ ((type :reader token-type)
+ (value :reader token-value)
+ (captures :initform 0 :type fixnum)
+ (tail :initform nil :type (or token-scanner-place null))
+ (filename :initarg filename :type string :reader scanner-filename)
+ (line :initarg :line :initform 1 :type fixnum :accessor scanner-line)
+ (column :initarg :column :initform 0
+ :type fixnum :accessor scanner-column))
+ (:documentation
+ "A rewindable scanner for tokenizing.
+
+ The scanner should be used via the parser protocol; see also the token
+ scanner protocol, which explains the model.
+
+ Subclasses must provide the detailed scanning behaviour -- most notably
+ the `scanner-token' generic function. This function should also update
+ the `line' and `column' slots to track the position in the underlying
+ source, if appropriate, and also implement a method on `file-location' to
+ return the location. This class will handle the remaining details, such
+ as dealing correctly with rewinding."))
+
+(export 'token-scanner-context)
+(defclass token-scanner-context (scanner-context token-parser-context)
+ ()
+ (:documentation
+ "A parser context for a richer token-based scanners."))
+
+;; Protocol.
+
+(export 'scanner-token)
+(defgeneric scanner-token (scanner)
+ (:documentation
+ "Internal protocol: read the next token from the SCANNER.
+
+ This function is called by `scanner-step' to actually read the next token
+ if necessary. It should return two values: the token's `type' and its
+ `value'."))
+
+;;;--------------------------------------------------------------------------
+;;; Character scanner streams.
+;;;
+;;; This seems like an abstraction inversion, but it's important if we're to
+;;; `read' from a character scanner.
+
+(export 'character-scanner-stream)
+(defclass character-scanner-stream (fundamental-character-input-stream)
+ ((scanner :initarg :scanner))
+ (:documentation
+ "A stream which reads from a character scanner.
+
+ The SCANNER must implement the character scanner protcol, including
+ `scanner-current-char', `scanner-step', and `scanner-unread'; it is not
+ necessary that the scanner implement the place-capture protocol.
+
+ The stream can be made more efficient by implementing
+ `stream-read-sequence' and `stream-read-line' in a scanner-specific
+ manner."))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Additional stream protocol.
+;;;
+;;; (c) 2009 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-parser)
+
+;;;--------------------------------------------------------------------------
+;;; Discovery of file names.
+
+(export 'stream-pathname)
+(defgeneric stream-pathname (stream)
+ (:documentation
+ "Returns the pathname of the file that STREAM is open on.
+
+ If STREAM is open on a file, then return the pathname of that file.
+ Otherwise return NIL.")
+
+ ;; Provide some default methods. Most streams don't have a pathname.
+ ;; File-based streams provide a pathname, but it's usually been merged with
+ ;; *DEFAULT-PATHNAME-DEFAULTS* or some such, which has made it absolute,
+ ;; which isn't ideal. We'll hack around this in more useful classes later.
+ (:method ((stream stream)) nil)
+ (:method ((stream file-stream)) (pathname stream)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Test parser infrastructure
+;;;
+;;; (c) 2009 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)
+
+(defclass test-parser (test-case)
+ ())
+(add-test *sod-test-suite* (get-suite test-parser))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defmacro assert-parse
+ ((string value winp consumedp &key (scanner (gensym "SCANNER-")))
+ &body parser)
+ (once-only (string value winp consumedp)
+ (with-gensyms (my-value my-winp my-consumedp label what)
+ `(let ((,scanner (make-string-scanner ,string)))
+ (multiple-value-bind (,my-value ,my-winp ,my-consumedp)
+ (with-parser-context
+ (character-scanner-context :scanner ,scanner)
+ (parse ,@parser))
+ (flet ((,label (,what)
+ (format nil "~A; parsing ~S with ~S"
+ ,what ,string ',@parser)))
+ (cond (,winp
+ (assert-true ,my-winp (,label "winp"))
+ (if (eq ,value t)
+ (assert-not-eql ,my-value nil
+ (,label "parser result"))
+ (assert-equal ,my-value ,value
+ (,label "parser result"))))
+ (t
+ (assert-false ,my-winp (,label "winp"))
+ (assert-true (and (null (set-difference ,my-value ,value
+ :test #'equal))
+ (null (set-difference ,value ,my-value
+ :test #'equal)))
+ (,label "failure indicator"))))
+ (if ,consumedp
+ (assert-true ,my-consumedp (,label "consumedp"))
+ (assert-false ,my-consumedp (,label "consumedp")))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple parser tests.
+;;;
+;;; This lot causes SBCL to warn like a mad thing. It's too clever for us,
+;;; and does half of the work at compile time!
+
+(def-test-method test-simple ((test test-parser) :run nil)
+ "Test simple atomic parsers, because we rely on them later."
+
+ ;; Characters match themselves. For a character known only at run-time,
+ ;; use (char CH).
+ (assert-parse ("abcd" #\a t t) #\a)
+ (let ((ch #\b))
+ (assert-parse ("abcd" '(#\b) nil nil) (char ch)))
+
+ ;; A character can't match at EOF.
+ (assert-parse ("" '(#\z) nil nil) #\z)
+
+ ;; All characters match :any; but EOF isn't a character.
+ (assert-parse ("z" #\z t t) :any)
+ (assert-parse ("" '(:any) nil nil) :any)
+
+ ;; The parser (satisfies PREDICATE) succeeds if the PREDICATE returns
+ ;; true when applied to the current character.
+ (assert-parse ("a" #\a t t) (satisfies alpha-char-p))
+ (assert-parse ("0" '(alpha-char-p) nil nil) (satisfies alpha-char-p))
+
+ ;; The parser (not CHAR) matches a character other than CHAR; but it won't
+ ;; match EOF.
+ (assert-parse ("a" #\a t t) (not #\b))
+ (assert-parse ("b" '((not #\b)) nil nil) (not #\b))
+ (assert-parse ("" '((not #\b)) nil nil) (not #\b))
+
+ ;; But :eof matches only at EOF.
+ (assert-parse ("" :eof t nil) :eof)
+ (assert-parse ("abcd" '(:eof) nil nil) :eof)
+
+ ;; Strings match themselves without consuming if they fail.
+ (assert-parse ("abcd" "ab" t t) "ab")
+ (assert-parse ("abcd" '("cd") nil nil) "cd"))
+
+(def-test-method test-sequence ((test test-parser) :run nil)
+
+ ;; An empty sequence always succeeds and never consumes. And provokes
+ ;; warnings: don't do this.
+ (assert-parse ("" :win t nil) (seq () :win))
+ (assert-parse ("abcd" :win t nil) (seq () :win))
+
+ ;; A `seq' matches the individual parsers in order, and binds their results
+ ;; to variables -- if given. The result is the value of the body. If any
+ ;; parser fails having consumed input, then input stays consumed. There's
+ ;; no backtracking.
+ (assert-parse ("abcd" '(#\a . #\c) t t)
+ (seq ((foo #\a) #\b (bar #\c)) (cons foo bar)))
+ (assert-parse ("abcd" '(#\c) nil t)
+ (seq ((foo #\a) (bar #\c)) (cons foo bar)))
+ (assert-parse ("abcd" '(#\c) nil nil)
+ (seq ((bar #\c) (foo #\a)) (cons foo bar))))
+
+(def-test-method test-repeat ((test test-parser) :run nil)
+
+ ;; A `many' matches a bunch of similar things in a row. You can compute a
+ ;; result using `do'-like accumulation.
+ (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc)) #\a))
+
+ ;; The default minimum is zero; so the parser always succeeds.
+ (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc)) #\b))
+
+ ;; You can provide an explicit minimum. Then the match might fail.
+ (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min 2) #\a))
+ (assert-parse ("aabb" '(#\a) nil t) (many (acc 0 (1+ acc) :min 3) #\a))
+
+ ;; You can also provide an explicit maximum. This will cause the parser to
+ ;; stop searching, but it can't make it fail.
+ (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max 3) #\a))
+
+ ;; You can provide both a maximum and a minimum at the same time. If
+ ;; they're consistent, you won't be surprised. If they aren't, then the
+ ;; maximum wins and the minimum is simply ignored (currently).
+ (assert-parse ("aaaaab" 4 t t)
+ (many (acc 0 (1+ acc) :min 3 :max 4) #\a))
+ (assert-parse ("aabbbb" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min 3 :max 4) #\a))
+ (assert-parse ("aaabbb" 3 t t)
+ (many (acc 0 (1+ acc) :min 3 :max 3) #\a))
+ (assert-parse ("aaabbb" 3 t t)
+ (many (acc 0 (1+ acc) :min 17 :max 3) #\a))
+
+ ;; You can provide a separator. The `many' parser will look for the
+ ;; separator between each of the main items, but will ignore the results.
+ (assert-parse ("a,a,abc" 3 t t) (many (acc 0 (1+ acc)) #\a #\,))
+ (assert-parse ("a,a,abc" 2 t t) (many (acc 0 (1+ acc) :max 2) #\a #\,))
+
+ ;; If `many' sees a separator then by default it commits to finding another
+ ;; item; so this can cause a parse to fail.
+ (assert-parse ("a,a,bc" '(#\a) nil t) (many (acc 0 (1+ acc)) #\a #\,))
+ (assert-parse ("abc" 1 t t) (many (acc 0 (1+ acc)) #\a #\,))
+
+ ;; If you specify a separator then the default minimum number of
+ ;; repetitions becomes 1 rather than 0. But you can override this
+ ;; explicitly.
+ (assert-parse ("bc" '(#\a) nil nil) (many (acc 0 (1+ acc)) #\a #\,))
+ (assert-parse ("bc" 0 t nil) (many (acc 0 (1+ acc) :min 0) #\a #\,))
+
+ ;; The parser will fail looking for a separator if there aren't enough
+ ;; items.
+ (assert-parse ("a,abc" '(#\,) nil t)
+ (many (acc 0 (1+ acc) :min 3) #\a #\,))
+
+ ;; You can override the commit-on-separator behaviour by using :commit.
+ ;; This makes a trailing separator legal (but optional), so it also affects
+ ;; the behaviour regarding maximum and minimum repetitions. (Commitment is
+ ;; irrelevant if you don't have a separator.)
+ (assert-parse ("a,a,bc" 2 t t)
+ (many (acc 0 (1+ acc) :commitp nil) #\a #\,))
+ (assert-parse ("a,a,abc" 3 t t)
+ (many (acc 0 (1+ acc) :commitp nil) #\a #\,))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp t) #\a #\,))
+ #\,)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp nil) #\a #\,))
+ #\b)
+ n))
+ (assert-parse ("a,a,bc" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min 3 :commitp nil) #\a #\,))
+
+ ;; The `many' parser won't backtrack. The `many' eats as many `a's as
+ ;; possible; asking for another one is sure to fail.
+ (assert-parse ("aaaabc" '(#\a) nil t) (and (skip-many () #\a) #\a)))
+
+(def-test-method test-repeat-hairy ((test test-parser) :run nil)
+ ;; The `many' expander is very hairy and does magical things if it notices
+ ;; that some of its arguments are constants. So here we test a number of
+ ;; the above things again, using variables so that it has to produce code
+ ;; which makes decisions at run-time. (I've no doubt that SBCL will issue
+ ;; an infinite number of notes explaining how clever it is and how it can
+ ;; do it all at compile-time anyway. Of course, suppressing these notes is
+ ;; the main reason `many' is so hairy anyway.)
+
+ (let ((zero 0) (two 2) (three 3) (yes t) (no nil))
+
+ ;; Minima.
+ (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :min zero) #\a))
+ (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc) :min zero) #\b))
+ (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min two) #\a))
+ (assert-parse ("aabb" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min three) #\a))
+
+ ;; Maxima.
+ (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :max no) #\a))
+ (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max three) #\a))
+
+ ;; And now together with separators and commitment. Oh, my.
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (many (acc 0 (1+ acc) :commitp no) #\a #\,))
+ (assert-parse ("a,a,a,bc" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :commitp yes) #\a #\,))
+ (assert-parse ("a,a,bc" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min three :commitp yes) #\a #\,))
+ (assert-parse ("a,a,bc" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min 3 :commitp yes) #\a #\,))
+ (assert-parse ("a,a,bc" '(#\a) nil t)
+ (many (acc 0 (1+ acc) :min three :commitp t) #\a #\,))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max three :commitp no) #\a #\,)) #\b)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max three :commitp yes) #\a #\,)) #\,)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp no) #\a #\,)) #\b)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp yes) #\a #\,)) #\,)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max three :commitp nil) #\a #\,)) #\b)
+ n))
+ (assert-parse ("a,a,a,bc" 3 t t)
+ (seq ((n (many (acc 0 (1+ acc) :max three :commitp t) #\a #\,)) #\,)
+ n))))
+
+(def-test-method test-alternate ((test test-parser) :run nil)
+
+ ;; An `or' matches the first parser that either succeeds or fails having
+ ;; consumed input.
+ (assert-parse ("abcd" #\a t t) (or #\a #\b))
+ (assert-parse ("abcd" #\a t t) (or #\b #\a))
+ (assert-parse ("abcd" '(#\b #\c) nil nil) (or #\b #\c))
+
+ ;; Strings don't consume if they fail.
+ (assert-parse ("abcd" "ab" t t) (or "cd" "ab"))
+ (assert-parse ("abcd" "ab" t t) (or "ad" "ab"))
+ (assert-parse ("abcd" '("ad" "ac") nil nil) (or "ad" "ac"))
+
+ ;; But `seq' will if some component consumes.
+ (assert-parse ("abcd" '(#\d) nil t) (or (and #\a #\d) "ab"))
+ (assert-parse ("abcd" "ab" t t) (or (and #\c #\d) "ab"))
+
+ ;; We can tame this using `peek' which rewinds the source if its argument
+ ;; fails, so as to hide consumption of input.
+ (assert-parse ("abcd" "ab" t t) (or (peek (and #\a #\d)) "ab"))
+ (assert-parse ("abcd" '(#\a #\b "cd") t t)
+ (seq ((foo (peek (seq ((foo #\a) (bar #\b)) (list foo bar))))
+ (bar "cd"))
+ (append foo (list bar))))
+
+ ;; Failure indicators are union'd if they all fail.
+ (assert-parse ("abcd" '(#\q #\x #\z) nil nil)
+ (or #\q (peek (and #\a (or #\x #\q))) #\z))
+
+ ;; But if any of them consumed input then you only get the indicators from
+ ;; the consuming branch, because we committed to it when we consumed the
+ ;; input.
+ (assert-parse ("abcd" '(#\x #\q) nil t)
+ (or #\q #\z (and #\a (or #\q #\x)))))
+
+;;;--------------------------------------------------------------------------
+;;; Some tests with a simple recursive parser.
+
+(defstruct (node
+ (:predicate nodep)
+ (:constructor make-node (left data right)))
+ "Structure type for a simple binary tree."
+ left data right)
+
+(defun parse-tree (scanner)
+ "Parse a textual representation into a simple binary tree.
+
+ The syntax is simple:
+
+ TREE ::= EMPTY | `(' TREE CHAR TREE `)'
+
+ There's an ambiguity in this syntax, at least if you have limited
+ lookahead: suppose you've just parsed the opening `(' of a TREE, and you
+ see another `(' -- is it the start of the non-empty left sub-TREE, or is
+ it the CHAR following an empty left sub-TREE? We opt for the first choice
+ always."
+
+ ;; This came from another project, although it isn't actually used there.
+ ;; It exposed the weakness in an earlier design which prompted the addition
+ ;; of the CONSUMEDP flags to the parser protocol.
+
+ (with-parser-context (character-scanner-context :scanner scanner)
+ (labels ((tree ()
+ (parse (or (seq (#\(
+ (left (tree))
+ (data :any)
+ (right (tree))
+ #\))
+ (make-node left data right))
+ (values nil t nil)))))
+ (parse (seq ((tree (tree)) :eof)
+ tree)))))
+
+(defun parse-tree-lookahead (scanner)
+ "Parse a textual representation into a simple binary tree.
+
+ The syntax is simple, and, indeed, the grammar's the same as for
+ `sod-parse-tree':
+
+ TREE ::= EMPTY | `(' TREE CHAR TREE `)'
+
+ But the rules are different. Instead of resolving the `ambiguity' between
+ TREE and CHAR when we find another `(' after the opening `(' of a TREE
+ deterministically in favour of TREE as `parse-tree' does, we try that
+ first, and backtrack if necessary."
+
+ ;; Bison can do this, but you have to persuade it to use the scary GLR
+ ;; parser algorithm
+
+ (with-parser-context (character-scanner-context :scanner scanner)
+ (labels ((tree ()
+ (parse (or (peek (seq (#\(
+ (left (tree))
+ (data :any)
+ (right (tree))
+ #\))
+ (make-node left data right)))
+ (values nil t nil)))))
+ (parse (seq ((tree (tree)) :eof)
+ tree)))))
+
+(def-test-method test-simple-tree-parser ((test test-parser) :run nil)
+ (assert-parse ("" nil t nil :scanner sc) (parse-tree sc))
+ (assert-parse ("((a)b((c)d(e)))" t t t :scanner sc) (parse-tree sc))
+ (assert-parse ("((a)b((c)d(e)))z" '(:eof) nil t :scanner sc)
+ (parse-tree sc))
+ (assert-parse ("((a)b((c)d(e))" '(#\)) nil t :scanner sc) (parse-tree sc))
+ (assert-parse ("(([)*(]))" t t t :scanner sc) (parse-tree sc))
+ (assert-parse ("((()-()))" '(#\)) nil t :scanner sc) (parse-tree sc))
+ (assert-parse ("((()-()))" t t t :scanner sc) (parse-tree-lookahead sc)))
+
+;;;--------------------------------------------------------------------------
+;;; Test expression parser.
+
+(defparse token (:context (context character-parser-context) parser)
+ (with-gensyms (value)
+ (expand-parser-spec context
+ `(seq ((,value ,parser) :whitespace) ,value))))
+
+(let ((add (binop "+" (x y 5) `(+ ,x ,y)))
+ (sub (binop "-" (x y 5) `(- ,x ,y)))
+ (mul (binop "*" (x y 7) `(* ,x ,y)))
+ (div (binop "/" (x y 7) `(/ ,x ,y)))
+ (eq (binop "=" (x y 3 :assoc nil) `(= ,x ,y)))
+ (ne (binop "/=" (x y 3 :assoc nil) `(/= ,x ,y)))
+ (lt (binop "<" (x y 3 :assoc nil) `(< ,x ,y)))
+ (gt (binop ">" (x y 3 :assoc nil) `(> ,x ,y)))
+ (and (binop "&" (x y 2) `(and ,x ,y)))
+ (or (binop "|" (x y 1) `(or ,x ,y)))
+ (expt (binop "**" (x y 8 :assoc :right) `(** ,x ,y)))
+ (neg (preop "-" (x 9) `(- ,x)))
+ (not (preop "!" (x 2) `(not ,x)))
+ (fact (postop "!" (x 10) `(! ,x)))
+ (lp (lparen #\))) (rp (rparen #\)))
+ (lb (lparen #\])) (rb (rparen #\])))
+ (defun test-parse-expr (string)
+ (with-parser-context (string-parser :string string)
+ (parse (seq (:whitespace
+ (value (expr (:nestedp nestedp)
+ (token (many (a 0 (+ (* a 10) it) :min 1)
+ (filter digit-char-p)))
+ (token (or (seq ("**") expt)
+ (seq ("/=") ne)
+ (seq (#\+) add)
+ (seq (#\-) sub)
+ (seq (#\*) mul)
+ (seq (#\/) div)
+ (seq (#\=) eq)
+ (seq (#\<) lt)
+ (seq (#\>) gt)
+ (seq (#\&) and)
+ (seq (#\|) or)))
+ (token (or (seq (#\() lp)
+ (seq (#\-) neg)
+ (seq (#\!) not)))
+ (token (or (seq (#\!) fact)
+ (when nestedp (seq (#\)) rp))))))
+ (next (or :any (t :eof))))
+ (cons value next))))))
+
+(defun assert-expr-parse (string value winp consumedp)
+ (multiple-value-bind (v w c) (test-parse-expr string)
+ (flet ((message (what)
+ (format nil "expression ~S; ~A" string what)))
+ (cond (winp (assert-true w (message "winp"))
+ (assert-equal v value (message "value")))
+ (t (assert-false w (message "winp"))
+ (assert-equal v value (message "expected"))))
+ (assert-eql c consumedp (message "consumedp")))))
+
+(def-test-method test-expression-parser ((test test-parser) :run nil)
+ (assert-expr-parse "1 + 2 + 3" '((+ (+ 1 2) 3) . :eof) t t)
+ (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t)
+ (assert-expr-parse "1 * 2 + 3" '((+ (* 1 2) 3) . :eof) t t)
+ (assert-expr-parse "(1 + 2) * 3" '((* (+ 1 2) 3) . :eof) t t)
+ (assert-expr-parse "1 ** 2 ** 3" '((** 1 (** 2 3)) . :eof) t t)
+ (assert-expr-parse "1 + 2) * 3" '((+ 1 2) . #\)) t t)
+ (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t)
+
+ (assert-expr-parse "! 1 + 2 = 3 | 6 - 3 /= 12/6"
+ '((or (not (= (+ 1 2) 3))
+ (/= (- 6 3) (/ 12 6)))
+ . :eof)
+ t t)
+ (assert-expr-parse "! 1 > 2 & ! 4 < 6 | 3 < 4 & 9 > 10"
+ '((or (and (not (> 1 2)) (not (< 4 6)))
+ (and (< 3 4) (> 9 10)))
+ . :eof)
+ t t)
+
+ (assert-condition 'simple-error (test-parse-expr "(1 + 2"))
+ (assert-condition 'simple-error (test-parse-expr "(1 + 2]"))
+ (assert-condition 'simple-error (test-parse-expr "1 < 2 < 3")))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Test for the charbuf scanner
+;;;
+;;; (c) 2009 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.
+
+;;; The charbuf scanner is a hairy beast and in need of a thorough going
+;;; over.
+
+(cl:in-package #:sod-test)
+
+;;;--------------------------------------------------------------------------
+;;; Tests of the low-level seeking and fetching machinery.
+
+(defclass charbuf-test (test-case) (scanner))
+(add-test *sod-test-suite* (get-suite charbuf-test))
+
+(defparameter *background-pattern*
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789."
+ "Basic pattern underlying our initial buffer contents.
+
+ The pattern is one character short of the base-64 sequence `A-Za-z0-9./',
+ with the aim of making its length be prime to the actual buffer length --
+ so that the pattern doesn't repeat exactly for many buffers.")
+(assert (= (gcd (length *background-pattern*) charbuf-size) 1))
+
+(defun make-pattern-string (start end)
+ "Return a string containing the buffer pattern between START and END.
+
+ The most interesting cases occur at the boundaries between buffers; so we
+ shall want to put recognizable patterns there. The buffers are quite big
+ (we import `charbuf-size' off the books so that we don't actually have to
+ know exactly) but we should still fill with a repeating pattern so that we
+ can detect synchronization failures.
+
+ We fill most of the buffer with the `*background-pattern*', which has been
+ chosen so as not to align nicely with the buffer size. Across the joins,
+ we write a string `<<N][N+1>>', where the boundary is between `]' and `[',
+ and the numbers N and N + 1 are the numbers, in words, of the respective
+ buffers."
+
+ (with-output-to-string (out)
+ (multiple-value-bind (n0 i0) (floor start charbuf-size)
+ (multiple-value-bind (n1 i1) (floor end charbuf-size)
+
+ (do ((n n0 (1+ n))) ((> n n1))
+ (let* ((l (format nil "[~R>>" n))
+ (r (format nil "<<~R]" n))
+ (m (length l))
+ (q (length *background-pattern*))
+ (i (if (= n n0) i0 0))
+ (e (if (= n n1) i1 charbuf-size))
+ (k (min (- charbuf-size m) e)))
+ (when (< i (length l))
+ (write-string l out :start i :end (min e m))
+ (setf i m))
+ (do ((o (mod (+ (* charbuf-size n) i) q) 0))
+ ((>= i k))
+ (let ((p (min (- k i) (- q o))))
+ (write-string *background-pattern* out :start o :end (+ o p))
+ (incf i p)))
+ (when (< k e)
+ (write-string r out :start (- i k) :end (- e k)))))))))
+
+(defparameter *test-pattern* (make-pattern-string 0 10000)
+ "The pattern that our test scanner is reading.")
+
+(defmethod set-up ((test charbuf-test))
+ (with-slots (scanner) test
+ (let ((stream (make-string-input-stream *test-pattern*)))
+ (setf scanner (make-instance 'charbuf-scanner
+ :stream stream
+ :filename "<magic test>")))))
+
+(defun skip (scanner n)
+ (assert (>= n 0))
+ (charbuf-scanner-map scanner
+ (lambda (buf start end)
+ (declare (ignore buf))
+ (let ((d (- end start)))
+ (if (>= d n)
+ (values t (+ start n))
+ (progn (decf n d) (values nil 0)))))))
+
+(defun assert-string-next (scanner pos len)
+ "Assert that the next LEN characters from SCANNER are correct.
+
+ That is, that they match the corresponding LEN characters starting at
+ position POS as returned by `make-pattern-string'."
+ (let ((want (make-pattern-string pos (+ pos len))))
+ (dotimes (i len)
+ (assert-false (scanner-at-eof-p scanner))
+ (assert-eql (scanner-current-char scanner) (char want i))
+ (scanner-step scanner))))
+
+(def-test-method test-pattern ((test charbuf-test) :run nil)
+ ;; Make sure the pattern is what we expect. This is a completely different
+ ;; (and considerably more stupid) way of generating the basic pattern up to
+ ;; a particular length.
+ (let* ((len (length *background-pattern*))
+ (string ""))
+ (loop while (< (length string) len)
+ do (setf string (concatenate 'string string *test-pattern*)))
+ (loop for n from 0
+ for i from 0 by charbuf-size below len
+ for l = (format nil "[~R>>" n) and r = (format nil "<<~R]" n)
+ for e = (- (+ i charbuf-size) (length r))
+ do (setf (subseq string i) l)
+ when (< e len) do (setf (subseq string e) r))
+ (assert-equal (subseq string 0 len)
+ (make-pattern-string 0 len))))
+
+(def-test-method test-read ((test charbuf-test) :run nil)
+ ;; Test reading from various places.
+ (with-slots (scanner) test
+ (loop for prev = 0 then (+ pos len)
+ for (pos len) in '((0 10) (50 250) (4086 20)
+ (5000 3192) (9800 200)) do
+ (assert (>= pos prev))
+ (skip scanner (- pos prev))
+ (assert-string-next scanner pos len))
+ (assert-true (scanner-at-eof-p scanner))))
+
+(def-test-method test-unread ((test charbuf-test) :run nil)
+ ;; Torture test for `scanner-unread', which is distressingly hairy.
+ (with-slots (scanner) test
+
+ (flet ((test (here next skip there note)
+ (assert-eql (scanner-current-char scanner) here
+ (format nil "Here (~A)." note))
+ (scanner-step scanner)
+ (assert-eql (scanner-current-char scanner) next
+ (format nil "Next (~A)." note))
+ (scanner-unread scanner here)
+ (with-scanner-place (place scanner)
+ (assert-eql (scanner-current-char scanner) here
+ (format nil "Here again (~A)." note))
+ (scanner-step scanner)
+ (assert-eql (scanner-current-char scanner) next
+ (format nil "Next again (~A)." note))
+ (skip scanner skip)
+ (assert-eql (scanner-current-char scanner) there
+ (format nil "There (~A)." note))
+ (scanner-unread scanner there)
+ (with-scanner-place (another-place scanner)
+ (scanner-restore-place scanner place)
+ (assert-eql (scanner-current-char scanner) here
+ (format nil "Here restored (~A)." note))))))
+
+ (test #\[ #\z 51 #\0 "start")
+ (skip scanner 4095)
+ (test #\] #\[ 4096 #\[ "edge")
+
+ ;; Check behaviour at EOF. Ought to test behaviour when EOF is on a
+ ;; buffer boundary too.
+ (skip scanner 5904)
+ (assert-false (scanner-at-eof-p scanner))
+ (assert-eql (scanner-current-char scanner) #\t "EOF.")
+ (scanner-step scanner)
+ (assert-true (scanner-at-eof-p scanner))
+ (scanner-unread scanner #\t)
+ (assert-false (scanner-at-eof-p scanner))
+ (assert-eql (scanner-current-char scanner) #\t "EOF again."))))
+
+(def-test-method test-rewind ((test charbuf-test) :run nil)
+ ;; Test reading, like before, but this time with rewinding.
+ (with-slots (scanner) test
+ (let* ((list '((0 10) (0 10000) (50 250) (4086 20)
+ (4095 4097) (5000 3192) (9999 1)))
+ (places (loop for prev = 0 then pos
+ for (pos) in list
+ do (skip scanner (- pos prev))
+ collect (scanner-capture-place scanner))))
+ (loop for (pos len) in list
+ for place in places do
+ (scanner-restore-place scanner place)
+ (assert-string-next scanner pos len))
+ (assert-true (scanner-at-eof-p scanner)))))
+
+(def-test-method test-interval ((test charbuf-test) :run nil)
+ ;; Test fetching intervals of text.
+ (with-slots (scanner) test
+ (let* ((posns '(0 12 4080 4110 5000 9000 10000))
+ (places (loop for prev = 0 then pos
+ for pos in posns
+ do (skip scanner (- pos prev))
+ collect (scanner-capture-place scanner))))
+ (loop for p0 in places
+ for i0 in posns do
+ (loop for p1 in places
+ for i1 in posns do
+ (if (< i1 i0)
+ (assert-condition 'error (scanner-interval p0 p1))
+ (assert-equal (scanner-interval scanner p0 p1)
+ (make-pattern-string i0 i1)
+ (format nil "Mismatch interval ~A .. ~A."
+ i0 i1)))
+ (assert-true (scanner-at-eof-p scanner)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Tests of the position tracking machinery.
+
+(defparameter *position-test-text*
+ ;; Use a roundabout method of getting tabs in there, so that they don't get
+ ;; screwed by strange editors and suchlike.
+ (substitute #\tab #\@ "Line one
+Line two is rather longer, but not noticeably more interesting.
+Line three explains that line four contains column numbers mod 10.
+012345678@6789@@2345678@012
+@@Line five is indented somewhat.")
+ "Text for the position-tracking test.
+
+ The text should /look/ like the following. Note that this text here may
+ get trashed by tab/space conversions and whatever, and I've indented it so
+ that it doesn't look daft in the source; but the columns should remain
+ where they are.
+
+ 0 1 2 3 4 5 6 7
+ 0123456789012345678901234567890123456789012345678901234567890123456789012
+ Line one
+ Line two is rather longer, but not noticeably more interesting.
+ Line three explains that line four contains column numbers mod 10.
+ 012345678 6789 2345678 012
+ Line five is indented somewhat.
+
+ It would be nice at some point to add additional tests for edge cases
+ around buffer boundaries. This isn't completely essential, though: the
+ current implementation manages positions fairly independently of the
+ buffering.")
+
+(defparameter *known-positions*
+ '(
+ ;; The first few line aren't actually very interesting. We'll
+ ;; check the start and end positions, and maybe a few in the
+ ;; middle. Note that a newline character is logically a part of
+ ;; the preceding line.
+ (0 #\L 1 0 #\i 1 1 0) (5 #\o 1 5 #\n 1 6 5) (8 #\newline 1 8 #\L 2 0 0)
+ (9 #\L 2 0 #\i 2 1 0) (72 #\newline 2 63 #\L 3 0 0)
+ (73 #\L 3 0 #\i 3 1 0) (139 #\newline 3 66 #\0 4 0 0)
+
+ ;; Now for the line with the fancy tabbings.
+ (140 #\0 4 0 #\1 4 1 0)
+ (148 #\8 4 8 #\tab 4 9 8) ; nothing so far
+ (149 #\tab 4 9 #\6 4 16 15) ; the tab itself just follows on
+ (150 #\6 4 16 #\7 4 17 16) ; but the char after is tabbed
+ (154 #\tab 4 20 #\tab 4 24 23) ; next tab position
+ (155 #\tab 4 24 #\2 4 32 31) ; two in a row
+ (156 #\2 4 32 #\3 4 33 32) ; should be here now
+ (162 #\8 4 38 #\tab 4 39 38) ; skip to the next bit
+ (163 #\tab 4 39 #\0 4 40 39) ; tab is here
+ (164 #\0 4 40 #\1 4 41 40) ; and doesn't move us much
+ (166 #\2 4 42 #\newline 4 43 42) ; last actual character on the line
+ (167 #\newline 4 43 #\tab 5 0 0) ; and the ending newline
+
+ ;; And the final line.
+ (168 #\tab 5 0 #\tab 5 8 7) ; first tab on next line
+ (169 #\tab 5 8 #\L 5 16 15) ; and the second
+ (170 #\L 5 16 #\i 5 17 16) ; beginning of the text
+ (200 #\. 5 46 :eof 5 47 46) ; last character in the stream
+ (201 :eof 5 47)) ; but eof has a position too
+ "List of character positions, characters and line/column numbers.
+
+ The characters are there for sanity-checking purposes. The format is
+
+ (INDEX CHAR LINE COLUMN NEXT-CHAR
+ NEXT-LINE NEXT-COLUMN REWIND-COLUMN)
+
+ which asserts that the character at INDEX is CHAR, found at the given LINE
+ and COLUMN, that the next character is NEXT-CHAR, at the NEXT-LINE and
+ NEXT-COLUMN, and if one unreads from there, it will be (possibly
+ erroneously) claimed that the character at INDEX is at REWIND-COLUMN.
+ (Restoring a captured place shouldn't get the column wrong -- only
+ unreading.)
+
+ The symbol `:eof' means that there is no character at the given INDEX,
+ because the file has already ended. However, EOF has a position which
+ should be correct, and it should be possible to unread from EOF.")
+
+(defclass charbuf-position-test (test-case) (scanner))
+(add-test *sod-test-suite* (get-suite charbuf-position-test))
+
+(defmethod set-up ((test charbuf-position-test))
+ (with-slots (scanner) test
+ (let ((stream (make-string-input-stream *position-test-text*)))
+ (setf scanner (make-instance 'charbuf-scanner
+ :stream stream
+ :filename "<position test>")))))
+
+(defun check-position (scanner pos char line column note)
+ (if (eq char :eof)
+ (assert-true (scanner-at-eof-p scanner)
+ (format nil "EOF, position ~A (~A)." pos note))
+ (assert-eql char (scanner-current-char scanner)
+ (format nil "Character, position ~A (~A)." pos note)))
+ (assert-eql line (scanner-line scanner)
+ (format nil "Line number, position ~A (~A)." pos note))
+ (assert-eql column (scanner-column scanner)
+ (format nil "Column number, position ~A (~A)." pos note)))
+
+(def-test-method test-simple-positions
+ ((test charbuf-position-test) :run nil)
+ (with-slots (scanner) test
+ (loop for prev = 0 then pos
+ for (pos char line column) in *known-positions* do
+ (loop repeat (- pos prev) do (scanner-step scanner))
+ (check-position scanner pos char line column "simple"))))
+
+(def-test-method test-rewind-positions
+ ((test charbuf-position-test) :run nil)
+ (with-slots (scanner) test
+ (let ((places (loop for prev = 0 then pos
+ for (pos char line column) in *known-positions* do
+ (skip scanner (- pos prev))
+ (check-position scanner pos char line column "skip")
+ collect (scanner-capture-place scanner))))
+ (loop for place in places
+ for (pos char line column
+ next-char next-line next-column
+ rewind-column)
+ in *known-positions* do
+ (scanner-restore-place scanner place)
+ (check-position scanner pos char line column "rewind")
+ (unless (eq char :eof)
+ (scanner-step scanner)
+ (check-position scanner (1+ pos) next-char
+ next-line next-column "step")
+ (scanner-unread scanner char)
+ (check-position scanner pos char line rewind-column
+ "unread")
+ (scanner-step scanner)
+ (check-position scanner (1+ pos) next-char
+ next-line next-column "restep"))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for C type representation
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Root classes and common access protocol.
+
+;; It seems more useful to put the root class here, so that we can provide
+;; methods specialized on it, e.g., PRINT-OBJECT.
+
+(export 'c-type)
+(defclass c-type ()
+ ()
+ (:documentation
+ "Base class for C type objects."))
+
+(export '(qualifiable-c-type c-type-qualifiers))
+(defclass qualifiable-c-type (c-type)
+ ((qualifiers :initarg :qualifiers :initform nil
+ :type list :reader c-type-qualifiers))
+ (:documentation
+ "Base class for C types which can be qualified."))
+
+(export 'canonify-qualifiers)
+(defun canonify-qualifiers (qualifiers)
+ "Return a canonical list of qualifiers."
+ (delete-duplicates (sort (copy-list qualifiers) #'string<)))
+
+(export 'c-type-subtype)
+(defgeneric c-type-subtype (type)
+ (:documentation
+ "For compound types, return the base type."))
+
+;;;--------------------------------------------------------------------------
+;;; Comparison protocol.
+
+(export 'c-type-equal-p)
+(defgeneric c-type-equal-p (type-a type-b)
+ (:method-combination and)
+ (:documentation
+ "Answers whether two types TYPE-A and TYPE-B are structurally equal.
+
+ Here, `structurally equal' means that they have the same qualifiers,
+ similarly spelt names, and structurally equal components.")
+ (:method and (type-a type-b)
+ (eql (class-of type-a) (class-of type-b))))
+
+(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
+ (type-b qualifiable-c-type))
+ (equal (canonify-qualifiers (c-type-qualifiers type-a))
+ (canonify-qualifiers (c-type-qualifiers type-b))))
+
+;;;--------------------------------------------------------------------------
+;;; C syntax output protocol.
+
+(export 'pprint-c-type)
+(defgeneric pprint-c-type (type stream kernel)
+ (:documentation
+ "Pretty-printer for C types.
+
+ Print TYPE to STREAM. In the middle of the declarator, call the function
+ KERNEL with one argument: whether it needs a leading space.")
+ (:method :around (type stream kernel)
+ (typecase kernel
+ (null (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore stream prio spacep))
+ nil)))
+ ((or function symbol) (call-next-method))
+ (t (pprint-c-type type stream
+ (lambda (stream prio spacep)
+ (declare (ignore prio))
+ (when spacep
+ (c-type-space stream))
+ (princ kernel stream)))))))
+
+(export 'c-type-space)
+(defun c-type-space (stream)
+ "Print a space and a miser-mode newline to STREAM.
+
+ This is the right function to call in a PPRINT-C-TYPE kernel function when
+ the SPACEP argument is true."
+ (pprint-indent :block 2 stream)
+ (write-char #\space stream)
+ (pprint-newline :miser stream))
+
+(defun maybe-in-parens* (stream condition thunk)
+ "Helper function for the MAYBE-IN-PARENS macro."
+ (multiple-value-bind (prefix suffix)
+ (if condition (values "(" ")") (values "" ""))
+ (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
+ (funcall thunk stream))))
+
+(export 'maybe-in-parens)
+(defmacro maybe-in-parens ((stream condition) &body body)
+ "Evaluate BODY; if CONDITION, write parens to STREAM around it.
+
+ This macro is useful for implementing the PPRINT-C-TYPE method on compound
+ types. The BODY is evaluated in the context of a logical block printing
+ to STREAM. If CONDITION is non-nil, then the block will have open/close
+ parens as its prefix and suffix; otherwise they will be empty.
+
+ The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
+ `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))
+
+(export 'format-qualifiers)
+(defun format-qualifiers (quals)
+ "Return a string listing QUALS, with a space after each."
+ (format nil "~{~(~A~) ~}" quals))
+
+;;;--------------------------------------------------------------------------
+;;; S-expression notation protocol.
+
+(export 'print-c-type)
+(defgeneric print-c-type (stream type &optional colon atsign)
+ (:documentation
+ "Print an abbreviated syntax for TYPE to the STREAM.
+
+ This function is suitable for use in FORMAT's ~/.../ command."))
+
+(export 'expand-c-type-spec)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defgeneric expand-c-type-spec (spec)
+ (:documentation
+ "Expand SPEC into Lisp code to construct a C type.")
+ (:method ((spec list))
+ (expand-c-type-form (car spec) (cdr spec))))
+ (defgeneric expand-c-type-form (head tail)
+ (:documentation
+ "Expand a C type list beginning with HEAD.")
+ (:method ((name (eql 'lisp)) tail)
+ `(progn ,@tail))))
+
+(export 'c-type)
+(defmacro c-type (spec)
+ "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
+ (expand-c-type-spec spec))
+
+(export 'define-c-type-syntax)
+(defmacro define-c-type-syntax (name bvl &rest body)
+ "Define a C-type syntax function.
+
+ A function defined by BODY and with lambda-list BVL is associated with the
+ NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
+ function with the argument list STUFF."
+ (with-gensyms (head tail)
+ (multiple-value-bind (doc decls body) (parse-body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
+ ,@doc
+ (destructuring-bind ,bvl ,tail
+ ,@decls
+ ,@body))
+ ',name))))
+
+(export 'c-type-alias)
+(defmacro c-type-alias (original &rest aliases)
+ "Make ALIASES behave the same way as the ORIGINAL type."
+ (with-gensyms (head tail)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (alias)
+ `(defmethod expand-c-type-form
+ ((,head (eql ',alias)) ,tail)
+ (expand-c-type-form ',original ,tail)))
+ aliases)
+ ',aliases)))
+
+(export 'defctype)
+(defmacro defctype (names value)
+ "Define NAMES all to describe the C-type VALUE.
+
+ NAMES can be a symbol (treated as a singleton list), or a list of symbols.
+ The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will
+ be expanded once at run-time."
+ (let* ((names (if (listp names) names (list names)))
+ (namevar (gensym "NAME"))
+ (typevar (symbolicate 'c-type- (car names))))
+ `(progn
+ (defparameter ,typevar ,(expand-c-type-spec value))
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ ,@(mapcar (lambda (name)
+ `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
+ ',typevar))
+ names))
+ 'names)))
+
+(export 'c-name-case)
+(defun c-name-case (name)
+ "Convert NAME to suitable case.
+
+ Strings are returned as-is; symbols are squashed to lower-case and hyphens
+ are replaced by underscores."
+ (typecase name
+ (symbol (with-output-to-string (out)
+ (loop for ch across (symbol-name name)
+ do (cond ((alpha-char-p ch)
+ (write-char (char-downcase ch) out))
+ ((or (digit-char-p ch)
+ (char= ch #\_))
+ (write-char ch out))
+ ((char= ch #\-)
+ (write-char #\_ out))
+ (t
+ (error "Bad character in C name ~S." name))))))
+ (t name)))
+
+;;;--------------------------------------------------------------------------
+;;; Function arguments.
+
+(export '(argument argumentp make-argument argument-name argument-type))
+(defstruct (argument (:constructor make-argument (name type))
+ (:predicate argumentp))
+ "Simple structure representing a function argument."
+ name
+ type)
+
+(export 'commentify-argument-name)
+(defgeneric commentify-argument-name (name)
+ (:documentation
+ "Produce a `commentified' version of the argument.
+
+ The default behaviour is that temporary argument names are simply omitted
+ (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
+ printable representation of the argument.")
+ (:method ((name null)) nil)
+ (:method ((name t)) (format nil "/*~A*/" name)))
+
+;;;--------------------------------------------------------------------------
+;;; Printing objects.
+
+(defmethod print-object ((object c-type) stream)
+ (if *print-escape*
+ (format stream "~:@<C-TYPE ~/sod:print-c-type/~:>" object)
+ (pprint-c-type object stream nil)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class finalization protocol
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Protocol definition.
+
+(defgeneric compute-cpl (class)
+ (:documentation
+ "Returns the class precedence list for CLASS."))
+
+(defgeneric compute-chains (class)
+ (:documentation
+ "Compute the layout chains for CLASS.
+
+ Returns the following three values.
+
+ * the head of the class's primary chain;
+
+ * the class's primary chain as a list, most- to least-specific; and
+
+ * the complete collection of chains, as a list of lists, each most- to
+ least-specific, with the primary chain first.
+
+ These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots.
+
+ If the chains are ill-formed (i.e., not distinct) then an error is
+ signalled."))
+
+(defgeneric check-sod-class (class)
+ (:documentation
+ "Check the CLASS for validity.
+
+ This is done as part of class finalization. The checks performed are as
+ follows.
+
+ * The class name and nickname, and the names of messages, obey the
+ rules (see VALID-NAME-P).
+
+ * The messages and slots have distinct names.
+
+ * The classes in the class-precedence-list have distinct nicknames.
+
+ * The chain-link is actually a proper (though not necessarily direct)
+ superclass.
+
+ * The chosen metaclass is actually a subclass of all of the
+ superclasses' metaclasses.
+
+ Returns true if all is well; false (and signals errors) if anything was
+ wrong."))
+
+(defgeneric finalize-sod-class (class)
+ (:documentation
+ "Computes all of the gory details about a class.
+
+ Once one has stopped inserting methods and slots and so on into a class,
+ one needs to finalize it to determine the layout structure and the class
+ precedence list and so on. More precisely that gets done is this:
+
+ * Related classes (i.e., direct superclasses and the metaclass) are
+ finalized if they haven't been already.
+
+ * If you've been naughty and failed to store a list of slots or
+ whatever, then an empty list is inserted.
+
+ * The class precedence list is computed and stored.
+
+ * The class is checked for compiance with the well-formedness rules.
+
+ * The layout chains are computed."))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class layout protocol
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Effective slot objects.
+
+(export '(effective-slot effective-slot-class
+ effective-slot-direct-slot effective-slot-initializer))
+(defclass effective-slot ()
+ ((class :initarg :class :type sod-slot :reader effective-slot-class)
+ (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
+ (initializer :initarg :initializer :type (or sod-initializer null)
+ :reader effective-slot-initializer))
+ (:documentation
+ "Describes a slot and how it's meant to be initialized.
+
+ Specifically, an effective slot object states that in an instance of
+ CLASS, a particular SLOT is initializd by a particular INITIALIZER. Note
+ that the CLASS is a subclass of the SLOT's defining class, and not
+ necessarily the same.
+
+ Effective slot objects are usually found in `islots' objects."))
+
+(export 'find-slot-initializer)
+(defgeneric find-slot-initializer (class slot)
+ (:documentation
+ "Return the most specific initializer for SLOT, starting from CLASS."))
+
+(export 'compute-effective-slot)
+(defgeneric compute-effective-slot (class slot)
+ (:documentation
+ "Construct an effective slot from the supplied direct slot.
+
+ SLOT is a direct slot defined on CLASS or one of its superclasses.
+ (Metaclass initializers are handled using a different mechanism.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Instance layout.
+
+;;; islots
+
+(export '(islots islots-class islots-subclass islots-slots))
+(defclass islots ()
+ ((class :initarg :class :type sod-class :reader islots-class)
+ (subclass :initarg :subclass :type sod-class :reader islots-subclass)
+ (slots :initarg :slots :type list :reader islots-slots))
+ (:documentation
+ "Contains effective slot definitions for a class's direct slots.
+
+ In detail: SLOTS is a list of effective slot objects corresponding to
+ CLASS's direct slots, and containing initializers computed relative to
+ SUBCLASS."))
+
+(export 'compute-islots)
+(defgeneric compute-islots (class subclass)
+ (:documentation
+ "Return `islots' for a particular CLASS and SUBCLASS.
+
+ Initializers for the slots should be taken from the most specific
+ superclass of SUBCLASS."))
+
+;;; vtable-pointer
+
+(export '(vtable-pointer vtable-pointer-class
+ vtable-pointer-chain-head vtable-pointer-chain-tail))
+(defclass vtable-pointer ()
+ ((class :initarg :class :type sod-class :reader vtable-pointer-class)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader vtable-pointer-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtable-pointer-chain-tail))
+ (:documentation
+ "Represents a pointer to a class's vtable.
+
+ There's one of these for each of CLASS's chains. This particular one
+ belongs to the chain headed by CHAIN-HEAD; the most specific superclass of
+ CLASS on that chain is CHAIN-TAIL. (The tail is useful because we can --
+ and do -- use structure types defined by the tail class for non-primary
+ chains.)"))
+
+;;; ichain
+
+(export '(ichain ichain-class ichain-head ichain-tail ichain-body))
+(defclass ichain ()
+ ((class :initarg :class :type sod-class :reader ichain-class)
+ (chain-head :initarg :chain-head :type sod-class :reader ichain-head)
+ (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail)
+ (body :initarg :body :type list :reader ichain-body))
+ (:documentation
+ "Contains instance data for a particular chain of superclasses.
+
+ In detail: describes instance data for one of CLASS's chains, specifically
+ the chain headed by CHAIN-HEAD. The CHAIN-TAIL is the most specific
+ superclass of CLASS on the chain in question. The BODY is a list of
+ layout objects to be included.
+
+ An `ilayout' object maintains a list of `ichain' objects, one for each of
+ a class's chains."))
+
+(export 'compute-ichain)
+(defgeneric compute-ichain (class chain)
+ (:documentation
+ "Return an ICHAIN for a particular CHAIN of CLASS's superclasses.
+
+ The CHAIN is a list of classes, with the least specific first -- so the
+ chain head is the first element."))
+
+;;; ilayout
+
+(export '(ilayout ilayout-class ilayout-ichains))
+(defclass ilayout ()
+ ((class :initarg :class :type sod-class :reader ilayout-class)
+ (ichains :initarg :ichains :type list :reader ilayout-ichains))
+ (:documentation
+ "All of the instance layout for a class.
+
+ Describes the layout of an instance of CLASS. The list ICHAINS contains
+ an `ichain' object for each chain of CLASS."))
+
+(export 'compute-ilayout)
+(defgeneric compute-ilayout (class)
+ (:documentation
+ "Compute and return an instance layout for CLASS."))
+
+;;;--------------------------------------------------------------------------
+;;; Vtable layout.
+
+;;; vtmsgs
+
+(defclass vtmsgs ()
+ ((class :initarg :class :type sod-class :reader vtmsgs-class)
+ (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader vtmsgs-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtmsgs-chain-tail)
+ (entries :initarg :entries :type list :reader vtmsgs-entries))
+ (:documentation
+ "The message dispatch table for a particular class.
+
+ In detail, this lists the `method-entry' objects for the messages defined
+ by a particular CLASS, where the effective methods are specialized for the
+ SUBCLASS; the method entries adjust the instance pointer argument
+ appropriately for a call via the vtable for the chain headed by
+ CHAIN-HEAD. The CHAIN-TAIL is the most specific superclass of SUBCLASS on
+ this chain. The ENTRIES are a list of `method-entry' objects."))
+
+(export 'compte-vtmsgs)
+(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
+ (:documentation
+ "Return a VTMSGS object containing method entries for CLASS.
+
+ The CHAIN-HEAD describes which chain the method entries should be
+ constructed for.
+
+ The default method simply calls MAKE-METHOD-ENTRY for each of the methods
+ and wraps a VTMSGS object around them. This ought to be enough for almost
+ all purposes."))
+
+;;; class-pointer
+
+(export '(class-pointer class-pointer-class class-pointer-chain-head
+ class-pointer-metaclass class-pointer-meta-chain-head))
+(defclass class-pointer ()
+ ((class :initarg :class :type sod-class :reader class-pointer-class)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader class-pointer-chain-head)
+ (metaclass :initarg :metaclass :type sod-class
+ :reader class-pointer-metaclass)
+ (meta-chain-head :initarg :meta-chain-head :type sod-class
+ :reader class-pointer-meta-chain-head))
+ (:documentation
+ "Represents a pointer to a class object for the instance's class.
+
+ This is somewhat complicated because there are two degrees of freedom. An
+ instance of `class-pointer' is a pointer from a vtable to an `ichain' of
+ the the class's metaclass instance. In particular, `class-pointer'
+ instance represents a pointer in a vtable constructed for CLASS and
+ attached to the chain headed by CHAIN-HEAD; it points to an instance of
+ METACLASS, and specifically to the `ichain' substructure corresponding to
+ the chain headed by META-CHAIN-HEAD, which will be a superclass of
+ METACLASS.
+
+ I'm sorry if this is confusing."))
+
+(export 'make-class-pointer)
+(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head)
+ (:documentation
+ "Return a class pointer to a metaclass chain."))
+
+;;; base-offset
+
+(export '(base-offset base-offset-class base-offset-chain-head))
+(defclass base-offset ()
+ ((class :initarg :class :type sod-class :reader base-offset-class)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader base-offset-chain-head))
+ (:documentation
+ "The offset of this chain to the `ilayout' base.
+
+ We're generating a vtable for CLASS, attached to the chain headed by
+ CHAIN-HEAD. Fortunately (and unlike `class-pointer'), the chain head can
+ do double duty, since it also identifies the `ichain' substructure of the
+ class's `ilayout' whose offset we're interested in."))
+
+(export 'make-base-offset)
+(defgeneric make-base-offset (class chain-head)
+ (:documentation
+ "Return the base offset object for CHAIN-HEAD ichain."))
+
+;;; chain-offset
+
+(export '(chain-offset chain-offset-class
+ chain-offset-chain-head chain-offset-target-head))
+(defclass chain-offset ()
+ ((class :initarg :class :type sod-class :reader chain-offset-class)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader chain-offset-chain-head)
+ (target-head :initarg :target-head :type sod-class
+ :reader chain-offset-target-head))
+ (:documentation
+ "The offset to a different `ichain'.
+
+ We're generating a vtable for CLASS, attached to the chain headed by
+ CHAIN-HEAD. This instance represents an offset to the (different) chain
+ headed by TARGET-HEAD.
+
+ This is, strictly speaking, redundant. We could do as well by using the
+ base offset and finding the offset to the target class in the class
+ object's metadata; but that would either require a search or we'd have to
+ be able work out the target chain's index in the table."))
+
+(defgeneric make-chain-offset (class chain-head target-head)
+ (:documentation
+ "Return the offset from CHAIN-HEAD to TARGET-HEAD."))
+
+;;; vtable
+
+(export '(vtable vtable-class vtable-body
+ vtable-chain-head vtable-chain-tail))
+(defclass vtable ()
+ ((class :initarg :class :type sod-class :reader vtable-class)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader vtable-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader vtable-chain-tail)
+ (body :initarg :body :type list :reader vtable-body))
+ (:documentation
+ "A vtable holds all of the per-chain static information for a class.
+
+ Each chain of CLASS has its own vtable; the `vtable' object remembers the
+ least specific (CHAIN-HEAD) and most specific (CHAIN-TAIL) superclasses of
+ CLASS on that chain. (This is useful because we can reuse vtable
+ structure types from superclasses for chains other than the primary chain
+ -- i.e., the one in which CLASS itself appears.)
+
+ The BODY is a list of vtable items, including `vtmsgs' structures,
+ `chain-offset's, `class-pointers', and a `base-offset'."))
+
+(export 'compute-vtable-items)
+(defgeneric compute-vtable-items (class super chain-head chain-tail emit)
+ (:documentation
+ "Emit vtable items for a superclass of CLASS.
+
+ This function is called for each superclass SUPER of CLASS reached on the
+ chain headed by CHAIN-HEAD. The function should call EMIT for each
+ vtable item it wants to write.
+
+ The right way to check to see whether items have already been emitted
+ (e.g., has an offset to some other chain been emitted?) is as follows:
+
+ * In a method (ideally an `:around'-method) on `compute-vtable', bind a
+ special variable to an empty list or hash table.
+
+ * In a method on this function, check the variable or hash table.
+
+ This function is the real business end of `compute-vtable'."))
+
+(export 'compute-vtable)
+(defgeneric compute-vtable (class chain)
+ (:documentation
+ "Compute the vtable layout for a chain of CLASS.
+
+ The CHAIN is a list of classes, with the least specific first.
+
+ There is a default method which invokes `compute-vtable-items' to do the
+ difficult work."))
+
+(export 'compute-vtables)
+(defgeneric compute-vtables (class)
+ (:documentation
+ "Compute the vtable layouts for CLASS.
+
+ Returns a list of VTABLE objects in the order of CLASS's chains."))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Class construction protocol
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Classes.
+
+(export 'make-sod-class)
+(defun make-sod-class (name superclasses pset &optional location)
+ "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
+
+ This is the main constructor function for classes. The protocol works as
+ follows. The `:lisp-class' property in PSET is checked: if it exists, it
+ must be a symbol naming a (CLOS) class, which is used in place of
+ `sod-class'. All of the arguments are then passed to `make-instance';
+ further behaviour is left to the standard CLOS instance construction
+ protocol; for example, `sod-class' defines an `:after'-method on
+ 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."
+
+ (with-default-error-location (location)
+ (let* ((pset (property-set pset))
+ (class (make-instance (get-property pset :lisp-class :symbol
+ 'sod-class)
+ :name name
+ :superclasses superclasses
+ :location (file-location location)
+ :pset pset)))
+ (check-unused-properties pset)
+ class)))
+
+(export 'guess-metaclass)
+(defgeneric guess-metaclass (class)
+ (:documentation
+ "Determine a suitable metaclass for the CLASS.
+
+ The default behaviour is to choose the most specific metaclass of any of
+ the direct superclasses of CLASS, or to signal an error if that failed."))
+
+;;;--------------------------------------------------------------------------
+;;; Slots and slot initializers.
+
+(export 'make-sod-slot)
+(defgeneric make-sod-slot (class name type pset &optional location)
+ (:documentation
+ "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
+
+ This is the main constructor function for slots. This is a generic
+ function primarily so that the CLASS can intervene in the construction
+ process. The default method uses the `:lisp-class' property (defaulting
+ 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."))
+
+(export 'make-sod-instance-initializer)
+(defgeneric make-sod-instance-initializer
+ (class nick name value-kind value-form pset &optional location)
+ (:documentation
+ "Construct and attach an instance slot initializer, to CLASS.
+
+ This is the main constructor function for instance initializers. This is
+ a generic function primarily so that the CLASS can intervene in the
+ 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."))
+
+(export 'make-sod-class-initializer)
+(defgeneric make-sod-class-initializer
+ (class nick name value-kind value-form pset &optional location)
+ (:documentation
+ "Construct and attach a class slot initializer, to CLASS.
+
+ This is the main constructor function for class initializers. This is a
+ generic function primarily so that the CLASS can intervene in the
+ 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."))
+
+(export 'make-sod-initializer-using-slot)
+(defgeneric make-sod-initializer-using-slot
+ (class slot init-class value-kind value-form pset location)
+ (:documentation
+ "Common construction protocol for slot initializers.
+
+ This generic function does the common work for constructing instance and
+ class initializers. It can usefully be specialized according to both the
+ class and slot types. The default method uses the `:lisp-class' property
+ (defaulting to INIT-CLASS) 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-initializer' defines an
+ `:after'-method on `shared-initialize'.
+
+ Diagnosing unused properties is left for the caller (usually
+ `make-sod-instance-initializer' or `make-sod-class-initializer') to do.
+ The caller is also expected to have set `with-default-error-location' if
+ appropriate.
+
+ You are not expected to call this generic function directly; it's more
+ useful as a place to hang methods for custom initializer classes."))
+
+;;;--------------------------------------------------------------------------
+;;; Messages and methods.
+
+(export 'make-sod-message)
+(defgeneric make-sod-message (class name type pset &optional location)
+ (:documentation
+ "Construct and attach a new message with given NAME and TYPE, to CLASS.
+
+ This is the main constructor function for messages. This is a generic
+ function primarily so that the CLASS can intervene in the construction
+ process. The default method uses the `:lisp-class' property (defaulting
+ to `sod-message') to choose a (CLOS) class to instantiate. The message 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-message' defines an `:after'-method on
+ `shared-initialize'.
+
+ Unused properties on PSET are diagnosed as errors."))
+
+(export 'make-sod-method)
+(defgeneric make-sod-method
+ (class nick name type body pset &optional location)
+ (:documentation
+ "Construct and attach a new method to CLASS.
+
+ This is the main constructor function for methods. This is a generic
+ function primarily so that the CLASS can intervene in the message lookup
+ process, though this is actually a fairly unlikely occurrence.
+
+ The default method looks up the message using `find-message-by-name',
+ 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."))
+
+(export 'make-sod-method-using-message)
+(defgeneric make-sod-method-using-message
+ (message class type body pset location)
+ (:documentation
+ "Main construction subroutine for method construction.
+
+ This is a generic function so that it can be specialized according to both
+ a class and -- more particularly -- a message. The default method uses
+ the `:lisp-class' property (defaulting to the result of calling
+ `sod-message-method-class') to choose a (CLOS) class to instantiate. The
+ method 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-method' defines an
+ `:after'-method on `shared-initialize'.
+
+ Diagnosing unused properties is left for the caller (usually
+ `make-sod-method') to do. The caller is also expected to have set
+ `with-default-error-location' if appropriate.
+
+ You are not expected to call this generic function directly; it's more
+ useful as a place to hang methods for custom method classes."))
+
+(export 'sod-message-method-class)
+(defgeneric sod-message-method-class (message class pset)
+ (:documentation
+ "Return the preferred class for methods on MESSAGE.
+
+ The message can inspect the PSET to decide on a particular message. A
+ `:lisp-class' property will usually override this decision: it's then the
+ programmer's responsibility to ensure that the selected method class is
+ appropriate."))
+
+(export 'check-message-type)
+(defgeneric check-message-type (message type)
+ (:documentation
+ "Check that TYPE is a suitable type for MESSAGE. Signal errors if not.
+
+ This is separated out of `shared-initialize', where it's called, so that
+ it can be overridden conveniently by subclasses."))
+
+(export 'check-method-type)
+(defgeneric check-method-type (method message type)
+ (:documentation
+ "Check that TYPE is a suitable type for METHOD. Signal errors if not.
+
+ This is separated out of `shared-initialize', where it's called, so that
+ it can be overridden conveniently by subclasses."))
+
+;;;--------------------------------------------------------------------------
+;;; Builder macros.
+
+(export 'define-sod-class)
+(defmacro define-sod-class (name (&rest superclasses) &body body)
+ "Construct a new SOD class called NAME in the current module.
+
+ The new class has the named direct SUPERCLASSES, which should be a list of
+ strings.
+
+ The BODY begins with a sequence of alternating keyword/value pairs
+ defining properties for the new class. The keywords are (obviously) not
+ evaluated, but the value forms are.
+
+ The remainder of the BODY are a sequence of forms to be evaluated as an
+ implicit `progn'. Additional macros are available to the BODY, to make
+ defining the class easier.
+
+ In the following, NAME is a string giving a C identifier; NICK is a string
+ giving the nickname of a superclass; TYPE is a C type using S-expression
+ notation.
+
+ * message NAME TYPE &rest PLIST
+
+ * method NICK NAME TYPE BODY &rest PLIST
+
+ * slot NAME TYPE &rest PLIST
+
+ * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST
+
+ * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST"
+
+ (let ((plist nil)
+ (classvar (gensym "CLASS-")))
+ (loop
+ (when (or (null body)
+ (not (keywordp (car body))))
+ (return))
+ (push (pop body) plist)
+ (push (pop body) plist))
+ `(let ((,classvar (make-sod-class ,name
+ (mapcar #'find-sod-class
+ (list ,@superclasses))
+ (make-property-set
+ ,@(nreverse plist)))))
+ (macrolet ((message (name type &rest plist)
+ `(make-sod-message ,',classvar ,name (c-type ,type)
+ (make-property-set ,@plist)))
+ (method (nick name type body &rest plist)
+ `(make-sod-method ,',classvar ,nick ,name (c-type ,type)
+ ,body (make-property-set ,@plist)))
+ (slot (name type &rest plist)
+ `(make-sod-slot ,',classvar ,name (c-type ,type)
+ (make-property-set ,@plist)))
+ (instance-initializer
+ (nick name value-kind value-form &rest plist)
+ `(make-sod-instance-initializer ,',classvar ,nick ,name
+ ,value-kind ,value-form
+ (make-property-set
+ ,@plist)))
+ (class-initializer
+ (nick name value-kind value-form &rest plist)
+ `(make-sod-class-initializer ,',classvar ,nick ,name
+ ,value-kind ,value-form
+ (make-property-set
+ ,@plist))))
+ ,@body
+ (finalize-sod-class ,classvar)
+ (add-to-module *module* ,classvar)))))
+
+;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; Code generator for effective methods
+;;; Code generation protocol
;;;
;;; (c) 2009 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; 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
;;;--------------------------------------------------------------------------
;;; Temporary names.
-(defclass temporary-name ()
- ((tag :initarg :tag :reader temp-tag))
+;; Protocol.
+
+(export 'format-temporary-name)
+(defgeneric format-temporary-name (var stream)
(:documentation
- "Base class for temporary variable and argument names."))
+ "Write the name of a temporary variable VAR to STREAM."))
-(defclass temporary-argument (temporary-name) ())
-(defclass temporary-function (temporary-name) ())
+(export 'var-in-use-p)
+(defgeneric var-in-use-p (var)
+ (:documentation
+ "Answer whether VAR is currently being used. See WITH-TEMPORARY-VAR.")
+ (:method (var)
+ "Non-temporary variables are always in use."
+ t))
+(defgeneric (setf var-in-use-p) (value var)
+ (:documentation
+ "Record whether VAR is currently being used. See WITH-TEMPORARY-VAR."))
-(defclass temporary-variable (temporary-name)
- ((in-use-p :initarg :in-use-p :initform nil
- :type boolean :accessor var-in-use-p)))
+;; Root class.
-(defmethod var-in-use-p ((var t))
- "Non-temporary variables are always in use."
- t)
+(export 'temporary-name)
+(defclass temporary-name ()
+ ((tag :initarg :tag :reader temp-tag))
+ (:documentation
+ "Base class for temporary variable and argument names."))
-(defmethod commentify-argument-name ((name temporary-name))
- nil)
+;; Important variables.
(defparameter *temporary-index* 0
"Index for temporary name generation.
This is automatically reset to zero before the output functions are
invoked to write a file. This way, we can ensure that the same output
- file is always produced from the same input.")
+ file is always produced from the same input."
+ ;; FIXME: this is currently a lie. Need some protocol to ensure that this
+ ;; happens.
+)
-(defun temporary-function ()
- "Return a temporary function name."
- (make-instance 'temporary-function
- :tag (prog1 *temporary-index* (incf *temporary-index*))))
-
-(defgeneric format-temporary-name (var stream)
- (:method ((var temporary-name) stream)
- (format stream "~A" (temp-tag var)))
- (:method ((var temporary-argument) stream)
- (format stream "sod__a~A" (temp-tag var)))
- (:method ((var temporary-variable) stream)
- (format stream "sod__v~A" (temp-tag var)))
- (:method ((var temporary-function) stream)
- (format stream "sod__f~A" (temp-tag var))))
-
-(defmethod print-object ((var temporary-name) stream)
- (if *print-escape*
- (print-unreadable-object (var stream :type t)
- (prin1 (temp-tag var) stream))
- (format-temporary-name var stream)))
+;; Important temporary names.
+(export '(*sod-ap* *sod-master-ap*))
(defparameter *sod-ap*
(make-instance 'temporary-name :tag "sod__ap"))
(defparameter *sod-master-ap*
;;;--------------------------------------------------------------------------
;;; Instructions.
+;; Classes.
+
+(export 'inst)
(defclass inst () ()
(:documentation
"A base class for instructions.
This doesn't really do very much, but it acts as a handy marker for
instruction subclasses."))
+(export 'inst-metric)
(defgeneric inst-metric (inst)
(:documentation
"Returns a `metric' describing how complicated INST is.
code fairly simply.")
(:method (inst) 1))
+;; Instruction definition.
+
+(export 'definst)
(defmacro definst (code (streamvar) args &body body)
"Define an instruction type and describe how to output it.
,@(mappend #'list keys args)))
(progn ,@body)))))))
+;; Important instruction classes.
+
+(export '(block-inst make-block-inst var-inst make-var-inst
+ function-inst make-function-inst set-inst make-set-inst
+ return-inst make-return-inst expr-inst make-expr-inst
+ inst-decls inst-body inst-name inst-type inst-init inst-var
+ inst-expr))
+
+(definst var (stream) (name type init)
+ (pprint-c-type type stream name)
+ (when init
+ (format stream " = ~A" init)))
+(definst set (stream) (var expr)
+ (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
+(definst return (stream) (expr)
+ (format stream "return~@[ (~A)~];" expr))
+(definst expr (stream) (expr)
+ (format stream "~A;" expr))
+(definst block (stream) (decls body)
+ (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
+ decls body))
+(definst function (stream) (name type body)
+ (pprint-logical-block (stream nil)
+ (princ "static " stream)
+ (pprint-c-type type stream name)
+ (format stream "~:@_~A~:@_~:@_" body)))
+
+;; Formatting utilities.
+
(defun format-compound-statement* (stream child morep thunk)
"Underlying function for FORMAT-COMPOUND-STATEMENT."
(cond ((typep child 'block-inst)
(:space
(write-char #\space stream)
(pprint-newline :linear stream))
- (t
+ ((t)
(pprint-newline :mandatory stream)))))))
+(export 'format-compound-statement)
(defmacro format-compound-statement
((stream child &optional morep) &body body)
"Format a compound statement to STREAM.
(lambda (,stream) ,@body)))
;;;--------------------------------------------------------------------------
-;;; Instruction types.
-
-;; Compound statements.
-
-(definst block (stream) (decls body)
- (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
- decls body))
-
-(definst if (stream) (condition consequent alternative)
- (format-compound-statement (stream consequent alternative)
- (format stream "if (~A)" condition))
- (when alternative
- (format-compound-statement (stream alternative)
- (write-string "else" stream))))
-
-(definst while (stream) (condition body)
- (format-compound-statement (stream body)
- (format stream "while (~A)" condition)))
-
-(definst do-while (stream) (body condition)
- (format-compound-statement (stream body :space)
- (write-string "do" stream))
- (format stream "while (~A);" condition))
-
-;; Simple statements.
-
-(definst set (stream) (var expr)
- (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-
-(definst return (stream) (expr)
- (format stream "return~@[ (~A)~];" expr))
-
-(definst expr (stream) (expr)
- (format stream "~A;" expr))
-
-;; Special varargs hacks.
-
-(definst va-start (stream) (ap arg)
- (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
+;;; Code generation.
-(definst va-copy (stream) (to from)
- (format stream "va_copy(~@<~A, ~_~A~:>);" to from))
+;; Accessors.
-(definst va-end (stream) (ap)
- (format stream "va_end(~A);" ap))
-
-;; Declarations. These should appear at the heads of BLOCK-INSTs.
-
-(definst var (stream) (name type init)
- (pprint-c-type type stream name)
- (when init
- (format stream " = ~A" init)))
-
-;; Expressions.
-
-(definst call (stream) (func args)
- (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
-
-;; Top level things.
-
-(definst function (stream) (name type body)
- (pprint-logical-block (stream nil)
- (princ "static " stream)
- (pprint-c-type type stream name)
- (format stream "~:@_~A~:@_~:@_" body)))
-
-;;;--------------------------------------------------------------------------
-;;; Code generator objects.
-
-(defclass basic-codegen ()
- ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
- (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
- (temp-index :initarg :temp-index :initform 0
- :type fixnum :accessor codegen-temp-index))
- (:documentation
- "Base class for code generator state.
-
- This contains the bare essentials for supporting the EMIT-INST and
- ENSURE-VAR protocols; see the documentation for those generic functions
- for more details.
-
- This class isn't abstract. A full CODEGEN object uses instances of this
- to keep track of pending functions which haven't been completed yet.
-
- Just in case that wasn't clear enough: this is nothing to do with the
- BASIC language."))
-
-(defgeneric emit-inst (codegen inst)
+(export 'codegen-functions)
+(defgeneric codegen-functions (codegen)
(:documentation
- "Add INST to the end of CODEGEN's list of instructions.")
- (:method ((codegen basic-codegen) inst)
- (push inst (codegen-insts codegen))))
-
-(defgeneric emit-insts (codegen insts)
- (:documentation
- "Add a list of INSTS to the end of CODEGEN's list of instructions.")
- (:method ((codegen basic-codegen) insts)
- (setf (codegen-insts codegen)
- (revappend insts (codegen-insts codegen)))))
+ "Return the list of FUNCTION-INSTs of completed functions."))
+(export 'ensure-var)
(defgeneric ensure-var (codegen name type &optional init)
(:documentation
"Add a variable to CODEGEN's list.
The variable is called NAME (which should be comparable using EQUAL and
print to an identifier) and has the given TYPE. If INIT is present and
non-nil it is an expression INST used to provide the variable with an
- initial value.")
- (:method ((codegen basic-codegen) name type &optional init)
- (let* ((vars (codegen-vars codegen))
- (var (find name vars :key #'inst-name :test #'equal)))
- (cond ((not var)
- (setf (codegen-vars codegen)
- (cons (make-var-inst name type init) vars)))
- ((not (c-type-equal-p type (inst-type var)))
- (error "(Internal) Redefining type for variable ~A." name)))
- name)))
-
-(defclass codegen (basic-codegen)
- ((functions :initform nil :type list :accessor codegen-functions)
- (stack :initform nil :type list :accessor codegen-stack))
- (:documentation
- "A full-fat code generator which can generate and track functions.
+ initial value."))
- This is the real deal. Subclasses may which to attach additional state
- for convenience's sake, but this class is self-contained. It supports the
- CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))
+(export '(emit-inst emit-insts))
+(defgeneric emit-inst (codegen inst)
+ (:documentation
+ "Add INST to the end of CODEGEN's list of instructions."))
+(defgeneric emit-insts (codegen insts)
+ (:documentation
+ "Add a list of INSTS to the end of CODEGEN's list of instructions.")
+ (:method (codegen insts)
+ (dolist (inst insts) (emit-inst codegen inst))))
+(export 'codegen-push)
(defgeneric codegen-push (codegen)
(:documentation
"Pushes the current code generation state onto a stack.
- The state consists of the accumulated variables and instructions, i.e.,
- what is representable by a BASIC-CODEGEN.")
- (:method ((codegen codegen))
- (with-slots (vars insts temp-index stack) codegen
- (push (make-instance 'basic-codegen
- :vars vars
- :insts insts
- :temp-index temp-index)
- stack)
- (setf vars nil insts nil temp-index 0))))
+ The state consists of the accumulated variables and instructions."))
+(export 'codegen-pop)
(defgeneric codegen-pop (codegen)
(:documentation
"Pops a saved state off of the CODEGEN's stack.
Returns the newly accumulated variables and instructions as lists, as
- separate values.")
- (:method ((codegen codegen))
- (with-slots (vars insts temp-index stack) codegen
- (multiple-value-prog1
- (values (nreverse vars) (nreverse insts))
- (let ((sub (pop stack)))
- (setf vars (codegen-vars sub)
- insts (codegen-insts sub)
- temp-index (codegen-temp-index sub)))))))
+ separate values."))
+(export 'codegen-add-function)
(defgeneric codegen-add-function (codegen function)
(:documentation
"Adds a function to CODEGEN's list.
Actually, we're not picky: FUNCTION can be any kind of object that you're
- willing to find in the list returned by CODEGEN-FUNCTIONS.")
- (:method ((codegen codegen) function)
- (with-slots (functions) codegen
- (setf functions (nconc functions (list function))))))
+ willing to find in the list returned by CODEGEN-FUNCTIONS."))
+
+(export 'temporary-var)
+(defgeneric temporary-var (codegen type)
+ (:documentation
+ "Return the name of a temporary variable.
+
+ The temporary variable will have the given TYPE, and will be marked
+ in-use. You should clear the in-use flag explicitly when you've finished
+ with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
+ automatically."))
+(export 'codegen-build-function)
(defun codegen-build-function (codegen name type vars insts)
"Build a function and add it to CODEGEN's list.
(make-block-inst vars insts)))
name)
+(export 'codegen-pop-block)
+(defgeneric codegen-pop-block (codegen)
+ (:documentation
+ "Makes a block (BLOCK-INST) out of the completed code in CODEGEN.")
+ (:method (codegen)
+ (multiple-value-bind (vars insts) (codegen-pop codegen)
+ (make-block-inst vars insts))))
+
+(export 'codegen-pop-function)
(defgeneric codegen-pop-function (codegen name type)
(:documentation
"Makes a function out of the completed code in CODEGEN.
The NAME can be any object you like. The TYPE should be a function type
object which includes argument names. The return value is the NAME.")
- (:method ((codegen codegen) name type)
+ (:method (codegen name type)
(multiple-value-bind (vars insts) (codegen-pop codegen)
(codegen-build-function codegen name type vars insts))))
-(defgeneric temporary-var (codegen type)
- (:documentation
- "Return the name of a temporary variable.
-
- The temporary variable will have the given TYPE, and will be marked
- in-use. You should clear the in-use flag explicitly when you've finished
- with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
- automatically."))
-
-(defmethod temporary-var ((codegen basic-codegen) type)
- (with-slots (vars temp-index) codegen
- (or (find-if (lambda (var)
- (and (not (var-in-use-p (inst-name var)))
- (c-type-equal-p type (inst-type var))))
- vars)
- (let* ((name (make-instance 'temporary-variable
- :tag (prog1 temp-index
- (incf temp-index)))))
- (push (make-var-inst name type nil) vars)
- name))))
-
+(export 'with-temporary-var)
(defmacro with-temporary-var ((codegen var type) &body body)
"Evaluate BODY with VAR bound to a temporary variable name.
;;;--------------------------------------------------------------------------
;;; Code generation idioms.
+(export 'deliver-expr)
(defun deliver-expr (codegen target expr)
"Emit code to deliver the value of EXPR to the TARGET.
(emit-inst codegen (make-return-inst nil)))
(t (emit-inst codegen (make-set-inst target expr)))))
+(export 'convert-stmts)
(defun convert-stmts (codegen target type func)
"Invoke FUNC to deliver a value to a non-:RETURN target.
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for lexical analysis
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Accessors.
+
+(export 'lexer-char)
+(defgeneric lexer-char (lexer)
+ (:documentation
+ "Return the current lookahead character from the LEXER.
+
+ When the lexer is first created, there is no lookahead character: you must
+ `prime the pump' by calling NEXT-CHAR. The lexer represents encountering
+ the end of its input stream by setting the lookahead character to nil. At
+ this point it is still possible to push back characters."))
+
+(export '(token-type token-value))
+(defgeneric token-type (lexer)
+ (:documentation
+ "Return the type of the LEXER's current lookahead token
+
+ When the lexer is first created, there is no lookahead token: you must
+ `prime the pump' by calling NEXT-TOKEN."))
+(defgeneric token-value (lexer)
+ (:documentation
+ "Return the value of the LEXER's current lookahead token
+
+ When the lexer is first created, there is no lookahead token: you must
+ `prime the pump' by calling NEXT-TOKEN."))
+
+;;;--------------------------------------------------------------------------
+;;; Formatting tokens.
+
+(defgeneric format-token (token-type &optional token-value)
+ (:documentation
+ "Return a string describing a token with the specified type and value.")
+ (:method ((token-type (eql :eof)) &optional token-value)
+ (declare (ignore token-value))
+ "<end-of-file>")
+ (:method ((token-type (eql :string)) &optional token-value)
+ (declare (ignore token-value))
+ "<string-literal>")
+ (:method ((token-type (eql :char)) &optional token-value)
+ (declare (ignore token-value))
+ "<character-literal>")
+ (:method ((token-type (eql :id)) &optional token-value)
+ (format nil "<identifier~@[ `~A'~]>" token-value))
+ (:method ((token-type symbol) &optional token-value)
+ (declare (ignore token-value))
+ (check-type token-type keyword)
+ (format nil "`~(~A~)'" token-type))
+ (:method ((token-type character) &optional token-value)
+ (declare (ignore token-value))
+ (format nil "~:[<~:C>~;`~C'~]"
+ (and (graphic-char-p token-type)
+ (char/= token-type #\space))
+ token-type)))
+
+;;;--------------------------------------------------------------------------
+;;; Reading and pushing back characters.
+
+(export 'next-char)
+(defgeneric next-char (lexer)
+ (:documentation
+ "Fetch the next character from the LEXER's input stream.
+
+ Read a character from the input stream, and store it in the LEXER's CHAR
+ slot. The character stored is returned. If characters have been pushed
+ back then pushed-back characters are used instead of the input stream. If
+ there are no more characters to be read then the lookahead character is
+ nil. Returns the new lookahead character.
+
+ (This function is primarily intended for the use of lexer subclasses.)"))
+
+(export 'pushback-char)
+(defgeneric pushback-char (lexer char)
+ (:documentation
+ "Push the CHAR back into the lexer.
+
+ Make CHAR be the current lookahead character (stored in the LEXER's CHAR
+ slot). The previous lookahead character is pushed down, and will be made
+ available again once this character is consumed by NEXT-CHAR.
+
+ (This function is primarily intended for the use of lexer subclasses.)"))
+
+(defgeneric fixup-stream* (lexer thunk)
+ (:documentation
+ "Helper function for WITH-LEXER-STREAM.
+
+ This function does the main work for WITH-LEXER-STREAM. The THUNK is
+ invoked on a single argument, the LEXER's underlying STREAM."))
+
+(export 'with-lexer-stream)
+(defmacro with-lexer-stream ((streamvar lexer) &body body)
+ "Evaluate BODY with STREAMVAR bound to the LEXER's input stream.
+
+ The STREAM is fixed up so that the next character read (e.g., using
+ READ-CHAR) will be the lexer's current lookahead character. Once the BODY
+ completes, the next character in the stream is read and set as the
+ lookahead character. It is an error if the lexer has pushed-back
+ characters (since these can't be pushed back into the input stream
+ properly)."
+
+ `(fixup-stream* ,lexer (lambda (,streamvar) ,@body)))
+
+;;;--------------------------------------------------------------------------
+;;; Reading and pushing back tokens.
+
+(export 'scan-token)
+(defgeneric scan-token (lexer)
+ (:documentation
+ "Internal protocol for scanning tokens from an input stream.
+
+ Implementing a method on this function is the main responsibility of LEXER
+ subclasses; it is called by the user-facing NEXT-TOKEN function.
+
+ The method should consume characters (using NEXT-CHAR) as necessary, and
+ return two values: a token type and token value. These will be stored in
+ the corresponding slots in the lexer object in order to provide the user
+ with one-token lookahead."))
+
+(export 'next-token)
+(defgeneric next-token (lexer)
+ (:documentation
+ "Scan a token from an input stream.
+
+ This function scans a token from an input stream. Two values are
+ returned: a `token type' and a `token value'. These are opaque to the
+ LEXER base class, but the intent is that the token type be significant to
+ determining the syntax of the input, while the token value carries any
+ additional information about the token's semantic content. The token type
+ and token value are also made available for lookahead via accessors
+ TOKEN-TYPE and TOKEN-VALUE on the LEXER object.
+
+ The new lookahead token type and value are returned as two separate
+ values.
+
+ If tokens have been pushed back (see PUSHBACK-TOKEN) then they are
+ returned one by one instead of scanning the stream."))
+
+(export 'pushback-token)
+(defgeneric pushback-token (lexer token-type &optional token-value location)
+ (:documentation
+ "Push a token back into the lexer.
+
+ Make the given TOKEN-TYPE and TOKEN-VALUE be the current lookahead token.
+ The previous lookahead token is pushed down, and will be made available
+ agan once this new token is consumed by NEXT-TOKEN. If LOCATION is
+ non-nil then FILE-LOCATION is saved and replaced by LOCATION. The
+ TOKEN-TYPE and TOKEN-VALUE can be anything at all: for instance, they need
+ not be values which can actually be returned by NEXT-TOKEN."))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(export 'skip-spaces)
+(defgeneric skip-spaces (lexer)
+ (:documentation
+ "Skip over whitespace characters in the LEXER.
+
+ There must be a lookahead character; when the function returns, the
+ lookahead character will be a non-whitespace character or nil if there
+ were no non-whitespace characters remaining. Returns the new lookahead
+ character."))
+
+(export 'require-token)
+(defun require-token
+ (lexer wanted-token-type &key (errorp t) (consumep t) default)
+ "Require a particular token to appear.
+
+ If the LEXER's current lookahead token has type WANTED-TOKEN-TYPE then
+ consume it (using NEXT-TOKEN) and return its value. Otherwise, if the
+ token doesn't have the requested type then signal a continuable error
+ describing the situation and return DEFAULT (which defaults to nil).
+
+ If ERRORP is false then no error is signalled; this is useful for
+ consuming or checking for optional punctuation. If CONSUMEP is false then
+ a matching token is not consumed; non-matching tokens are never consumed."
+
+ (with-slots (token-type token-value) lexer
+ (cond ((eql token-type wanted-token-type)
+ (prog1 token-value
+ (when consumep (next-token lexer))))
+ (errorp
+ (cerror* "Expected ~A but found ~A"
+ (format-token wanted-token-type)
+ (format-token token-type token-value))
+ default)
+ (t
+ default))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Method combination protocol
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Effective methods and entries.
+
+(export '(effective-method effective-method-message effective-method-class))
+(defclass effective-method ()
+ ((message :initarg :message :type sod-message
+ :reader effective-method-message)
+ (class :initarg :class :type sod-class :reader effective-method-class))
+ (:documentation
+ "The behaviour invoked by sending a message to an instance of a class.
+
+ This class describes the behaviour when an instance of CLASS is sent
+ MESSAGE.
+
+ This is not a useful class by itself. Message classes are expected to
+ define their own effective-method classes.
+
+ An effective method classce must accept a `:direct-methods' initarg, which
+ will be a list of applicable methods sorted in most-to-least specific
+ order. (Either that or you have to add an overriding method to
+ `compute-sod-effective-method'."))
+
+(export 'message-effective-method-class)
+(defgeneric message-effective-method-class (message)
+ (:documentation
+ "Return the effective method class for the given MESSAGE.
+
+ This function is invoked by `compute-sod-effective-method'."))
+
+(export 'primary-method-class)
+(defgeneric primary-method-class (message)
+ (:documentation
+ "Return the name of the primary direct method class for MESSAGE.
+
+ This protocol is used by `simple-message' subclasses."))
+
+(export 'compute-sod-effective-method)
+(defgeneric compute-sod-effective-method (message class)
+ (:documentation
+ "Return the effective method when a CLASS instance receives MESSAGE.
+
+ The default method constructs an instance of the message's chosen
+ `message-effective-method-class', passing the MESSAGE, the CLASS and the
+ list of applicable methods as initargs to `make-instance'."))
+
+(export 'compute-effective-methods)
+(defgeneric compute-effective-methods (class)
+ (:documentation
+ "Return a list of all of the effective methods needed for CLASS.
+
+ The list needn't be in any particular order."))
+
+(export '(method-entry method-entry-effective-method
+ method-entry-chain-head method-entry-chain-tail))
+(defclass method-entry ()
+ ((method :initarg :method :type effective-method
+ :reader method-entry-effective-method)
+ (chain-head :initarg :chain-head :type sod-class
+ :reader method-entry-chain-head)
+ (chain-tail :initarg :chain-tail :type sod-class
+ :reader method-entry-chain-tail))
+ (:documentation
+ "An entry point into an effective method.
+
+ Specifically, this is the entry point to the effective method METHOD
+ invoked via the vtable for the chain headed by CHAIN-HEAD. The CHAIN-TAIL
+ is the most specific class on this chain; this is useful because we can
+ reuse the types of method entries from superclasses on non-primary chains.
+
+ Each effective method may have several different method entries, because
+ an effective method can be called via vtables attached to different
+ chains, and such calls will pass instance pointers which point to
+ different `ichain' structures within the overall instance layout; it's the
+ job of the method entry to adjust the instance pointers correctly for the
+ rest of the effective method.
+
+ The boundaries between a method entry and the effective method
+ is (intentionally) somewhat fuzzy. In extreme cases, the effective method
+ may not exist at all as a distinct entity in the output because its
+ content is duplicated in all of the method entry functions. This is left
+ up to the effective method protocol."))
+
+(export 'make-method-entry)
+(defgeneric make-method-entry (effective-method chain-head chain-tail)
+ (:documentation
+ "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
+
+ There is no default method for this function. (Maybe when the
+ effective-method/method-entry output protocol has settled down I'll know
+ what a sensible default action would be.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Protocol for messages and direct-methods.
+
+(export 'sod-message-argument-tail)
+(defgeneric sod-message-argument-tail (message)
+ (:documentation
+ "Return the argument tail for the message, with invented argument names.
+
+ No `me' argument is prepended; any `:ellipsis' is left as it is."))
+
+(export 'sod-message-no-varargs-tail)
+(defgeneric sod-message-no-varargs-tail (message)
+ (:documentation
+ "Return the argument tail for the message with `:ellipsis' substituted.
+
+ As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended.
+ However, an :ELLIPSIS is replaced by an argument of type `va_list', named
+ `sod__ap'."))
+
+(export 'sod-method-function-type)
+(defgeneric sod-method-function-type (method)
+ (:documentation
+ "Return the C function type for the direct method.
+
+ This is called during initialization of a direct method object, and the
+ result is cached.
+
+ A default method is provided (by `basic-direct-method') which simply
+ prepends an appropriate `me' argument to the user-provided argument list.
+ Fancy method classes may need to override this behaviour."))
+
+(export 'sod-method-next-method-type)
+(defgeneric sod-method-next-method-type (method)
+ (:documentation
+ "Return the C function type for the next-method trampoline.
+
+ This is called during initialization of a direct method object, and the
+ result is cached. It should return a function type, not a pointer type.
+
+ A default method is provided (by `delegating-direct-method') which should
+ do the right job. Very fancy subclasses might need to do something
+ different."))
+
+(export 'sod-method-function-name)
+(defgeneric sod-method-function-name (method)
+ (:documentation
+ "Return the C function name for the direct method."))
+
+(export 'varargs-message-p)
+(defun varargs-message-p (message)
+ "Answer whether the MESSAGE accepts a variable-length argument list.
+
+ We need to jump through some extra hoops in order to cope with varargs
+ messages, so this is useful to know."
+ (member :ellipsis (sod-message-argument-tail message)))
+
+;;;--------------------------------------------------------------------------
+;;; Protocol for effective methods and method entries.
+
+(export 'method-entry-function-type)
+(defgeneric method-entry-function-type (entry)
+ (:documentation
+ "Return the C function type for a method entry."))
+
+(export 'effective-method-basic-argument-names)
+(defgeneric effective-method-basic-argument-names (method)
+ (:documentation
+ "Return a list of argument names to be passed to direct methods.
+
+ The argument names are constructed from the message's arguments returned
+ by `sod-message-no-varargs-tail'. The basic arguments are the ones
+ immediately derived from the programmer's explicitly stated arguments; the
+ `me' argument is not included, and neither are more exotic arguments added
+ as part of the method delegation protocol."))
+
+;;;--------------------------------------------------------------------------
+;;; Code generation.
+
+;;; Enhanced code-generator class.
+
+(export '(method-codegen codegen-message codegen-class
+ codegen-method codegen-target))
+(defclass method-codegen (codegen)
+ ((message :initarg :message :type sod-message :reader codegen-message)
+ (class :initarg :class :type sod-class :reader codegen-class)
+ (method :initarg :method :type effective-method :reader codegen-method)
+ (target :initarg :target :reader codegen-target))
+ (:documentation
+ "Augments CODEGEN with additional state regarding an effective method.
+
+ We store the effective method, and also its target class and owning
+ message, so that these values are readily available to the code-generating
+ functions."))
+
+;;; Protocol.
+
+(export 'compute-effective-method-body)
+(defgeneric compute-effective-method-body (method codegen target)
+ (:documentation
+ "Generates the body of an effective method.
+
+ Writes the function body to the code generator. It can (obviously)
+ generate auxiliary functions if it needs to.
+
+ The arguments are as specified by the `sod-message-no-varargs-tail', with
+ an additional argument `sod__obj' of type pointer-to-ilayout. The code
+ should deliver the result (if any) to the TARGET."))
+
+(export 'simple-method-body)
+(defgeneric simple-method-body (method codegen target)
+ (:documentation
+ "Generate the body of a simple effective method.
+
+ The function is invoked on an effective METHOD, with a CODEGEN to which it
+ should emit code delivering the method's value to TARGET."))
+
+;;; Additional instructions.
+
+(export 'convert-to-ilayout)
+(definst convert-to-ilayout (stream) (class chain-head expr)
+ (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)"
+ class (sod-class-nickname chain-head) expr))
+
+;;; Utilities.
+
+(export 'invoke-method)
+(defun invoke-method (codegen target arguments-tail direct-method)
+ "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
+
+ The code is generated in the context of CODEGEN, which can be any instance
+ of the `codegen' class -- it needn't be an instance of `method-codegen'.
+ The DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of
+ argument expressions), preceded by a `me' argument of type pointer-to-
+ CLASS where CLASS is the class on which the method was defined.
+
+ If the message accepts a variable-length argument list then a copy of the
+ prevailing master argument pointer is provided in place of the
+ `:ellipsis'."
+
+ (let* ((message (sod-method-message direct-method))
+ (class (sod-method-class direct-method))
+ (function (sod-method-function-name direct-method))
+ (arguments (cons (format nil "&sod__obj.~A.~A"
+ (sod-class-nickname
+ (sod-class-chain-head class))
+ (sod-class-nickname class))
+ arguments-tail)))
+ (if (varargs-message-p message)
+ (convert-stmts codegen target
+ (c-type-subtype (sod-method-type direct-method))
+ (lambda (var)
+ (ensure-var codegen *sod-ap* (c-type va-list))
+ (emit-inst codegen
+ (make-va-copy-inst *sod-ap*
+ *sod-master-ap*))
+ (deliver-expr codegen var
+ (make-call-inst function arguments))
+ (emit-inst codegen
+ (make-va-end-inst *sod-ap*))))
+ (deliver-expr codegen target (make-call-inst function arguments)))))
+
+(export 'ensure-ilayout-var)
+(defun ensure-ilayout-var (codegen super)
+ "Define a variable `sod__obj' pointing to the class's ilayout structure.
+
+ CODEGEN is a `method-codegen'. The class in question is CODEGEN's class,
+ i.e., the target class for the effective method. SUPER is one of the
+ class's superclasses; it is assumed that `me' is a pointer to a SUPER
+ (i.e., to SUPER's ichain within the ilayout)."
+
+ (let* ((class (codegen-class codegen))
+ (super-head (sod-class-chain-head super)))
+ (ensure-var codegen "sod__obj"
+ (c-type (* (struct (ilayout-struct-tag class))))
+ (make-convert-to-ilayout-inst class super-head "me"))))
+
+(export 'make-trampoline)
+(defun make-trampoline (codegen super body)
+ "Construct a trampoline function and return its name.
+
+ CODEGEN is a `method-codegen'. SUPER is a superclass of the CODEGEN
+ class. We construct a new trampoline function (with an unimaginative
+ name) suitable for being passed to a direct method defined on SUPER as its
+ `next_method'. In particular, it will have a `me' argument whose type is
+ pointer-to-SUPER.
+
+ The code of the function is generated by BODY, which will be invoked with
+ a single argument which is the TARGET to which it should deliver its
+ result.
+
+ The return value is the name of the generated function."
+
+ (let* ((message (codegen-message codegen))
+ (message-type (sod-message-type message))
+ (return-type (c-type-subtype message-type))
+ (arguments (mapcar (lambda (arg)
+ (if (eq (argument-name arg) *sod-ap*)
+ (make-argument *sod-master-ap*
+ (c-type va-list))
+ arg))
+ (sod-message-no-varargs-tail message))))
+ (codegen-push codegen)
+ (ensure-ilayout-var codegen super)
+ (funcall body (codegen-target codegen))
+ (codegen-pop-function codegen (temporary-function)
+ (c-type (fun (lisp return-type)
+ ("me" (* (class super)))
+ . arguments)))))
+
+;;;--------------------------------------------------------------------------
+;;; Method entry protocol.
+
+(export 'effective-method-function-name)
+(defgeneric effective-method-function-name (method)
+ (:documentation
+ "Returns the function name of an effective method."))
+
+(export 'method-entry-function-name)
+(defgeneric method-entry-function-name (method chain-head)
+ (:documentation
+ "Returns the function name of a method entry.
+
+ The method entry is given as an effective method/chain-head pair, rather
+ than as a method entry object because we want the function name before
+ we've made the entry object."))
+
+(export 'compute-method-entry-functions)
+(defgeneric compute-method-entry-functions (method)
+ (:documentation
+ "Construct method entry functions.
+
+ Builds the effective method function (if there is one) and the necessary
+ method entries. Returns a list of functions (i.e., `function-inst'
+ objects) which need to be defined in the generated source code."))
+
+;;;--------------------------------------------------------------------------
+;;; Invoking direct methods.
+
+(export 'invoke-delegation-chain)
+(defun invoke-delegation-chain (codegen target basic-tail chain kernel)
+ "Invoke a chain of delegating methods.
+
+ CODEGEN is a `method-codegen'. BASIC-TAIL is a list of argument
+ expressions to provide to the methods. The result of the delegation chain
+ will be delivered to TARGET.
+
+ The CHAIN is a list of method objects (it's intended to be used with
+ `delegating-direct-method' objects). The behaviour is as follows. The
+ first method in the chain is invoked with the necessary arguments (see
+ below) including a `next_method' pointer. If KERNEL is nil and there are
+ no more methods in the chain then the `next_method' pointer will be null;
+ otherwise it will point to a `trampoline' function, whose behaviour is to
+ call the remaining methods on the chain as a delegation chain. The method
+ may choose to call this function with its arguments. It will finally
+ return a value, which will be delivered to the TARGET.
+
+ If the chain is empty, then the code generated by KERNEL (given a TARGET
+ argument) will be invoked. It is an error if both CHAIN and KERNEL are
+ nil."
+
+ (let* ((message (codegen-message codegen))
+ (argument-tail (if (varargs-message-p message)
+ (cons *sod-master-ap* basic-tail)
+ basic-tail)))
+ (labels ((next-trampoline (method chain)
+ (if (or kernel chain)
+ (make-trampoline codegen (sod-method-class method)
+ (lambda (target)
+ (invoke chain target)))
+ 0))
+ (invoke (chain target)
+ (if (null chain)
+ (funcall kernel target)
+ (let* ((trampoline (next-trampoline (car chain)
+ (cdr chain))))
+ (invoke-method codegen target
+ (cons trampoline argument-tail)
+ (car chain))))))
+ (invoke chain target))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Module protocol definition
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Module environment.
+
+(defvar *module-bindings-alist* nil
+ "An alist of (SYMBOL . THUNK) pairs.
+
+ During module construction, each SYMBOL is special-bound to the value
+ returned by the corresponding THUNK.")
+
+(export 'add-module-binding)
+(defun add-module-binding (symbol thunk)
+ "Add a new module variable binding.
+
+ During module construction, SYMBOL will be special-bound to the value
+ returned by THUNK. If you can, use `define-module-var' instead."
+ (aif (assoc symbol *module-bindings-alist*)
+ (setf (cdr it) thunk)
+ (asetf *module-bindings-alist* (acons symbol thunk it))))
+
+(export 'define-module-var)
+(defmacro define-module-var (name value-form &optional documentation)
+ "Add a new module variable binding.
+
+ During module construction, NAME will be special-bound to the value of
+ VALUE-FORM. The NAME is proclaimed special, but is initially left
+ unbound."
+ `(progn
+ (defvar ,name)
+ ,@(and documentation
+ `((setf (documentation ',name 'variable) ,documentation)))
+ (add-module-binding ',name (lambda () ,value-form))))
+
+(export 'call-with-module-environment)
+(defun call-with-module-environment (thunk)
+ "Invoke THUNK with a new collection of bindings for the module variables."
+ (progv
+ (mapcar #'car *module-bindings-alist*)
+ (mapcar (compose #'cdr #'funcall) *module-bindings-alist*)
+ (funcall thunk)))
+
+;;;--------------------------------------------------------------------------
+;;; The reset switch.
+
+(defvar *clear-the-decks-alist* nil
+ "List tracking functions to be called by `clear-the-decks'.")
+
+(export 'add-clear-the-decks-function)
+(defun add-clear-the-decks-function (symbol thunk)
+ "Add a function to the `clear-the-decks' list.
+
+ If a function tagged by SYMBOL already exists on the list, then that
+ function is replaced; otherwise a new function is added."
+ (aif (assoc symbol *clear-the-decks-alist*)
+ (setf (cdr it) thunk)
+ (asetf *clear-the-decks-alist* (acons symbol thunk it))))
+
+(export 'define-clear-the-decks)
+(defmacro define-clear-the-decks (name &body body)
+ "Add behaviour to `clear-the-decks'.
+
+ When `clear-the-decks' is called, the BODY will be evaluated as a progn.
+ The relative order of `clear-the-decks' operations is unspecified."
+ `(add-clear-the-decks-function ',name (lambda () ,@body)))
+
+(export 'clear-the-decks)
+(defun clear-the-decks ()
+ "Invoke a sequence of functions to reset the world."
+ (dolist (item *clear-the-decks-alist*)
+ (funcall (cdr item))))
+
+;;;--------------------------------------------------------------------------
+;;; Module construction protocol.
+
+(export '*module*)
+(defparameter *module* nil
+ "The current module under construction.
+
+ This is always an instance of MODULE. Once we've finished constructing
+ it, we'll call `change-class' to turn it into an instance of whatever type
+ is requested in the module's `:lisp-class' property.")
+
+(export 'module-import)
+(defgeneric module-import (object)
+ (:documentation
+ "Import definitions into the current environment.
+
+ Instructs the OBJECT to import its definitions into the current
+ environment. Modules pass the request on to their constituents. There's
+ a default method which does nothing at all.
+
+ It's not usual to modify the current module. Inserting things into the
+ `*module-type-map*' is a good plan.")
+ (:method (object) nil))
+
+(export 'add-to-module)
+(defgeneric add-to-module (module item)
+ (:documentation
+ "Add ITEM to the MODULE's list of accumulated items.
+
+ The module items participate in the `module-import' and `add-output-hooks'
+ protocols."))
+
+(export 'finalize-module)
+(defgeneric finalize-module (module)
+ (:documentation
+ "Finalizes a module, setting everything which needs setting.
+
+ This isn't necessary if you made the module by hand. If you've
+ constructed it incrementally, then it might be a good plan. In
+ particular, it will change the class (using `change-class') of the module
+ according to the class choice set in the module's `:lisp-class' property.
+ This has the side effects of calling `shared-initialize', setting the
+ module's state to T, and checking for unrecognized properties. (Therefore
+ subclasses should add a method to `shared-initialize' taking care of
+ looking at interesting properties, just to make sure they're ticked
+ off.)"))
+
+;;;--------------------------------------------------------------------------
+;;; Module objects.
+
+(export '(module module-name module-pset module-items module-dependencies))
+(defclass module ()
+ ((name :initarg :name :type pathname :reader module-name)
+ (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
+ (items :initarg :items :initform nil :type list :accessor module-items)
+ (dependencies :initarg :dependencies :initform nil
+ :type list :accessor module-dependencies)
+ (state :initarg :state :initform nil :accessor module-state))
+ (:documentation
+ "A module is a container for the definitions made in a source file.
+
+ Modules are the fundamental units of translation. The main job of a
+ module is to remember which definitions it contains, so that they can be
+ translated and written to output files. The module contains the following
+ handy bits of information:
+
+ * A (path) name, which is the filename we used to find it. The default
+ output filenames are derived from this. (We use the file's truename
+ as the hash key to prevent multiple inclusion, and that's a different
+ thing.)
+
+ * A property list containing other useful things.
+
+ * A list of items which the module contains.
+
+ * A list of other modules that this one depends on.
+
+ Modules are usually constructed by the `read-module' function, though
+ there's nothing to stop fancy extensions building modules
+ programmatically."))
+
+(export 'define-module)
+(defmacro define-module
+ ((name &key (truename nil truenamep) (location nil locationp))
+ &body body)
+ "Define a new module.
+
+ The module will be called NAME; it will be included in the *module-map*
+ only if it has a TRUENAME (which defaults to the truename of NAME, or nil
+ if there is no file with that name). The module is populated by
+ evaluating the BODY in a dynamic environment where *module* is bound to
+ the module under construction, and any other module variables are bound to
+ appropriate initial values -- see `*module-bindings-alist*' and
+ `define-module-var'.
+
+ Evaluation order irregularity: the TRUENAME and LOCATION arguments are
+ always evaluated in that order, regardless of their order in the macro
+ call site."
+
+ `(build-module ,name
+ (lambda () ,@body)
+ ,@(and truenamep `(:truename ,truename))
+ ,@(and locationp `(:location ,location))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Output scheduling protocol
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Sequencing machinery.
+
+(export '(sequencer-item make-sequencer-item sequencer-item-p
+ sequencer-item-name sequencer-item-functions))
+(defstruct (sequencer-item
+ (:constructor make-sequencer-item (name &optional functions)))
+ "Represents a distinct item to be sequenced by a `sequencer'.
+
+ A `sequencer-item' maintains a list of FUNCTIONS which are invoked when
+ the sequencer is invoked."
+ (name nil :read-only t)
+ (functions nil :type list))
+
+(export '(sequencer sequencer-constraints sequencer-table))
+(defclass sequencer ()
+ ((constraints :initarg :constraints :initform nil
+ :type list :accessor sequencer-constraints)
+ (table :initform (make-hash-table :test #'equal)
+ :reader sequencer-table))
+ (:documentation
+ "A sequencer tracks items and invokes them in the proper order.
+
+ The job of a SEQUENCER object is threefold. Firstly, it collects
+ sequencer items and stores them in its table indexed by name. Secondly,
+ it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly,
+ it can be instructed to invoke the items in an order compatible with the
+ established constraints.
+
+ Sequencer item names may may any kind of object which can be compared with
+ EQUAL. In particular, symbols, integers and strings are reasonable
+ choices for atomic names, and lists work well for compound names -- so
+ it's possible to construct a hierarchy."))
+
+(export 'ensure-sequencer-item)
+(defgeneric ensure-sequencer-item (sequencer name)
+ (:documentation
+ "Arrange that SEQUENCER has a sequencer-item called NAME.
+
+ Returns the corresponding SEQUENCER-ITEM object."))
+
+(export 'add-sequencer-constraint)
+(defgeneric add-sequencer-constraint (sequencer constraint)
+ (:documentation
+ "Attach the given CONSTRAINT to an SEQUENCER.
+
+ The CONSTRAINT should be a list of sequencer-item names; see
+ ENSURE-SEQUENCER-ITEM for what they look like. Note that the names
+ needn't have been declared in advance; indeed, they needn't be mentioned
+ anywhere else at all."))
+
+(export 'add-sequencer-item-function)
+(defgeneric add-sequencer-item-function (sequencer name function)
+ (:documentation
+ "Arranges to call FUNCTION when the item called NAME is traversed.
+
+ More than one function can be associated with a given sequencer item.
+ They are called in the same order in which they were added.
+
+ Note that an item must be mentioned in at least one constraint in order to
+ be traversed by INVOKE-SEQUENCER-ITEMS. If there are no special ordering
+ requirments for a particular item, then the trivial constraint (NAME) will
+ suffice."))
+
+(export 'invoke-sequencer-items)
+(defgeneric invoke-sequencer-items (sequencer &rest arguments)
+ (:documentation
+ "Invoke functions attached to the SEQUENCER's items in the right order.
+
+ Each function is invoked in turn with the list of ARGUMENTS. The return
+ values of the functions are discarded."))
+
+;;;--------------------------------------------------------------------------
+;;; Output preparation.
+
+(defgeneric hook-output (object reason sequencer)
+ (:documentation
+ "Announces the intention to write SEQUENCER, with a particular REASON.
+
+ The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which
+ can be matched using an EQL-specializer. In response, OBJECT should add
+ any constrains and item functions that it wishes, and pass the
+ announcement to its sub-objects. It is not uncommon for an object to pass
+ a reason to its sub-objects that is different from the REASON with which
+ it was itself invoked.")
+
+ (:method-combination progn)
+ (:method progn (object reason sequencer)))
+
+;;;--------------------------------------------------------------------------
+;;; Useful syntax.
+
+(defmacro sequence-output
+ ((streamvar sequencer) &body clauses)
+ "Register output behaviour in a convenient manner.
+
+ The full syntax isn't quite as described:
+
+ sequence-output (STREAMVAR SEQUENCER)
+ { :constrant CONSTRAINT }*
+ CLAUSE*
+
+ STREAMVAR ::= a symbol
+ SEQUENCER ::= a sequencer object, evaluated
+ CONSTRAINT ::= ( ITEM-NAME* )
+ CLAUSE ::= (ITEM-NAME FORM*)
+ ITEM-NAME ::= an atom or a list of expressions
+
+ An ITEM-NAME may be a self-evaluating atom (in which case it stands for
+ itself, clearly), a symbol (in which case the corresponding variable value
+ is used) or a list of forms (in which case the name used is the list of
+ the corresponding values).
+
+ The behaviour is as follows. The CONSTRAINTS, if any, are added to the
+ sequencer. Then, for each CLAUSE, a function is attached to the named
+ sequencer item whose behaviour is to bind STREAMVAR to the output stream
+ and evaluate the FORMs as a progn."
+
+ (let ((seqvar (gensym "SEQ")))
+ (labels ((convert-item-name (name)
+ (if (listp name)
+ (cons 'list name)
+ name))
+ (convert-constraint (constraint)
+ (cons 'list (mapcar #'convert-item-name constraint)))
+ (process-body (clauses)
+ (if (eq (car clauses) :constraint)
+ (cons `(add-sequencer-constraint
+ ,seqvar
+ ,(convert-constraint (cadr clauses)))
+ (process-body (cddr clauses)))
+ (mapcar (lambda (clause)
+ (let ((name (car clause))
+ (body (cdr clause)))
+ `(add-sequencer-item-function
+ ,seqvar
+ ,(convert-item-name name)
+ (lambda (,streamvar)
+ ,@body))))
+ clauses))))
+ `(let ((,seqvar ,sequencer))
+ ,@(process-body clauses)))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Protocol for property sets
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+;;; Property representation.
+
+(export 'property-key)
+(defun property-key (name)
+ "Convert NAME into a keyword.
+
+ If NAME isn't a symbol already, then flip its case (using
+ `frob-identifier'), and intern into the `keyword' package."
+ (etypecase name
+ (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)) :integer)
+ (: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))
+(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)))))
+ "A simple structure for holding a property in a property set.
+
+ The main useful feature is the ability to tick off properties which have
+ been used, so that we can complain about unrecognized properties.
+
+ An explicit type tag is necessary because we need to be able to talk
+ distinctly about identifiers, strings and symbols, and we've only got two
+ obvious Lisp types to play with. Sad, but true."
+
+ (name nil :type (or string symbol))
+ (value nil :type t)
+ (type nil :type symbol)
+ (location (file-location nil) :type file-location)
+ (key nil :type symbol)
+ (seenp nil :type boolean))
+
+(defun string-to-symbol
+ (string &key (package *package*) (swap-case t) (swap-hyphen t))
+ "Convert STRING to a symbol in PACKAGE.
+
+ Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the
+ package; PACKAGE is used if there isn't a prefix. A doubled colon allows
+ access to internal symbols, and will intern if necessary. Note that
+ escape characters are /not/ processed; don't put colons in package names
+ if you want to use them from SOD property sets.
+
+ The portions of the string are modified by `frob-identifier'; the
+ arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to
+ control this process."
+
+ (let* ((length (length string))
+ (colon (position #\: string)))
+ (multiple-value-bind (start internalp)
+ (cond ((not colon) (values 0 t))
+ ((and (< (1+ colon) length)
+ (char= (char string (1+ colon)) #\:))
+ (values (+ colon 2) t))
+ (t
+ (values (1+ colon) nil)))
+ (when colon
+ (let* ((package-name (if (zerop colon) "KEYWORD"
+ (frob-identifier (subseq string 0 colon)
+ :swap-case swap-case
+ :swap-hyphen swap-hyphen)))
+ (found (find-package package-name)))
+ (unless found
+ (error "Unknown package `~A'" package-name))
+ (setf package found)))
+ (let ((name (frob-identifier (subseq string start)
+ :swap-case swap-case
+ :swap-hyphen swap-hyphen)))
+ (multiple-value-bind (symbol status)
+ (funcall (if internalp #'intern #'find-symbol) name package)
+ (cond ((or internalp (eq status :external))
+ symbol)
+ ((not status)
+ (error "Symbol `~A' not found in package `~A'"
+ name (package-name package)))
+ (t
+ (error "Symbol `~A' not external in package `~A'"
+ name (package-name package)))))))))
+
+(export 'coerce-property-value)
+(defgeneric coerce-property-value (value type wanted)
+ (:documentation
+ "Convert VALUE, a property of type TYPE, to be of type WANTED.
+
+ It's sensible to add additional methods to this function, but there are
+ all the ones we need.")
+
+ ;; If TYPE matches WANTED, we'll assume that VALUE already has the right
+ ;; form. Otherwise, if nothing else matched, then I guess we'll have to
+ ;; say it didn't work.
+ (:method (value type wanted)
+ (if (eql type wanted) value
+ (error "Incorrect type: expected ~A but found ~A" wanted type)))
+
+ ;; If the caller asks for type T then give him the raw thing.
+ (:method (value type (wanted (eql t)))
+ value))
+
+;;;--------------------------------------------------------------------------
+;;; Property set representation.
+
+(export '(pset psetp))
+(defstruct (pset (:predicate psetp)
+ (:constructor %make-pset)
+ (:conc-name %pset-))
+ "A property set.
+
+ Wrapped up in a structure so that we can define a print function."
+ (hash (make-hash-table) :type hash-table))
+
+(export '(make-pset pset-get pset-store pset-map))
+(declaim (inline make-pset pset-get pset-store pset-map))
+
+(defun make-pset ()
+ "Constructor for property sets."
+ (%make-pset))
+
+(defun pset-get (pset key)
+ "Look KEY up in PSET and return what we find.
+
+ If there's no property by that name, return NIL."
+ (values (gethash key (%pset-hash pset))))
+
+(defun pset-store (pset prop)
+ "Store property PROP in PSET.
+
+ Overwrite or replace any previous property with the same name. Mutates
+ the property set."
+ (setf (gethash (p-key prop) (%pset-hash pset)) prop))
+
+(defun pset-map (func pset)
+ "Call FUNC for each property in PSET."
+ (maphash (lambda (key value) (declare (ignore key)) (funcall func value))
+ (%pset-hash pset)))
+
+(export 'with-pset-iterator)
+(defmacro with-pset-iterator ((name pset) &body body)
+ "Evaluate BODY with NAME bound to a macro returning properties from PSET.
+
+ Evaluating (NAME) returns a property object or nil if all properties have
+ been read."
+ (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))))
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; `Cooked' property set operations.
+
+(export 'store-property)
+(defun store-property
+ (pset name value &key (type (property-type value)) location)
+ "Store a property in PSET."
+ (pset-store pset
+ (make-property name value :type type :location location)))
+
+(export 'get-property)
+(defun get-property (pset name type &optional default)
+ "Fetch a property from a property set.
+
+ If a property NAME is not found in PSET, or if a property is found, but
+ its type doesn't match TYPE, then return DEFAULT and nil; otherwise return
+ the value and its file location. In the latter case, mark the property as
+ having been used.
+
+ The value returned depends on the TYPE argument provided. If you pass NIL
+ then you get back the entire PROPERTY object. If you pass `t', then you
+ get whatever was left in the property set, uninterpreted. Otherwise the
+ value is coerced to the right kind of thing (where possible) and returned.
+
+ If PSET is nil, then return DEFAULT."
+
+ (let ((prop (and pset (pset-get pset (property-key name)))))
+ (with-default-error-location ((and prop (p-location prop)))
+ (cond ((not prop)
+ (values default nil))
+ ((not type)
+ (setf (p-seenp prop) t)
+ (values prop (p-location prop)))
+ (t
+ (setf (p-seenp prop) t)
+ (values (coerce-property-value (p-value prop)
+ (p-type prop)
+ type)
+ (p-location prop)))))))
+
+(export 'add-property)
+(defun add-property
+ (pset name value &key (type (property-type value)) location)
+ "Add a property to PSET.
+
+ If a property with the same NAME already exists, report an error."
+
+ (with-default-error-location (location)
+ (let ((existing (get-property pset name nil)))
+ (when existing
+ (error "Property ~S already defined~@[ at ~A~]"
+ name (p-location existing)))
+ (store-property pset name value :type type :location location))))
+
+(export 'make-property-set)
+(defun make-property-set (&rest plist)
+ "Make a new property set, with given properties.
+
+ This isn't the way to make properties when parsing, but it works well for
+ programmatic generation. The arguments should form a property list
+ (alternating keywords and values is good).
+
+ 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."
+
+ (property-set plist))
+
+(export 'property-set)
+(defgeneric property-set (thing)
+ (:documentation
+ "Convert THING into a property set.")
+ (:method ((pset pset)) pset)
+ (:method ((list list))
+ "Convert a list into a property set. This works for alists and plists."
+ (multiple-value-bind (next name value)
+ (if (and list (consp (car list)))
+ (values #'cdr #'caar #'cdar)
+ (values #'cddr #'car #'cadr))
+ (do ((pset (make-pset))
+ (list list (funcall next list)))
+ ((endp list) pset)
+ (add-property pset (funcall name list) (funcall value list))))))
+
+(export 'check--unused-properties)
+(defun check-unused-properties (pset)
+ "Issue errors about unused properties in PSET."
+ (when pset
+ (pset-map (lambda (prop)
+ (unless (p-seenp prop)
+ (cerror*-with-location (p-location prop)
+ "Unknown property `~A'"
+ (p-name prop))
+ (setf (p-seenp prop) t)))
+ pset)))
+
+;;;--------------------------------------------------------------------------
+;;; Utility macros.
+
+(defmacro default-slot-from-property
+ ((instance slot slot-names)
+ (pset property type
+ &optional (pvar (gensym "PROP-"))
+ &rest convert-forms)
+ &body default-forms)
+ "Initialize a slot from a property.
+
+ We initialize SLOT in INSTANCE. In full: if PSET contains a property
+ called NAME, then convert it to TYPE, bind the value to PVAR and evaluate
+ CONVERT-FORMS -- these default to just using the property value. If
+ there's no property, and the slot is named in SLOT-NAMES and currently
+ unbound, then evaluate DEFAULT-FORMS and use their value to compute the
+ slot value."
+
+ (once-only (instance slot slot-names pset property type)
+ (with-gensyms (floc)
+ `(multiple-value-bind (,pvar ,floc)
+ (get-property ,pset ,property ,type)
+ (if ,floc
+ (setf (slot-value ,instance ,slot)
+ (with-default-error-location (,floc)
+ ,@(or convert-forms `(,pvar))))
+ (default-slot (,instance ,slot ,slot-names)
+ ,@default-forms))))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+(in-package #:sod)
+
+(defun try-parse* (parser string)
+ (call-with-module-environment
+ (lambda ()
+ (let* ((char-scanner (make-string-scanner string))
+ (scanner (make-instance 'sod-token-scanner
+ :char-scanner char-scanner)))
+ (funcall parser scanner)))))
+
+(defmacro try-parse ((scanner string) &body parser)
+ `(try-parse* (lambda (,scanner)
+ (with-parser-context
+ (token-scanner-context :scanner ,scanner)
+ ,@parser))
+ ,string))
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Tests for the Simple Object Design translator
+;;;
+;;; (c) 2009 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:defpackage #:sod-test-sysdef
+ (:use #:common-lisp #:asdf))
+
+(cl:in-package #:sod-test-sysdef)
+
+;;;--------------------------------------------------------------------------
+;;; Definition.
+
+(defsystem sod-test
+
+ ;; Boring copyright stuff.
+ :version "1.0.0"
+ :author "Mark Wooding"
+ :license "GNU General Public License, version 2 or later"
+
+ ;; Documentation.
+ :description "Tests for the Sensible Object Design translator."
+
+ :long-description
+ "This system provides unit tests for the Sod translator."
+
+ :depends-on ("sod" "xlunit")
+
+ :components
+ ((:file "test-base")
+
+ ;; Test the parser edifice.
+ (:module "parser" :depends-on ("test-base") :components
+ ((:file "test-parser")
+ (:file "test-scanner-charbuf")))
+
+ ;; The actual tests.
+ (:file "test-c-types" :depends-on ("test-base"))
+ (:file "test-codegen" :depends-on ("test-base"))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+(defmethod perform ((op test-op) (system (eql (find-system "sod-test"))))
+ (operate 'load-op system)
+ (funcall (find-symbol "RUN-TESTS" "SOD-TEST")))
+
+;;;--------------------------------------------------------------------------
+;;; Hacks.
+
+(defmethod perform :around
+ ((op compile-op) (component (eql (find-system "sod-test"))))
+ (let ((*compile-file-failure-behaviour* :warn))
+ (call-next-method)))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; System definition for the Simple Object Design translator
+;;;
+;;; (c) 2009 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:defpackage #:sod-sysdef
+ (:use #:common-lisp #:asdf))
+
+(cl:in-package #:sod-sysdef)
+
+;;;--------------------------------------------------------------------------
+;;; Definition.
+
+(defsystem sod
+
+ ;; Boring copyright stuff.
+ :version "1.0.0"
+ :author "Mark Wooding"
+ :license "GNU General Public License, version 2 or later"
+
+ ;; Documentation.
+ :description "A Sensible Object Design for C."
+
+ :long-description
+ "This system implements a fairly simple, yet powerful object system for
+ plain old C. Its main features are as follows.
+
+ * Multiple inheritance, done properly (unlike C++, say), with a
+ superclass linearlization algorithm, and exactly one copy of any
+ superclass's slots.
+
+ * Method combinations, and multiple flavours of methods, to make mixin
+ classes more useful.
+
+ * The default method combination doesn't depend on the programmer
+ statically predicting which superclass's method to delegate to.
+ Multiple inheritance makes this approach (taken by C++) fail: the
+ right next method might be an unknown sibling, and two siblings might
+ be in either order depending on descendents.
+
+ * Minimal runtime support requirements, so that it's suitable for use
+ wherever C is -- e.g., interfacing to other languages."
+
+ :components
+ ((:file "utilities")
+
+ ;; Parser equipment. This is way more elaborate than it needs to be, but
+ ;; it was interesting, and it may well get split off into a separate
+ ;; library.
+ (:module "parser" :depends-on ("utilities") :components
+ ((:file "package")
+
+ ;; File location protocol (including error reporting).
+ (:file "proto-floc" :depends-on ("package"))
+ (:file "impl-floc" :depends-on ("proto-floc"))
+
+ ;; Position-aware streams.
+ (:file "proto-streams" :depends-on ("package"))
+ (:file "impl-streams" :depends-on ("proto-streams" "proto-floc"))
+
+ ;; Scanner protocol, and various scanner implementations.
+ (:file "proto-scanner" :depends-on ("package"))
+ (:file "impl-scanner" :depends-on ("proto-scanner"))
+ (:file "impl-scanner-charbuf" :depends-on
+ ("proto-scanner" "proto-floc" "proto-streams"))
+ (:file "impl-scanner-token" :depends-on ("proto-scanner"))
+
+ ;; Parser notation macro support.
+ (:file "proto-parser" :depends-on ("package"))
+ (:file "impl-parser" :depends-on ("proto-parser"))
+
+ ;; Expression parser support.
+ (:file "proto-parser-expr" :depends-on ("proto-parser"))
+ (:file "impl-parser-expr" :depends-on ("proto-parser-expr"))
+
+ ;; Stitching parsers to scanners.
+ (:file "impl-scanner-context" :depends-on
+ ("proto-parser" "proto-scanner"))))
+
+ (:file "package" :depends-on ("parser"))
+
+ ;; C type representation protocol.
+ (:file "proto-c-types" :depends-on ("package"))
+ (:file "impl-c-types" :depends-on ("proto-c-types"))
+
+ ;; Property set protocol.
+ (:file "proto-pset" :depends-on ("package"))
+ (:file "impl-pset" :depends-on ("proto-pset"))
+
+ ;; Lexical analysis.
+ ;;(:file "proto-lexer" :depends-on ("parser"))
+ ;;(:file "impl-lexer" :depends-on ("proto-lexer"))
+
+ ;; Code generation protocol.
+ (:file "proto-codegen" :depends-on ("package"))
+ (:file "impl-codegen" :depends-on ("proto-codegen"))
+
+ ;; Modules.
+ (:file "proto-module" :depends-on ("package"))
+ (:file "impl-module" :depends-on
+ ("proto-module" "proto-pset" "impl-c-types-class" "builtin"))
+ (:file "builtin" :depends-on ("proto-module" "proto-pset" "classes"
+ "impl-c-types" "impl-c-types-class"))
+
+ ;; Output.
+ (:file "proto-output" :depends-on ("package"))
+ (:file "impl-output" :depends-on ("proto-output"))
+
+ ;; Class representation.
+ (:file "classes" :depends-on ("package" "proto-c-types"))
+ (:file "impl-c-types-class" :depends-on ("classes" "proto-module"))
+ (:file "class-utilities" :depends-on
+ ("classes" "impl-codegen" "impl-pset"
+ "impl-c-types" "impl-c-types-class"))
+
+ ;; Class construction.
+ (:file "proto-class-make" :depends-on ("class-utilities"))
+ (:file "impl-class-make" :depends-on ("proto-class-make"))
+
+ ;; Class layout.
+ (:file "proto-class-layout" :depends-on ("class-utilities"))
+ (:file "impl-class-layout" :depends-on
+ ("proto-class-layout" "proto-method"))
+
+ ;; Class finalization.
+ (:file "proto-class-finalize" :depends-on ("class-utilities"))
+ (:file "impl-class-finalize" :depends-on ("proto-class-finalize"))
+
+ ;; Method generation.
+ (:file "proto-method" :depends-on ("class-utilities"))
+ (:file "impl-method" :depends-on ("proto-method"))
+
+ ;; Class output.
+ (:file "output-class" :depends-on ("proto-output" "classes"))))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+(defmethod perform ((op test-op) (component (eql (find-system "sod"))))
+ (operate 'test-op "sod-test" :force t))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Package definition and other basic stuff for SOD tests
+;;;
+;;; (c) 2009 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:defpackage #:sod-test
+ (:use #:common-lisp
+
+ #+sbcl #:sb-mop
+ #+(or cmu clisp) #:mop
+ #+ecl #:mop
+
+ #:xlunit
+
+ #:sod-utilities #:sod-parser #:sod)
+
+ ;; Some internal symbols which are useful. This is somewhat bletcherous.
+ (:import-from #:sod-parser #:charbuf-size))
+
+(cl:in-package #:sod-test)
+
+(defvar *sod-test-suite*
+ (make-instance 'test-suite
+ :name "Sod master test suite"
+ :description "Top-level test for the Sod translator."))
+
+(defun assert-princ (object string)
+ (let ((*print-right-margin* 77)
+ (print (princ-to-string object)))
+ (assert-equal print string
+ (format nil "Assert princ: ~S ~_prints as `~A' ~_~
+ rather than `~A'."
+ object print string))))
+
+(defun run-tests ()
+ (textui-test-run *sod-test-suite*))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Test handling of C types
+;;;
+;;; (c) 2009 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 c-types-test (test-case) ())
+(add-test *sod-test-suite* (get-suite c-types-test))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(defun assert-cteqp (a b)
+ (unless (c-type-equal-p a b)
+ (failure "Assert equal C types: ~A ~_and ~A" a b)))
+
+(defun assert-not-cteqp (a b)
+ (when (c-type-equal-p a b)
+ (failure "Assert unequal C types: ~A ~_and ~A" a b)))
+
+(defun assert-pp-ctype (type kernel string)
+ (let* ((*print-right-margin* 77)
+ (print (with-output-to-string (out)
+ (pprint-c-type type out kernel))))
+ (assert-equal print string
+ (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~
+ rather than `~A'."
+ type kernel print string))))
+
+;;;--------------------------------------------------------------------------
+;;; Simple types.
+
+(def-test-method intern-trivial-simple-type ((test c-types-test) :run nil)
+ (assert-eql (c-type "foo") (make-simple-type "foo")))
+
+(def-test-method intern-qualified-simple-type ((test c-types-test) :run nil)
+ (assert-eql (c-type ("foo" :const :volatile))
+ (make-simple-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-simple-type ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo")))
+
+(def-test-method print-simple-type ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type "foo") "f" "foo f"))
+
+(def-test-method print-simple-type-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type "foo") nil "foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Tagged types.
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+ (assert-eql (c-type (struct "foo")) (make-struct-type "foo")))
+
+(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil)
+ (assert-eql (c-type (enum "foo" :const :volatile))
+ (make-enum-type "foo" '(:volatile :const :volatile))))
+
+(def-test-method mismatch-tagged-type ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (enum "foo" :restrict))
+ (make-union-type "foo" '(:restrict))))
+
+(def-test-method print-struct-type ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f"))
+
+(def-test-method print-union-type-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (union "foo")) nil "union foo"))
+
+;;;--------------------------------------------------------------------------
+;;; Pointer types.
+
+(def-test-method intern-trivial-pointer ((test c-types-test) :run nil)
+ (assert-eql (c-type (* "foo"))
+ (make-pointer-type (make-simple-type "foo"))))
+
+(def-test-method intern-qualified-pointer ((test c-types-test) :run nil)
+ (assert-eql (c-type (* "foo" :const :volatile))
+ (make-pointer-type (make-simple-type "foo")
+ '(:volatile :const))))
+
+(def-test-method intern-double-indirection ((test c-types-test) :run nil)
+ (assert-eql (c-type (* (* "foo")))
+ (make-pointer-type
+ (make-pointer-type (make-simple-type "foo")))))
+
+(def-test-method non-intern-complex-pointer ((test c-types-test) :run nil)
+ ;; The protocol doesn't specify what we do here; but we want to avoid
+ ;; interning pointers to non-interned types in order to prevent the intern
+ ;; table filling up with cruft. So test anyway.
+ (let ((a (c-type (* ([] "foo" 16))))
+ (b (make-pointer-type
+ (make-array-type (make-simple-type "foo") '(16)))))
+ (assert-not-eql a b)
+ (assert-cteqp a b)))
+
+(def-test-method print-pointer ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char)) "p" "char *p"))
+
+(def-test-method print-qualified-pointer ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p"))
+
+(def-test-method print-pointer-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char)) nil "char *"))
+
+(def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* char :const)) nil "char *const"))
+
+;;;--------------------------------------------------------------------------
+;;; Array types.
+
+(def-test-method compare-simple-arrays ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] int 10))
+ (make-array-type (make-simple-type "int") (list 10))))
+
+(def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] int 10 4))
+ (c-type ([] ([] int 4) 10))))
+
+(def-test-method compare-multiarrays ((test c-types-test) :run nil)
+ (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method bad-compare-multiarrays ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 5) 10))))
+
+(def-test-method compare-misshaped ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8))
+ (c-type ([] ([] ([] int 6) 9 8 7) 10))))
+
+(def-test-method print-array ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo"
+ "int foo[10][9][8][7][6]"))
+
+(def-test-method print-array-abs ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil
+ "int[10][9][8][7][6]"))
+
+(def-test-method print-array-of-pointers ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type ([] (* char))) nil "char *[]"))
+
+(def-test-method print-pointer-to-array ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]"))
+
+;;;--------------------------------------------------------------------------
+;;; Function types.
+
+(def-test-method compare-simple-functions ((test c-types-test) :run nil)
+ ;; Argument names don't matter.
+ (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+ (make-function-type (make-simple-type "int")
+ (list
+ (make-argument "foo"
+ (make-simple-type "int"))
+ (make-argument "bar"
+ (c-type double))))))
+
+(def-test-method build-argument-tail ((test c-types-test) :run nil)
+ (assert-cteqp (c-type (fun int ("a" int) ("b" double)))
+ (c-type (fun int ("foo" int)
+ . (list (make-argument "bar"
+ (c-type double)))))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+ (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil)
+ (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis))
+ (c-type (fun int ("y" int) ("z" double)))))
+
+(def-test-method print-signal ((test c-types-test) :run nil)
+ (assert-pp-ctype (c-type (fun (* (fun int (nil int)))
+ ("signo" int)
+ ("handler" (* (fun int (nil int))))))
+ "signal"
+ "int (*signal(int signo, int (*handler)(int)))(int)"))
+
+(def-test-method print-commentify ((test c-types-test) :run nil)
+ (assert-pp-ctype (commentify-function-type
+ (c-type (fun int
+ ("n" size-t)
+ (nil string)
+ ("format" const-string)
+ :ellipsis)))
+ "snprintf"
+ (concatenate 'string
+ "int snprintf(size_t /*n*/, char *, "
+ "const char */*format*/, "
+ "...)")))
+
+(def-test-method commentify-non-recursive ((test c-types-test) :run nil)
+ ;; Also checks pretty-printing.
+ (assert-pp-ctype (commentify-function-type
+ (c-type (fun int
+ ("dirpath" const-string)
+ ("fn" (* (fun int
+ ("fpath" const-string)
+ ("sb" (* (struct "stat"
+ :const)))
+ ("typeflag" int))))
+ ("nopenfd" int))))
+ "ftw"
+ (format nil "~
+int ftw(const char */*dirpath*/,
+ int (*/*fn*/)(const char *fpath,
+ const struct stat *sb,
+ int typeflag),
+ int /*nopenfd*/)")))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Tests for code generator
+;;;
+;;; (c) 2009 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)
+
+;;;--------------------------------------------------------------------------
+
+(defclass gcd-codegen-test (test-case)
+ (codegen))
+(add-test *sod-test-suite* (get-suite gcd-codegen-test))
+
+(defun make-gcd (codegen)
+
+ (codegen-push codegen)
+ (loop for (name init) in '(("aa" 1) ("bb" 0))
+ do (ensure-var codegen name (c-type int) init))
+ (codegen-push codegen)
+ (with-temporary-var (codegen r (c-type int))
+ (emit-inst codegen(make-set-inst r "u%v"))
+ (with-temporary-var (codegen q (c-type int))
+ (emit-inst codegen (make-set-inst q "u/v"))
+ (with-temporary-var (codegen a (c-type int))
+ (emit-insts codegen
+ (list (make-set-inst a "aa")
+ (make-set-inst "aa" "bb")
+ (make-set-inst "bb"
+ (format nil "~A - ~A*bb" a q))))))
+ (emit-insts codegen (list (make-set-inst "u" "v")
+ (make-set-inst "v" r))))
+ (emit-inst codegen (make-while-inst "v" (codegen-pop-block codegen)))
+ (emit-inst codegen (make-if-inst "a" (make-set-inst "*a" "aa") nil))
+ (deliver-expr codegen :return "u")
+ (codegen-pop-function codegen "gcd"
+ (c-type (fun int
+ ("u" int)
+ ("v" int)
+ ("a" (* int)))))
+
+ (codegen-push codegen)
+ (loop for (name init) in '(("u" "atoi(argv[1])")
+ ("v" "atoi(argv[2])")
+ ("a"))
+ do (ensure-var codegen name (c-type int) init))
+ (ensure-var codegen "g" (c-type int)
+ (make-call-inst "gcd" (list "u" "v" "&a")))
+ (emit-inst codegen (make-expr-inst
+ (make-call-inst "printf"
+ (list "\"%d*%d == %d (mod %d)\\n\""
+ "a" "u" "g" "v"))))
+ (deliver-expr codegen :return 0)
+ (codegen-pop-function codegen "main"
+ (c-type (fun int
+ ("argc" int)
+ ("argv" ([] string))))))
+
+(defmethod set-up ((test gcd-codegen-test))
+ (with-slots (codegen) test
+ (setf codegen (make-instance 'codegen))
+ (make-gcd codegen)))
+
+(def-test-method check-output ((test gcd-codegen-test) :run nil)
+ (assert-princ (codegen-functions (slot-value test 'codegen))
+ "(static int gcd(int u, int v, int *a)
+ {
+ int aa = 1;
+ int bb = 0;
+
+ while (v) {
+ int sod__v0;
+ int sod__v1;
+ int sod__v2;
+
+ sod__v0 = u%v;
+ sod__v1 = u/v;
+ sod__v2 = aa;
+ aa = bb;
+ bb = sod__v2 - sod__v1*bb;
+ u = v;
+ v = sod__v0;
+ }
+ if (a) *a = aa;
+ return (u);
+ }
+
+
+ static int main(int argc, char *argv[])
+ {
+ int u = atoi(argv[1]);
+ int v = atoi(argv[2]);
+ int a;
+ int g = gcd(u, v, &a);
+
+ printf(\"%d*%d == %d (mod %d)\\n\", a, u, g, v);
+ return (0);
+ }
+
+ )"))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Various handy utilities
+;;;
+;;; (c) 2009 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:defpackage #:sod-utilities
+ (:use #:common-lisp
+
+ ;; MOP from somewhere.
+ #+sbcl #:sb-mop
+ #+(or cmu clisp) #:mop
+ #+ecl #:clos))
+
+(cl:in-package #:sod-utilities)
+
+;;;--------------------------------------------------------------------------
+;;; Macro hacks.
+
+(export 'with-gensyms)
+(defmacro with-gensyms ((&rest binds) &body body)
+ "Evaluate BODY with variables bound to fresh symbols.
+
+ The BINDS are a list of entries (VAR [NAME]), and a singleton list can be
+ replaced by just a symbol; each VAR is bound to a fresh symbol generated
+ by (gensym NAME), where NAME defaults to the symbol-name of VAR."
+ `(let (,@(mapcar (lambda (bind)
+ (multiple-value-bind (var name)
+ (if (atom bind)
+ (values bind (concatenate 'string
+ (symbol-name bind) "-"))
+ (destructuring-bind
+ (var &optional
+ (name (concatenate 'string
+ (symbol-name var) "-")))
+ bind
+ (values var name)))
+ `(,var (gensym ,name))))
+ binds))
+ ,@body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun strip-quote (form)
+ "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO.
+
+ If FORM is a symbol whose constant value is `nil' then return `nil'.
+ Otherwise return FORM unchanged. This makes it easier to inspect constant
+ things. This is a utility for `once-only'."
+
+ (cond ((and (consp form)
+ (eq (car form) 'quote)
+ (cdr form)
+ (null (cddr form)))
+ (let ((body (cadr form)))
+ (if (or (not (or (consp body) (symbolp body)))
+ (member body '(t nil))
+ (keywordp body))
+ body
+ form)))
+ ((and (symbolp form) (boundp form) (null (symbol-value form)))
+ nil)
+ (t
+ form))))
+
+(export 'once-only)
+(defmacro once-only (binds &body body)
+ "Macro helper for preventing repeated evaluation.
+
+ The syntax is actually hairier than shown:
+
+ once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* )
+ { FORM }*
+
+ So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list
+ can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR.
+ But before them you can have keyword arguments. Only one is defined so
+ far. See below for the crazy things that does.
+
+ The result of evaluating a ONCE-ONLY form is a form with the structure
+
+ (let ((#:GS1 VALUE-FORM1)
+ ...
+ (#:GSn VALUE-FORMn))
+ STUFF)
+
+ where STUFF is the value of the BODY forms, as an implicit progn, in an
+ environment with the VARs bound to the corresponding gensyms.
+
+ As additional magic, if any of the VALUE-FORMs is actually constant (as
+ determined by inspection, and aided by `constantp' if an :environment is
+ supplied, then no gensym is constructed for it, and the VAR is bound
+ directly to the constant form. Moreover, if the constant form looks like
+ (quote FOO) for a self-evaluating FOO then the outer layer of quoting is
+ stripped away."
+
+ ;; We need an extra layer of gensyms in our expansion: we'll want the
+ ;; expansion to examine the various VALUE-FORMs to find out whether they're
+ ;; constant without evaluating them repeatedly. This also helps with
+ ;; another problem: we explicitly encourage the rebinding of a VAR
+ ;; (probably a macro argument) to a gensym which will be bound to the value
+ ;; of the form previously held in VAR itself -- so the gensym and value
+ ;; form must exist at the same time and we need two distinct variables.
+
+ (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-"))
+ (let ((env nil))
+
+ ;; First things first: let's pick up the keywords.
+ (loop
+ (unless (and binds (keywordp (car binds)))
+ (return))
+ (ecase (pop binds)
+ (:environment (setf env (pop binds)))))
+
+ ;; Now we'll investigate the bindings. Turn each one into a list (VAR
+ ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note
+ ;; above.
+ (let ((canon (mapcar (lambda (bind)
+ (multiple-value-bind (var form)
+ (if (atom bind)
+ (values bind bind)
+ (destructuring-bind
+ (var &optional (form var)) bind
+ (values var form)))
+ (list var form
+ (gensym (format nil "T-~A-"
+ (symbol-name var))))))
+ binds)))
+
+ `(let* (,@(and env `((,envvar ,env)))
+ (,lets nil)
+ ,@(mapcar (lambda (bind)
+ (destructuring-bind (var form temp) bind
+ (declare (ignore var))
+ `(,temp ,form)))
+ canon)
+ ,@(mapcar (lambda (bind)
+ (destructuring-bind (var form temp) bind
+ (declare (ignore form))
+ `(,var
+ (cond ((constantp ,temp
+ ,@(and env `(,envvar)))
+ (strip-quote ,temp))
+ ((symbolp ,temp)
+ ,temp)
+ (t
+ (let ((,sym (gensym
+ ,(concatenate 'string
+ (symbol-name var)
+ "-"))))
+ (push (list ,sym ,temp) ,lets)
+ ,sym))))))
+ canon))
+ (flet ((,bodyfunc () ,@body))
+ (if ,lets
+ `(let (,@(nreverse ,lets)) ,(,bodyfunc))
+ (,bodyfunc))))))))
+
+(export 'parse-body)
+(defun parse-body (body)
+ "Parse the BODY into a docstring, declarations and the body forms.
+
+ These are returned as three lists, so that they can be spliced into a
+ macro expansion easily. The declarations are consolidated into a single
+ `declare' form."
+ (let ((decls nil)
+ (doc nil))
+ (loop
+ (cond ((null body) (return))
+ ((and (consp (car body)) (eq (caar body) 'declare))
+ (setf decls (append decls (cdr (pop body)))))
+ ((and (stringp (car body)) (not doc) (cdr body))
+ (setf doc (pop body)))
+ (t (return))))
+ (values (and doc (list doc))
+ (and decls (list (cons 'declare decls)))
+ body)))
+
+;;;--------------------------------------------------------------------------
+;;; Anaphorics.
+
+(export 'it)
+
+(export 'aif)
+(defmacro aif (cond cons &optional (alt nil altp))
+ "If COND is not nil, evaluate CONS with `it' bound to the value of COND.
+
+ Otherwise, if given, evaluate ALT; `it' isn't bound in ALT."
+ (once-only (cond)
+ `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt)))))
+
+(export 'awhen)
+(defmacro awhen (cond &body body)
+ "If COND, evaluate BODY as a progn with `it' bound to the value of COND."
+ `(let ((it ,cond)) (when it ,@body)))
+
+(export 'acond)
+(defmacro acond (&rest clauses &environment env)
+ "Like COND, but with `it' bound to the value of the condition.
+
+ Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is
+ non-nil then evaluate the FORMs with `it' bound to the non-nil value, and
+ return the value of the last FORM; if there are no FORMs, then return `it'
+ itself. If the CONDITION is nil then continue with the next clause; if
+ all clauses evaluate to nil then the result is nil."
+ (labels ((walk (clauses)
+ (if (null clauses)
+ `nil
+ (once-only (:environment env (cond (caar clauses)))
+ (if (and (constantp cond)
+ (if (and (consp cond) (eq (car cond) 'quote))
+ (cadr cond) cond))
+ (if (cdar clauses)
+ `(let ((it ,cond))
+ (declare (ignorable it))
+ ,@(cdar clauses))
+ cond)
+ `(if ,cond
+ ,(if (cdar clauses)
+ `(let ((it ,cond))
+ (declare (ignorable it))
+ ,@(cdar clauses))
+ cond)
+ ,(walk (cdr clauses))))))))
+ (walk clauses)))
+
+(export '(acase aecase atypecase aetypecase))
+(defmacro acase (value &body clauses)
+ `(let ((it ,value)) (case it ,@clauses)))
+(defmacro aecase (value &body clauses)
+ `(let ((it ,value)) (ecase it ,@clauses)))
+(defmacro atypecase (value &body clauses)
+ `(let ((it ,value)) (typecase it ,@clauses)))
+(defmacro aetypecase (value &body clauses)
+ `(let ((it ,value)) (etypecase it ,@clauses)))
+
+(export 'asetf)
+(defmacro asetf (&rest places-and-values &environment env)
+ "Anaphoric update of places.
+
+ The PLACES-AND-VALUES are alternating PLACEs and VALUEs. Each VALUE is
+ evaluated with IT bound to the current value stored in the corresponding
+ PLACE."
+ `(progn ,@(loop for (place value) on places-and-values by #'cddr
+ collect (multiple-value-bind
+ (temps inits newtemps setform getform)
+ (get-setf-expansion place env)
+ `(let* (,@(mapcar #'list temps inits)
+ (it ,getform))
+ (multiple-value-bind ,newtemps ,value
+ ,setform))))))
+
+;;;--------------------------------------------------------------------------
+;;; MOP hacks (not terribly demanding).
+
+(export '(copy-instance copy-instance-using-class))
+(defgeneric copy-instance-using-class (class instance &rest initargs)
+ (:documentation
+ "Metaobject protocol hook for `copy-instance'.")
+ (:method ((class standard-class) instance &rest initargs)
+ (let ((copy (allocate-instance class)))
+ (dolist (slot (class-slots class))
+ (let ((name (slot-definition-name slot)))
+ (when (slot-boundp instance name)
+ (setf (slot-value copy name) (slot-value instance name)))))
+ (apply #'shared-initialize copy nil initargs))))
+(defun copy-instance (object &rest initargs)
+ "Construct and return a copy of OBJECT.
+
+ The new object has the same class as OBJECT, and the same slot values
+ except where overridden by INITARGS."
+ (apply #'copy-instance-using-class (class-of object) object initargs))
+
+;;;--------------------------------------------------------------------------
+;;; List utilities.
+
+(export 'make-list-builder)
+(defun make-list-builder (&optional initial)
+ "Return a simple list builder."
+
+ ;; The `builder' is just a cons cell whose cdr will be the list that's
+ ;; wanted. Effectively, then, we have a list that's one item longer than
+ ;; we actually want. The car of this extra initial cons cell is always the
+ ;; last cons in the list -- which is now well defined because there's
+ ;; always at least one.
+
+ (let ((builder (cons nil initial)))
+ (setf (car builder) (last builder))
+ builder))
+
+(export 'lbuild-add)
+(defun lbuild-add (builder item)
+ "Add an ITEM to the end of a list BUILDER."
+ (let ((new (cons item nil)))
+ (setf (cdar builder) new
+ (car builder) new))
+ builder)
+
+(export 'lbuild-add-list)
+(defun lbuild-add-list (builder list)
+ "Add a LIST to the end of a list BUILDER. The LIST will be clobbered."
+ (when list
+ (setf (cdar builder) list
+ (car builder) (last list)))
+ builder)
+
+(export 'lbuild-list)
+(defun lbuild-list (builder)
+ "Return the constructed list."
+ (cdr builder))
+
+(export 'mappend)
+(defun mappend (function list &rest more-lists)
+ "Like a nondestructive MAPCAN.
+
+ Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
+ and return the result of appending all of the resulting lists."
+ (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+
+(export '(inconsistent-merge-error merge-error-candidates))
+(define-condition inconsistent-merge-error (error)
+ ((candidates :initarg :candidates
+ :reader merge-error-candidates))
+ (:documentation
+ "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
+ (:report (lambda (condition stream)
+ (format stream "Merge inconsistency: failed to decide among ~A."
+ (merge-error-candidates condition)))))
+
+(export 'merge-lists)
+(defun merge-lists (lists &key pick (test #'eql))
+ "Return a merge of the given LISTS.
+
+ The resulting LIST contains the items of the given lists, with duplicates
+ removed. The order of the resulting list is consistent with the orders of
+ the input LISTS in the sense that if A precedes B in some input list then
+ A will also precede B in the output list. If the lists aren't consistent
+ (e.g., some list contains A followed by B, and another contains B followed
+ by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
+
+ Item equality is determined by TEST.
+
+ If there is an ambiguity at any point -- i.e., a choice between two or
+ more possible next items to emit -- then PICK is called to arbitrate.
+ PICK is called with two arguments: the list of candidate next items, and
+ the current output list. It should return one of the candidate items. If
+ PICK is omitted then an arbitrary choice is made.
+
+ The primary use of this function is in computing class precedence lists.
+ By building the input lists and selecting the PICK function appropriately,
+ a variety of different CPL algorithms can be implemented."
+
+ (do* ((lb (make-list-builder)))
+ ((null lists) (lbuild-list lb))
+
+ ;; The candidate items are the ones at the front of the input lists.
+ ;; Gather them up, removing duplicates. If a candidate is somewhere in
+ ;; one of the other lists other than at the front then we reject it. If
+ ;; we've just rejected everything, then we can make no more progress and
+ ;; the input lists were inconsistent.
+ (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
+ (leasts (remove-if (lambda (item)
+ (some (lambda (list)
+ (member item (cdr list) :test test))
+ lists))
+ candidates))
+ (winner (cond ((null leasts)
+ (error 'inconsistent-merge-error
+ :candidates candidates))
+ ((null (cdr leasts))
+ (car leasts))
+ (pick
+ (funcall pick leasts (lbuild-list lb)))
+ (t (car leasts)))))
+
+ ;; Check that the PICK function isn't conning us.
+ (assert (member winner leasts :test test))
+
+ ;; Update the output list and remove the winning item from the input
+ ;; lists. We know that it must be at the front of each input list
+ ;; containing it. At this point, we discard input lists entirely when
+ ;; they run out of entries. The loop ends when there are no more input
+ ;; lists left, i.e., when we've munched all of the input items.
+ (lbuild-add lb winner)
+ (setf lists (delete nil (mapcar (lambda (list)
+ (if (funcall test winner (car list))
+ (cdr list)
+ list))
+ lists))))))
+
+(export 'categorize)
+(defmacro categorize ((itemvar items &key bind) categories &body body)
+ "Categorize ITEMS into lists and invoke BODY.
+
+ The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR
+ will contain the current item. The BIND argument is a list of LET*-like
+ clauses. The CATEGORIES are a list of clauses of the form (SYMBOL
+ PREDICATE).
+
+ The behaviour of the macro is as follows. ITEMVAR is assigned (not
+ bound), in turn, each item in the list ITEMS. The PREDICATEs in the
+ CATEGORIES list are evaluated in turn, in an environment containing
+ ITEMVAR and the BINDings, until one of them evaluates to a non-nil value.
+ At this point, the item is assigned to the category named by the
+ corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an
+ error is signalled; a PREDICATE consisting only of T will (of course)
+ match anything; it is detected specially so as to avoid compiler warnings.
+
+ Once all of the ITEMS have been categorized in this fashion, the BODY is
+ evaluated as an implicit PROGN. For each SYMBOL naming a category, a
+ variable named after that symbol will be bound in the BODY's environment
+ to a list of the items in that category, in the same order in which they
+ were found in the list ITEMS. The final values of the macro are the final
+ values of the BODY."
+
+ (let* ((cat-names (mapcar #'car categories))
+ (cat-match-forms (mapcar #'cadr categories))
+ (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string
+ (symbol-name name) "-")))
+ cat-names))
+ (items-var (gensym "ITEMS-")))
+ `(let ((,items-var ,items)
+ ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars))
+ (dolist (,itemvar ,items-var)
+ (let* ,bind
+ (cond ,@(mapcar (lambda (cat-match-form cat-var)
+ `(,cat-match-form
+ (push ,itemvar ,cat-var)))
+ cat-match-forms cat-vars)
+ ,@(and (not (member t cat-match-forms))
+ `((t (error "Failed to categorize ~A" ,itemvar)))))))
+ (let ,(mapcar (lambda (name var)
+ `(,name (nreverse ,var)))
+ cat-names cat-vars)
+ ,@body))))
+
+;;;--------------------------------------------------------------------------
+;;; Strings and characters.
+
+(export 'frob-identifier)
+(defun frob-identifier (string &key (swap-case t) (swap-hyphen t))
+ "Twiddles the case of STRING.
+
+ If all the letters in STRING are uppercase, and SWAP-CASE is true, then
+ switch them to lowercase; if they're all lowercase then switch them to
+ uppercase. If there's a mix then leave them all alone. At the same time,
+ if there are underscores but no hyphens, and SWAP-HYPHEN is true, then
+ switch them to hyphens, if there are hyphens and no underscores, switch
+ them underscores, and if there are both then leave them alone.
+
+ This is an invertible transformation, which turns vaguely plausible Lisp
+ names into vaguely plausible C names and vice versa. Lisp names with
+ `funny characters' like stars and percent signs won't be any use, of
+ course."
+
+ ;; Work out what kind of a job we've got to do. Gather flags: bit 0 means
+ ;; there are upper-case letters; bit 1 means there are lower-case letters;
+ ;; bit 2 means there are hyphens; bit 3 means there are underscores.
+ ;;
+ ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set
+ ;; if we have to frob case; bit 3 is set if we have to swap hyphens and
+ ;; underscores. So use this to select functions which do bits of the
+ ;; mapping, and then compose them together.
+ (let* ((flags (reduce (lambda (state ch)
+ (logior state
+ (cond ((upper-case-p ch) 1)
+ ((lower-case-p ch) 2)
+ ((char= ch #\-) 4)
+ ((char= ch #\_) 8)
+ (t 0))))
+ string
+ :initial-value 0))
+ (mask (logxor flags (ash flags 1)))
+ (letter (cond ((or (not swap-case) (not (logbitp 1 mask)))
+ (constantly nil))
+ ((logbitp 0 flags)
+ (lambda (ch)
+ (and (alpha-char-p ch) (char-downcase ch))))
+ (t
+ (lambda (ch)
+ (and (alpha-char-p ch) (char-upcase ch))))))
+ (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen))
+ (constantly nil))
+ ((logbitp 2 flags)
+ (lambda (ch) (and (char= ch #\-) #\_)))
+ (t
+ (lambda (ch) (and (char= ch #\_) #\-))))))
+
+ (if (logbitp 3 (logior mask (ash mask 2)))
+ (map 'string (lambda (ch)
+ (or (funcall letter ch)
+ (funcall uscore-hyphen ch)
+ ch))
+ string)
+ string)))
+
+(export 'whitespace-char-p)
+(declaim (inline whitespace-char-p))
+(defun whitespace-char-p (char)
+ "Returns whether CHAR is a whitespace character.
+
+ Whitespaceness is determined relative to the compile-time readtable, which
+ is probably good enough for most purposes."
+ (case char
+ (#.(loop for i below char-code-limit
+ for ch = (code-char i)
+ unless (with-input-from-string (in (string ch))
+ (peek-char t in nil))
+ collect ch) t)
+ (t nil)))
+
+(export 'update-position)
+(declaim (inline update-position))
+(defun update-position (char line column)
+ "Updates LINE and COLUMN appropriately for having read the character CHAR.
+
+ Returns the new LINE and COLUMN numbers."
+ (case char
+ ((#\newline #\vt #\page)
+ (values (1+ line) 0))
+ ((#\tab)
+ (values line (logandc2 (+ column 8) 7)))
+ (t
+ (values line (1+ column)))))
+
+(export 'backtrack-position)
+(declaim (inline backtrack-position))
+(defun backtrack-position (char line column)
+ "Updates LINE and COLUMN appropriately for having unread CHAR.
+
+ Well, actually an approximation for it; it will likely be wrong if the
+ last character was a tab. But when the character is read again, it will
+ be correct."
+
+ ;; This isn't perfect: if the character doesn't actually match what was
+ ;; really read then it might not actually be possible: for example, if we
+ ;; push back a newline while in the middle of a line, or a tab while not at
+ ;; a tab stop. In that case, we'll just lose, but hopefully not too badly.
+ (case char
+
+ ;; In the absence of better ideas, I'll set the column number to zero.
+ ;; This is almost certainly wrong, but with a little luck nobody will ask
+ ;; and it'll be all right soon.
+ ((#\newline #\vt #\page) (values (1- line) 0))
+
+ ;; Winding back a single space is sufficient. If the position is
+ ;; currently on a tab stop then it'll advance back here next time. If
+ ;; not, we're going to lose anyway because the previous character
+ ;; certainly couldn't have been a tab.
+ (#\tab (values line (1- column)))
+
+ ;; Anything else: just decrement the column and cross fingers.
+ (t (values line (1- column)))))
+
+;;;--------------------------------------------------------------------------
+;;; Functions.
+
+(export 'compose)
+(defun compose (function &rest more-functions)
+ "Composition of functions. Functions are applied left-to-right.
+
+ This is the reverse order of the usual mathematical notation, but I find
+ it easier to read. It's also slightly easier to work with in programs."
+ (labels ((compose1 (func-a func-b)
+ (lambda (&rest args)
+ (multiple-value-call func-b (apply func-a args)))))
+ (reduce #'compose1 more-functions :initial-value function)))
+
+;;;--------------------------------------------------------------------------
+;;; Symbols.
+
+(export 'symbolicate)
+(defun symbolicate (&rest symbols)
+ "Return a symbol named after the concatenation of the names of the SYMBOLS.
+
+ The symbol is interned in the current *PACKAGE*. Trad."
+ (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
+
+;;;--------------------------------------------------------------------------
+;;; Object printing.
+
+(export 'maybe-print-unreadable-object)
+(defmacro maybe-print-unreadable-object
+ ((object stream &rest args) &body body)
+ "Print helper for usually-unreadable objects.
+
+ If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
+ Otherwise just print using BODY."
+ (with-gensyms (print)
+ `(flet ((,print () ,@body))
+ (if *print-escape*
+ (print-unreadable-object (,object ,stream ,@args)
+ (,print))
+ (,print)))))
+
+;;;--------------------------------------------------------------------------
+;;; Iteration macros.
+
+(export 'dosequence)
+(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar)
+ &body body
+ &environment env)
+ "Macro for iterating over general sequences.
+
+ Iterates over a (sub)sequence SEQ, delimited by START and END (which are
+ evaluated). For each item of SEQ, BODY is invoked with VAR bound to the
+ item, and INDEXVAR (if requested) bound to the item's index. (Note that
+ this is different from most iteration constructs in Common Lisp, which
+ work by mutating the variable.)
+
+ The loop is surrounded by an anonymous BLOCK and the loop body forms an
+ implicit TAGBODY, as is usual. There is no result-form, however."
+
+ (once-only (:environment env seq start end)
+ (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
+
+ (flet ((loopguts (indexp listp endvar)
+ ;; Build a DO-loop to do what we want.
+ (let* ((do-vars nil)
+ (end-condition (if endvar
+ `(>= ,ivar ,endvar)
+ `(endp ,seq)))
+ (item (if listp
+ `(car ,seq)
+ `(aref ,seq ,ivar)))
+ (body-call `(,bodyfunc ,item)))
+ (when listp
+ (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+ do-vars))
+ (when indexp
+ (push `(,ivar ,start (1+ ,ivar)) do-vars))
+ (when indexvar
+ (setf body-call (append body-call (list ivar))))
+ `(do ,do-vars (,end-condition) ,body-call))))
+
+ `(block nil
+ (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+ (tagbody ,@body)))
+ (etypecase ,seq
+ (vector
+ (let ((,endvar (or ,end (length ,seq))))
+ ,(loopguts t nil endvar)))
+ (list
+ (if ,end
+ ,(loopguts t t end)
+ ,(loopguts indexvar t nil))))))))))
+
+;;;--------------------------------------------------------------------------
+;;; CLOS hacking.
+
+(export 'default-slot)
+(defmacro default-slot ((instance slot &optional (slot-names t))
+ &body value
+ &environment env)
+ "If INSTANCE's slot named SLOT is unbound, set it to VALUE.
+
+ Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we
+ obey the `shared-initialize' protocol). SLOT-NAMES defaults to `t', so
+ you can use it in `initialize-instance' or similar without ill effects.
+ Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
+ evaluated if it's needed."
+
+ (once-only (:environment env instance slot slot-names)
+ `(when ,(if (eq slot-names t)
+ `(not (slot-boundp ,instance ,slot))
+ `(and (not (slot-boundp ,instance ,slot))
+ (or (eq ,slot-names t)
+ (member ,slot ,slot-names))))
+ (setf (slot-value ,instance ,slot)
+ (progn ,@value)))))
+
+;;;----- That's all, folks --------------------------------------------------
#include "sod.h"
}
-lisp (write-line "Hello, world!") ;
-
[nick = nml, link = SodObject]
class Animal : SodObject {
int tickles = 0;
class Lion : Animal {
void bite(void) { puts("Munch!"); }
- void nml.tickle(void) { me->_vt.bite(me); }
+ void nml.tickle(void) { me->_vt.lion.bite(me); }
}
class Goat : Animal {
void butt(void) { puts("Bonk!"); }
- void nml.tickle(void) { me->_vt.butt(me); }
+ void nml.tickle(void) { me->_vt.goat.butt(me); }
}
class Serpent : Animal {
void bite(void) { puts("Nom!"); }
void nml.tickle(void) {
if (SERPENT__CONV_NML(me)->nml.tickles > 2)
- me->_vt.bite();
+ me->_vt.serpent.bite();
else
- me->_vt.hiss();
+ me->_vt.serpent.hiss();
}
}
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Various handy utilities
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; 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)
-
-;;;--------------------------------------------------------------------------
-;;; List utilities.
-
-(defun mappend (function list &rest more-lists)
- "Like a nondestructive MAPCAN.
-
- Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
- and return the result of appending all of the resulting lists."
- (reduce #'append (apply #'mapcar function list more-lists) :from-end t))
-
-(define-condition inconsistent-merge-error (error)
- ((candidates :initarg :candidates
- :reader merge-error-candidates))
- (:documentation
- "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
- (:report (lambda (condition stream)
- (format stream "Merge inconsistency: failed to decide among ~A."
- (merge-error-candidates condition)))))
-
-(defun merge-lists (lists &key pick (test #'eql))
- "Return a merge of the given LISTS.
-
- The resulting LIST contains the items of the given lists, with duplicates
- removed. The order of the resulting list is consistent with the orders of
- the input LISTS in the sense that if A precedes B in some input list then
- A will also precede B in the output list. If the lists aren't consistent
- (e.g., some list contains A followed by B, and another contains B followed
- by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
-
- Item equality is determined by TEST.
-
- If there is an ambiguity at any point -- i.e., a choice between two or
- more possible next items to emit -- then PICK is called to arbitrate.
- PICK is called with two arguments: the list of candidate next items, and
- the current output list. It should return one of the candidate items. If
- PICK is omitted then an arbitrary choice is made.
-
- The primary use of this function is in computing class precedence lists.
- By building the input lists and selecting the PICK function appropriately,
- a variety of different CPL algorithms can be implemented."
-
- ;; In this loop, TAIL points to the last cons cell in the list. This way
- ;; we can build the list up forwards, so as not to make the PICK function
- ;; interface be weird. HEAD is a dummy cons cell inserted before the list,
- ;; which gives TAIL something to point to initially. (If we had locatives,
- ;; I'd have TAIL point to the thing holding the final NIL, but we haven't;
- ;; instead, it points to the cons cell whose cdr holds the final NIL --
- ;; which means that we need to invent a cons cell if the list is empty.)
- (do* ((head (cons nil nil))
- (tail head))
- ((null lists) (cdr head))
-
- ;; The candidate items are the ones at the front of the input lists.
- ;; Gather them up, removing duplicates. If a candidate is somewhere in
- ;; one of the other lists other than at the front then we reject it. If
- ;; we've just rejected everything, then we can make no more progress and
- ;; the input lists were inconsistent.
- (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
- (leasts (remove-if (lambda (item)
- (some (lambda (list)
- (member item (cdr list) :test test))
- lists))
- candidates))
- (winner (cond ((null leasts)
- (error 'inconsistent-merge-error
- :candidates candidates))
- ((null (cdr leasts))
- (car leasts))
- (pick
- (funcall pick leasts (cdr head)))
- (t (car leasts))))
- (new (cons winner nil)))
-
- ;; Check that the PICK function isn't conning us.
- (assert (member winner leasts :test test))
-
- ;; Update the output list and remove the winning item from the input
- ;; lists. We know that it must be at the front of each input list
- ;; containing it. At this point, we discard input lists entirely when
- ;; they run out of entries. The loop ends when there are no more input
- ;; lists left, i.e., when we've munched all of the input items.
- (setf (cdr tail) new
- tail new
- lists (delete nil (mapcar (lambda (list)
- (if (funcall test winner (car list))
- (cdr list)
- list))
- lists))))))
-
-;;;--------------------------------------------------------------------------
-;;; Strings and characters.
-
-(defun frob-case (string)
- "Twiddles the case of STRING.
-
- If all the letters in STRING are uppercase, switch them to lowercase; if
- they're all lowercase then switch them to uppercase. If there's a mix
- then leave them all alone. This is an invertible transformation."
-
- ;; Given that this operation is performed by the reader anyway, it's
- ;; surprising that there isn't a Common Lisp function to do this built
- ;; in.
- (let ((flags (reduce (lambda (state ch)
- (logior state
- (cond ((upper-case-p ch) 1)
- ((lower-case-p ch) 2)
- (t 0))))
- string
- :initial-value 0)))
-
- ;; Now FLAGS has bit 0 set if there are any upper-case characters, and
- ;; bit 1 if there are lower-case. So if it's zero there were no letters
- ;; at all, and if it's three then there were both kinds; either way, we
- ;; leave the string unchanged. Otherwise we know how to flip the case.
- (case flags
- (1 (string-downcase string))
- (2 (string-upcase string))
- (t string))))
-
-(declaim (inline whitespace-char-p))
-(defun whitespace-char-p (char)
- "Returns whether CHAR is a whitespace character.
-
- Whitespaceness is determined relative to the compile-time readtable, which
- is probably good enough for most purposes."
- (case char
- (#.(loop for i below char-code-limit
- for ch = (code-char i)
- unless (with-input-from-string (in (string ch))
- (peek-char t in nil))
- collect ch) t)
- (t nil)))
-
-;;;--------------------------------------------------------------------------
-;;; Symbols.
-
-(defun symbolicate (&rest symbols)
- "Return a symbol named after the concatenation of the names of the SYMBOLS.
-
- The symbol is interned in the current *PACKAGE*. Trad."
- (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
-
-;;;--------------------------------------------------------------------------
-;;; Object printing.
-
-(defmacro maybe-print-unreadable-object
- ((object stream &rest args) &body body)
- "Print helper for usually-unreadable objects.
-
- If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
- Otherwise just print using BODY."
- (let ((func (gensym "PRINT")))
- `(flet ((,func () ,@body))
- (if *print-escape*
- (print-unreadable-object (,object ,stream ,@args)
- (,func))
- (,func)))))
-
-;;;--------------------------------------------------------------------------
-;;; Keyword arguments and lambda lists.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun transform-otherkeys-lambda-list (bvl)
- "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
-
- &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
- (which must also be present); &ALLOW-OTHER-KEYS must not be present.
-
- The behaviour is that
-
- * the presence of non-listed keyword arguments is permitted, as if
- &ALLOW-OTHER-KEYS had been provided, and
-
- * a list of the keyword arguments other than the ones explicitly listed
- is stored in the VAR.
-
- The return value is a replacement BVL which binds the &OTHER-KEYS variable
- as an &AUX parameter if necessary.
-
- At least for now, fancy things like destructuring lambda-lists aren't
- supported. I suspect you'll get away with a specializing lambda-list."
-
- (prog ((new-bvl nil)
- (rest-var nil)
- (keywords nil)
- (other-keys-var nil)
- (tail bvl))
-
- find-rest
- ;; Scan forwards until we find &REST or &KEY. If we find the former,
- ;; then remember the variable name. If we find the latter first then
- ;; there can't be a &REST argument, so we should invent one. If we
- ;; find neither then there's nothing to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- (&rest (when (endp tail)
- (error "Missing &REST argument name"))
- (setf rest-var (pop tail))
- (push rest-var new-bvl))
- (&aux (go ignore))
- (&key (unless rest-var
- (setf rest-var (gensym "REST"))
- (setf new-bvl (nconc (list '&key rest-var '&rest)
- (cdr new-bvl))))
- (go scan-keywords)))
- (go find-rest))
-
- scan-keywords
- ;; Read keyword argument specs one-by-one. For each one, stash it on
- ;; the NEW-BVL list, and also parse it to extract the keyword, which
- ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
- ;; nothing for us to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- ((&aux &allow-other-keys) (go ignore))
- (&other-keys (go fix-tail)))
- (let ((keyword (if (symbolp item)
- (intern (symbol-name item) :keyword)
- (let ((var (car item)))
- (if (symbolp var)
- (intern (symbol-name var) :keyword)
- (car var))))))
- (push keyword keywords))
- (go scan-keywords))
-
- fix-tail
- ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
- (pop new-bvl)
- (when (endp tail)
- (error "Missing &OTHER-KEYS argument name"))
- (setf other-keys-var (pop tail))
- (push '&allow-other-keys new-bvl)
-
- ;; There should be an &AUX next. If there isn't, assume there isn't
- ;; one and provide our own. (This is safe as long as nobody else is
- ;; expecting to plumb in lambda keywords too.)
- (when (and (not (endp tail)) (eq (car tail) '&aux))
- (pop tail))
- (push '&aux new-bvl)
-
- ;; Add our shiny new &AUX argument.
- (let ((keys-var (gensym "KEYS"))
- (list-var (gensym "LIST")))
- (push `(,other-keys-var (do ((,list-var nil)
- (,keys-var ,rest-var (cddr ,keys-var)))
- ((endp ,keys-var) (nreverse ,list-var))
- (unless (member (car ,keys-var)
- ',keywords)
- (setf ,list-var
- (cons (cadr ,keys-var)
- (cons (car ,keys-var)
- ,list-var))))))
- new-bvl))
-
- ;; Done.
- (return (nreconc new-bvl tail))
-
- ignore
- ;; Nothing to do. Return the unmolested lambda-list.
- (return bvl))))
-
-(defmacro lambda-otherkeys (bvl &body body)
- "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
- `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defun-otherkeys (name bvl &body body)
- "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
- `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defmethod-otherkeys (name &rest stuff)
- "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
- (do ((quals nil)
- (stuff stuff (cdr stuff)))
- ((listp (car stuff))
- `(defmethod ,name ,@(nreverse quals)
- ,(transform-otherkeys-lambda-list (car stuff))
- ,@(cdr stuff)))
- (push (car stuff) quals)))
-
-;;;--------------------------------------------------------------------------
-;;; Iteration macros.
-
-(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body)
- "Macro for iterating over general sequences.
-
- Iterates over a (sub)sequence SEQ, delimited by START and END (which are
- evaluated). For each item of SEQ, BODY is invoked with VAR bound to the
- item, and INDEXVAR (if requested) bound to the item's index. (Note that
- this is different from most iteration constructs in Common Lisp, which
- work by mutating the variable.)
-
- The loop is surrounded by an anonymous BLOCK and the loop body forms an
- implicit TAGBODY, as is usual. There is no result-form, however."
-
- (let ((seqvar (gensym "SEQ"))
- (startvar (gensym "START"))
- (endvar (gensym "END"))
- (ivar (gensym "INDEX"))
- (bodyfunc (gensym "BODY")))
-
- (flet ((loopguts (indexp listp use-endp)
- ;; Build a DO-loop to do what we want.
- (let* ((do-vars nil)
- (end-condition (if use-endp
- `(endp ,seqvar)
- `(>= ,ivar ,endvar)))
- (item (if listp
- `(car ,seqvar)
- `(aref ,seqvar ,ivar)))
- (body-call `(,bodyfunc ,item)))
- (when listp
- (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar))
- do-vars))
- (when indexp
- (push `(,ivar ,startvar (1+ ,ivar)) do-vars))
- (when indexvar
- (setf body-call (append body-call (list ivar))))
- `(do ,do-vars (,end-condition) ,body-call))))
-
- `(block nil
- (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
- (tagbody ,@body)))
- (let* ((,seqvar ,seq)
- (,startvar ,start))
- (etypecase ,seqvar
- (vector
- (let ((,endvar (or ,end (length ,seqvar))))
- ,(loopguts t nil nil)))
- (list
- (let ((,endvar ,end))
- (if ,endvar
- ,(loopguts t t nil)
- ,(loopguts indexvar t t)))))))))))
-
-;;;--------------------------------------------------------------------------
-;;; Meta-object hacking.
-
-(defgeneric copy-instance-using-class (class object &rest initargs)
- (:documentation
- "Return a copy of OBJECT.
-
- OBJECT is assumed to be an instance of CLASS. The copy returned is a
- fresh instance whose slots have the same values as OBJECT except where
- overridden by INITARGS.")
-
- (:method ((class standard-class) object &rest initargs)
- (let ((copy (apply #'allocate-instance class initargs)))
- (dolist (slot (class-slots class))
- (if (slot-boundp-using-class class object slot)
- (setf (slot-value-using-class class copy slot)
- (slot-value-using-class class object slot))
- (slot-makunbound-using-class class copy slot)))
- (apply #'shared-initialize copy nil initargs)
- copy)))
-
-(defun copy-instance (object &rest initargs)
- "Return a copy of OBJECT.
-
- The copy returned is a fresh instance whose slots have the same values as
- OBJECT except where overridden by INITARGS."
- (apply #'copy-instance-using-class (class-of object) object initargs))
-
-(defmacro default-slot ((instance slot) &body value &environment env)
- "If INSTANCE's SLOT is unbound, set it to VALUE.
-
- Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only
- evaluated if it's needed."
-
- (let* ((quotep (constantp slot env))
- (instancevar (gensym "INSTANCE"))
- (slotvar (if quotep slot (gensym "SLOT"))))
- `(let ((,instancevar ,instance)
- ,@(and (not quotep) `((,slotvar ,slot))))
- (unless (slot-boundp ,instancevar ,slotvar)
- (setf (slot-value ,instancevar ,slotvar)
- (progn ,@value))))))
-
-;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff
