+++ /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-*-
-;;;
-;;; Basic definitions for classes, methods and suchlike
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Classes.
-
-(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 the generic function 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.
-
- * 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.
-
-(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)))))
-
-(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))))
-
-(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."))
-
-(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.
-
-(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)))))
-
-(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))))
-
-;;;--------------------------------------------------------------------------
-;;; Classes as C types.
-
-(defclass c-class-type (simple-c-type)
- ((class :initarg :class :type (or null sod-class) :accessor c-type-class))
- (: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."))
-
-(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)))
-
-(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
- (declare (ignore colon atsign))
- (format stream "~:@<CLASS ~@_~S~{ ~_~S~}~:>"
- (c-type-name type)
- (c-type-qualifiers type)))
-
-(defun find-class-type (name &optional floc)
- "Look up NAME and return the corresponding C-CLASS-TYPE.
-
- Returns two values: TYPE and WINP.
-
- * 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 at FLOC."
-
- (with-default-error-location (floc)
- (let ((type (gethash name *type-map*)))
- (typecase type
- (null nil)
- (c-class-type type)
- (t (error "Type `~A' (~A) is not a class" name type))))))
-
-(defun make-class-type (name &optional floc)
- "Return a class type for NAME, creating it if necessary.
-
- FLOC is the location to use in error reports."
- (let ((name (etypecase name
- (sod-class (sod-class-name name))
- (string name))))
- (or (find-class-type name floc)
- (setf (gethash name *type-map*)
- (make-instance 'c-class-type :name name :class nil)))))
-
-(defun find-sod-class (name &optional floc)
- "Return the SOD-CLASS object with the given NAME.
-
- FLOC is the location to use in error reports."
- (with-default-error-location (floc)
- (let ((type (find-class-type name floc)))
- (cond ((not type) (error "Type `~A' not known" name))
- (t (let ((class (c-type-class type)))
- (unless class
- (error "Class `~A' is incomplete" name))
- class))))))
-
-(defun record-sod-class (class &optional (floc class))
- "Record CLASS as being a class definition.
-
- FLOC is the location to use in error reports."
- (with-default-error-location (floc)
- (let* ((name (sod-class-name class))
- (type (make-class-type name floc)))
- (cond ((null type) nil)
- ((c-type-class type)
- (cerror* "Class `~A' already defined at ~A"
- name (file-location (c-type-class type))))
- (t
- (setf (c-type-class type) class))))))
-
-(define-c-type-syntax class (name &rest quals)
- "Returns a type object for the named class."
- (if quals
- `(qualify-type (make-class-type ,name) (list ,@quals))
- `(make-class-type ,name)))
-
-;;;----- 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 --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output functions for classes
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; 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)))))
-
-;;;--------------------------------------------------------------------------
-;;; 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))))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(defun test (name)
- (let ((sequencer (make-instance 'sequencer))
- (class (find-sod-class name)))
- (hook-output class :h sequencer)
- (invoke-sequencer-items sequencer *standard-output*)
- sequencer))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /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
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Error types and handling 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)
-
-;;;--------------------------------------------------------------------------
-;;; Enclosing conditions.
-
-(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.
-
-(define-condition condition-with-location (condition)
- ((location :initarg :location :reader file-location :type file-location))
- (:documentation
- "A condition which has some location information attached."))
-
-(define-condition enclosing-condition-with-location
- (condition-with-location enclosing-condition)
- ())
-
-(define-condition error-with-location (condition-with-location error)
- ())
-
-(define-condition warning-with-location (condition-with-location warning)
- ())
-
-(define-condition enclosing-error-with-location
- (enclosing-condition-with-location error)
- ())
-
-(define-condition enclosing-warning-with-location
- (enclosing-condition-with-location warning)
- ())
-
-(define-condition simple-condition-with-location
- (condition-with-location simple-condition)
- ())
-
-(define-condition simple-error-with-location
- (error-with-location simple-error)
- ())
-
-(define-condition simple-warning-with-location
- (warning-with-location simple-warning)
- ())
-
-;;;--------------------------------------------------------------------------
-;;; Error reporting functions.
-
-(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)))))
-
-(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)))
-
-(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)))
-
-(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)))
-
-(defun cerror* (datum &rest arguments)
- (apply #'cerror "Continue" datum arguments))
-
-(defun cerror*-with-location (floc datum &rest arguments)
- (apply #'cerror-with-location floc "Continue" datum arguments))
-
-(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))))
-
-(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)))
-
-(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)))
-
-(defmacro with-default-error-location ((floc) &body body)
- "Evaluate BODY 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 subtype of
- ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original
- condition, and signalled. 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."
- `(with-default-error-location* ,floc (lambda () ,@body)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
-
-(defparameter *chimaera-module*
- (define-module ("chimaera.sod")
-
- (define-fragment (:c :includes) #{
- #include "chimaera.h"
- })
-
- (define-fragment (:h :includes) #{
- #include "sod.h"
- })
-
- (define-sod-class "Animal" ("SodObject")
- :nick 'nml
- :link '|SodObject|
- (slot "tickles" int)
- (instance-initializer "nml" "tickles" :single #{ 0 })
- (message "tickle" (fun void))
- (method "nml" "tickle" (fun void) #{
- me->tickles++;
- }
- :role :before)
- (method "nml" "tickle" (fun void) #{ }))
-
- (define-sod-class "Lion" ("Animal")
- :nick 'lion
- :link '|Animal|
- (message "bite" (fun void))
- (method "lion" "bite" (fun void) #{
- puts("Munch!");
- })
- (method "nml" "tickle" (fun void) #{
- me->_vt->lion.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Goat" ("Animal")
- :nick 'goat
- (message "butt" (fun void))
- (method "goat" "butt" (fun void) #{
- puts("Whack!");
- })
- (method "nml" "tickle" (fun void) #{
- me->_vt->goat.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Serpent" ("Animal")
- :nick 'serpent
- (message "bite" (fun void))
- (method "serpent" "bite" (fun void) #{
- puts("Nom!");
- })
- (message "hiss" (fun void))
- (method "serpent" "hiss" (fun void) #{
- puts("Ssss!");
- })
- (method "nml" "tickle" (fun void) #{
- if (me->tickles < 3) me->_vt->hiss(me);
- else me->_vt->bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
- :nick 'sir
- :link '|Lion|)
-
- (defparameter *chimaera* (find-sod-class "Chimaera"))
- (defparameter *emeth* (find "tickle"
- (sod-class-effective-methods *chimaera*)
- :key (lambda (method)
- (sod-message-name
- (effective-method-message method)))
- :test #'string=))))
+++ /dev/null
-;;;
-(write-line "stuff's a-goin' on")
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Lexical analysis of a vaguely C-like language
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Basic lexical analyser infrastructure.
-
-;; Class definition.
-
-(defclass 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)
- (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)."))
-
-;; Lexer protocol.
-
-(defgeneric scan-token (lexer)
- (:documentation
- "Internal function 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."))
-
-(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-NAME on the LEXER object.
-
- If tokens have been pushed back (see PUSHBACK-TOKEN) then they are
- returned one by one instead of scanning the stream.")
-
- (:method ((lexer lexer))
- (with-slots (pushback-tokens token-type token-value) lexer
- (setf (values token-type token-value)
- (if pushback-tokens
- (let ((pushback (pop pushback-tokens)))
- (values (car pushback) (cdr pushback)))
- (scan-token lexer))))))
-
-(defgeneric pushback-token (lexer token-type &optional token-value)
- (: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. The FILE-LOCATION is
- not affected by pushing tokens back. The TOKEN-TYPE and TOKEN-VALUE be
- anything at all: for instance, they need not be values which can actually
- be returned by NEXT-TOKEN.")
-
- (:method ((lexer lexer) new-token-type &optional new-token-value)
- (with-slots (pushback-tokens token-type token-value) lexer
- (push (cons token-type token-value) pushback-tokens)
- (setf token-type new-token-type
- token-value new-token-value))))
-
-(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.
-
- (This function is primarily intended for the use of lexer subclasses.)")
-
- (:method ((lexer lexer))
- (with-slots (stream char pushback-chars) lexer
- (setf char (if pushback-chars
- (pop pushback-chars)
- (read-char stream nil))))))
-
-(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.)")
-
- (:method ((lexer lexer) new-char)
- (with-slots (char pushback-chars) lexer
- (push char pushback-chars)
- (setf char new-char))))
-
-(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.")
-
- (:method ((lexer lexer) thunk)
- (with-slots (stream char pushback-chars) lexer
- (when pushback-chars
- (error "Lexer has pushed-back characters."))
- (unread-char char stream)
- (unwind-protect
- (funcall thunk stream)
- (setf char (read-char stream nil))))))
-
-(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)))
-
-(defmethod file-location ((lexer lexer))
- (with-slots (stream) lexer
- (file-location stream)))
-
-(defgeneric skip-spaces (lexer)
- (:documentation
- "Skip over whitespace characters in the LEXER."))
-
-;;;--------------------------------------------------------------------------
-;;; Lexer utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Our main lexer.
-
-(defun make-keyword-table (&rest keywords)
- "Construct a keyword table for the lexical analyser.
-
- The KEYWORDS arguments are individual keywords, either as strings or as
- (WORD . VALUE) pairs. A string argument is equivalent to a pair listing
- the string itself as WORD and the corresponding keyword symbol (forced to
- uppercase) as the VALUE."
-
- (let ((table (make-hash-table :test #'equal)))
- (dolist (item keywords)
- (multiple-value-bind (word keyword)
- (if (consp item)
- (values (car item) (cdr item))
- (values item (intern (string-upcase item) :keyword)))
- (setf (gethash word table) keyword)))
- table))
-
-(defparameter *sod-keywords*
- (make-keyword-table
-
- ;; Words with a meaning to C's type system.
- "char" "int" "float" "void"
- "long" "short" "signed" "unsigned" "double"
- "const" "volatile" "restrict"
- "struct" "union" "enum"))
-
-(defclass sod-lexer (lexer)
- ()
- (:documentation
- "Lexical analyser for the SOD lanuage.
-
- See the LEXER class for the gory details about the lexer protocol."))
-
-(defun format-token (token-type &optional token-value)
- (when (typep token-type 'lexer)
- (let ((lexer token-type))
- (setf token-type (token-type lexer)
- token-value (token-value lexer))))
- (etypecase token-type
- ((eql :eof) "<end-of-file>")
- ((eql :string) "<string-literal>")
- ((eql :char) "<character-literal>")
- ((eql :id) (format nil "<identifier~@[ `~A'~]>" token-value))
- (keyword (format nil "`~(~A~)'" token-type))
- (character (format nil "~:[<~:C>~;`~C'~]"
- (and (graphic-char-p token-type)
- (char/= token-type #\space))
- token-type))))
-
-(defmethod scan-token ((lexer sod-lexer))
- (with-slots (stream char keywords) lexer
- (prog ((ch char))
-
- consider
- (cond
-
- ;; End-of-file brings its own peculiar joy.
- ((null ch) (return (values :eof t)))
-
- ;; Ignore whitespace and continue around for more.
- ((whitespace-char-p ch) (go scan))
-
- ;; Strings.
- ((or (char= ch #\") (char= ch #\'))
- (with-default-error-location ((file-location lexer))
- (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")
- (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 :ellpisis 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))))
-
-;;;--------------------------------------------------------------------------
-;;; C fragments.
-
-(defun scan-c-fragment (lexer end-chars)
- "Snarfs a sequence of C tokens with balanced brackets.
-
- Reads and consumes characters from the LEXER's stream, and returns them as
- a string. The string will contain whole C tokens, up as far as an
- occurrence of one of the END-CHARS (a list) which (a) is not within a
- string or character literal or comment, and (b) appears at the outer level
- of nesting of brackets (whether round, curly or square -- again counting
- only brackets which aren't themselves within string/character literals or
- comments. The final END-CHAR is not consumed.
-
- An error is signalled if either the stream ends before an occurrence of
- one of the END-CHARS, or if mismatching brackets are encountered. No
- other attempt is made to ensure that the characters read are in fact a
- valid C fragment.
-
- Both original /*...*/ and new //... comments are recognized. Trigraphs
- and digraphs are currently not recognized."
-
- (let ((output (make-string-output-stream))
- (ch (lexer-char lexer))
- (start-floc (file-location lexer))
- (delim nil)
- (stack nil))
-
- ;; Main loop. At the top of this loop, we've already read a
- ;; character into CH. This is usually read at the end of processing
- ;; the individual character, though sometimes (following `/', for
- ;; example) it's read speculatively because we need one-character
- ;; lookahead.
- (block loop
- (labels ((getch ()
- "Read the next character into CH; complain if we hit EOF."
- (unless (setf ch (next-char lexer))
- (cerror*-with-location start-floc
- "Unexpected end-of-file in C fragment")
- (return-from loop))
- ch)
- (putch ()
- "Write the character to the output buffer."
- (write-char ch output))
- (push-delim (d)
- "Push a closing delimiter onto the stack."
- (push delim stack)
- (setf delim d)
- (getch)))
-
- ;; Hack: if the first character is a newline, discard it. Otherwise
- ;; (a) the output fragment will look funny, and (b) the location
- ;; information will be wrong.
- (when (eql ch #\newline)
- (getch))
-
- ;; And fetch characters.
- (loop
-
- ;; Here we're outside any string or character literal, though we
- ;; may be nested within brackets. So, if there's no delimiter, and
- ;; we've found the end character, we're done.
- (when (and (null delim) (member ch end-chars))
- (return))
-
- ;; Otherwise take a copy of the character, and work out what to do
- ;; next.
- (putch)
- (case ch
-
- ;; Starting a literal. Continue until we find a matching
- ;; character not preceded by a `\'.
- ((#\" #\')
- (let ((quote ch))
- (loop
- (getch)
- (putch)
- (when (eql ch quote)
- (return))
- (when (eql ch #\\)
- (getch)
- (putch)))
- (getch)))
-
- ;; Various kinds of opening bracket. Stash the current
- ;; delimiter, and note that we're looking for a new one.
- (#\( (push-delim #\)))
- (#\[ (push-delim #\]))
- (#\{ (push-delim #\}))
-
- ;; Various kinds of closing bracket. If it matches the current
- ;; delimeter then unstack the next one along. Otherwise
- ;; something's gone wrong: C syntax doesn't allow unmatched
- ;; brackets.
- ((#\) #\] #\})
- (if (eql ch delim)
- (setf delim (pop stack))
- (cerror* "Unmatched `~C'." ch))
- (getch))
-
- ;; A slash. Maybe a comment next. But maybe not...
- (#\/
-
- ;; Examine the next character to find out how to proceed.
- (getch)
- (case ch
-
- ;; A second slash -- eat until the end of the line.
- (#\/
- (putch)
- (loop
- (getch)
- (putch)
- (when (eql ch #\newline)
- (return)))
- (getch))
-
- ;; A star -- eat until we find a star-slash. Since the star
- ;; might be preceded by another star, we use a little state
- ;; machine.
- (#\*
- (putch)
- (tagbody
-
- main
- ;; Main state. If we read a star, switch to star state;
- ;; otherwise eat the character and try again.
- (getch)
- (putch)
- (case ch
- (#\* (go star))
- (t (go main)))
-
- star
- ;; Star state. If we read a slash, we're done; if we read
- ;; another star, stay in star state; otherwise go back to
- ;; main.
- (getch)
- (putch)
- (case ch
- (#\* (go star))
- (#\/ (go done))
- (t (go main)))
-
- done
- (getch)))))
-
- ;; Something else. Eat it and continue.
- (t (getch)))))
-
- (let* ((string (get-output-stream-string output))
- (end (position-if (lambda (char)
- (or (char= char #\newline)
- (not (whitespace-char-p char))))
- string
- :from-end t))
- (trimmed (if end
- (subseq string 0 (1+ end))
- "")))
-
- ;; Return the fragment we've collected.
- (make-instance 'c-fragment
- :location start-floc
- :text trimmed)))))
-
-(defun c-fragment-reader (stream char arg)
- "Reader for C-fragment syntax #{ ... stuff ... }."
- (declare (ignore char arg))
- (let ((lexer (make-instance 'sod-lexer
- :stream stream)))
- (next-char lexer)
- (scan-c-fragment lexer '(#\}))))
-
-#+interactive
-(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (in "
-{ foo } 'x' /?/***/!
-123 0432 0b010123 0xc0ffee __burp_32 class
-
-0xturning 0xfattening
-...
-
-class integer : integral_domain {
- something here;
-}
-
-")
- (let* ((stream (make-instance 'position-aware-input-stream
- :stream in
- :file #p"magic"))
- (lexer (make-instance 'sod-lexer
- :stream stream
- :keywords *sod-keywords*))
- (list nil))
- (next-char lexer)
- (loop
- (multiple-value-bind (tokty tokval) (next-token lexer)
- (push (list tokty tokval) list)
- (when (eql tokty :eof)
- (return))))
- (nreverse list)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /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 --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output handling for modules
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Main output protocol implementation.
-
-;;;--------------------------------------------------------------------------
-;;; Header output.
-
-;;;--------------------------------------------------------------------------
-;;; Source output.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Modules and module parser
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Module importing.
-
-(defun read-module (pathname &key (truename (truename pathname)) location)
- "Reads a module.
-
- The module is returned if all went well; nil is returned if an error
- occurred.
-
- The PATHNAME argument is the file to read. TRUENAME should be the file's
- truename, if known: often, the file will have been searched for using
- `probe-file' or similar, which drops the truename into your lap."
-
- ;; Deal with a module which is already in the map. If its state is a
- ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
- (let ((module (gethash truename *module-map*)))
- (cond ((null module))
- ((typep (module-state module) 'file-location)
- (error "Module ~A already being imported at ~A"
- pathname (module-state module)))
- (module
- (return-from read-module module))))
-
- ;; Make a new module. Be careful to remove the module from the map if we
- ;; didn't succeed in constructing it.
- (define-module (pathname :location location :truename truename)
- (let ((*readtable* (copy-readtable)))
- (with-open-file (f-stream pathname :direction :input)
- (let* ((pai-stream (make-instance 'position-aware-input-stream
- :stream f-stream
- :file pathname))
- (lexer (make-instance 'sod-lexer :stream pai-stream)))
- (with-default-error-location (lexer)
- (next-char lexer)
- (next-token lexer)
- (parse-module lexer)))))))
-
-;;;--------------------------------------------------------------------------
-;;; Module parsing protocol.
-
-(defgeneric parse-module-declaration (tag lexer pset)
- (:method (tag lexer pset)
- (error "Unexpected module declaration ~(~A~)" tag))
- (:method :before (tag lexer pset)
- (next-token lexer)))
-
-(defun parse-module (lexer)
- "Main dispatching for module parser.
-
- Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
-
- (loop
- (restart-case
- (case (token-type lexer)
- (:eof (return))
- (#\; (next-token lexer))
- (t (let ((pset (parse-property-set lexer)))
- (case (token-type lexer)
- (:id (let ((tag (intern (frob-case (token-value lexer))
- :keyword)))
- (parse-module-declaration tag lexer pset)
- (check-unused-properties pset)))
- (t (error "Unexpected token ~A: ignoring"
- (format-token lexer)))))))
- (continue ()
- :report "Ignore the error and continue parsing."
- nil))))
-
-(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
- "module-decl ::= `typename' id-list `;'"
- (loop (let ((name (require-token lexer :id)))
- (unless name (return))
- (if (gethash name *type-map*)
- (cerror* "Type `~A' already defined" name)
- (add-to-module *module* (make-instance 'type-item :name name)))
- (unless (require-token lexer #\, :errorp nil) (return))))
- (require-token lexer #\;))
-
-;;;--------------------------------------------------------------------------
-;;; Fragments.
-
-(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
- "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
- constraint ::= id*"
- (labels ((parse-constraint ()
- (let ((list nil))
- (loop (let ((id (require-token lexer :id
- :errorp (null list))))
- (unless id (return))
- (push id list)))
- (nreverse list)))
- (parse-constraints ()
- (let ((list nil))
- (when (require-token lexer #\[ :errorp nil)
- (loop (let ((constraint (parse-constraint)))
- (push constraint list)
- (unless (require-token lexer #\, :errorp nil)
- (return))))
- (require-token lexer #\]))
- (nreverse list)))
- (keywordify (id)
- (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
- (let* ((reason (prog1 (keywordify (require-token lexer :id))
- (require-token lexer #\:)))
- (name (keywordify (require-token lexer :id)))
- (constraints (parse-constraints)))
- (when (require-token lexer #\{ :consumep nil)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (add-to-module *module*
- (make-instance 'code-fragment-item
- :name name
- :reason reason
- :constraints constraints
- :fragment frag)))))))
-
-;;;--------------------------------------------------------------------------
-;;; File searching.
-
-
-(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
- "module-decl ::= `import' string `;'"
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name
- (make-pathname :type "SOD" :case :common))
- "module"
- (lambda (path true)
- (handler-case
- (let ((module (read-module path :truename true)))
- (when module
- (module-import module)
- (pushnew module (module-dependencies *module*))))
- (file-error (error)
- (cerror* "Error reading module ~S: ~A"
- path error)))))
- (require-token lexer #\;))))
-
-(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
- "module-decl ::= `load' string `;'"
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name
- (make-pathname :type "LISP" :case :common))
- "Lisp file"
- (lambda (path true)
- (handler-case (load true :verbose nil :print nil)
- (error (error)
- (cerror* "Error loading Lisp file ~S: ~A"
- path error)))))
- (require-token lexer #\;))))
-
-;;;--------------------------------------------------------------------------
-;;; Lisp escapes.
-
-(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
- "module-decl ::= `lisp' s-expression `;'"
- (let ((form (with-lexer-stream (stream lexer) (read stream t))))
- (eval form))
- (next-token lexer)
- (require-token lexer #\;))
-
-;;;--------------------------------------------------------------------------
-;;; Class declarations.
-
-(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
- "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
- (let* ((location (file-location lexer))
- (name (let ((name (require-token lexer :id)))
- (make-class-type name location)
- (when (require-token lexer #\; :errorp nil)
- (return-from parse-module-declaration))
- name))
- (supers (when (require-token lexer #\: :errorp nil)
- (let ((list nil))
- (loop (let ((id (require-token lexer :id)))
- (unless id (return))
- (push id list)
- (unless (require-token lexer #\, :errorp nil)
- (return))))
- (nreverse list))))
- (class (make-sod-class name (mapcar #'find-sod-class supers)
- pset location))
- (nick (sod-class-nickname class)))
- (require-token lexer #\{)
-
- (labels ((parse-item ()
- "Try to work out what kind of item this is. Messy."
- (let* ((pset (parse-property-set lexer))
- (location (file-location lexer)))
- (cond ((declaration-specifier-p lexer)
- (let ((declspec (parse-c-type lexer)))
- (multiple-value-bind (type name)
- (parse-c-declarator lexer declspec :dottedp t)
- (cond ((null type)
- nil)
- ((consp name)
- (parse-method type (car name) (cdr name)
- pset location))
- ((typep type 'c-function-type)
- (parse-message type name pset location))
- (t
- (parse-slots declspec type name
- pset location))))))
- ((not (eq (token-type lexer) :id))
- (cerror* "Expected <class-item>; found ~A (skipped)"
- (format-token lexer))
- (next-token lexer))
- ((string= (token-value lexer) "class")
- (next-token lexer)
- (parse-initializers #'make-sod-class-initializer
- pset location))
- (t
- (parse-initializers #'make-sod-instance-initializer
- pset location)))))
-
- (parse-method (type nick name pset location)
- "class-item ::= declspec+ dotted-declarator -!- method-body
-
- method-body ::= `{' c-fragment `}' | `extern' `;'
-
- The dotted-declarator must describe a function type."
- (let ((body (cond ((eq (token-type lexer) #\{)
- (prog1 (scan-c-fragment lexer '(#\}))
- (next-token lexer)
- (require-token lexer #\})))
- ((and (eq (token-type lexer) :id)
- (string= (token-value lexer)
- "extern"))
- (next-token lexer)
- (require-token lexer #\;)
- nil)
- (t
- (cerror* "Expected <method-body>; ~
- found ~A"
- (format-token lexer))))))
- (make-sod-method class nick name type body pset location)))
-
- (parse-message (type name pset location)
- "class-item ::= declspec+ declarator -!- (method-body | `;')
-
- The declarator must describe a function type."
- (make-sod-message class name type pset location)
- (unless (require-token lexer #\; :errorp nil)
- (parse-method type nick name nil location)))
-
- (parse-initializer-body ()
- "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
- (let ((char (lexer-char lexer)))
- (loop
- (when (or (null char) (not (whitespace-char-p char)))
- (return))
- (setf char (next-char lexer)))
- (cond ((eql char #\{)
- (next-char lexer)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (values :compound frag)))
- (t
- (let ((frag (scan-c-fragment lexer '(#\, #\;))))
- (next-token lexer)
- (values :simple frag))))))
-
- (parse-slots (declspec type name pset location)
- "class-item ::=
- declspec+ init-declarator [`,' init-declarator-list] `;'
-
- init-declarator ::= declarator -!- [initializer]"
- (loop
- (make-sod-slot class name type pset location)
- (when (eql (token-type lexer) #\=)
- (multiple-value-bind (kind form) (parse-initializer-body)
- (make-sod-instance-initializer class nick name
- kind form nil
- location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf (values type name)
- (parse-c-declarator lexer declspec)
- location (file-location lexer)))
- (require-token lexer #\;))
-
- (parse-initializers (constructor pset location)
- "class-item ::= [`class'] -!- slot-initializer-list `;'
-
- slot-initializer ::= id `.' id initializer"
- (loop
- (let ((nick (prog1 (require-token lexer :id)
- (require-token lexer #\.)))
- (name (require-token lexer :id)))
- (require-token lexer #\=)
- (multiple-value-bind (kind form)
- (parse-initializer-body)
- (funcall constructor class nick name kind form
- pset location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf location (file-location lexer)))
- (require-token lexer #\;)))
-
- (loop
- (when (require-token lexer #\} :errorp nil)
- (return))
- (parse-item)))
-
- (finalize-sod-class class)
- (add-to-module *module* class)))
-
-;;;----- 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 --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Parser for C types
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Declaration specifiers.
-;;;
-;;; This is a little messy. The C rules, which we're largely following,
-;;; allow declaration specifiers to be written in any oreder, and allows an
-;;; arbitrary number of the things. This is mainly an exercise in
-;;; book-keeping, but we make an effort to categorize the various kinds of
-;;; specifiers rather better than the C standard.
-;;;
-;;; We consider four kinds of declaration specifiers:
-;;;
-;;; * Type qualifiers: `const', `restrict', and `volatile'.
-;;; * Sign specifiers: `signed' and `unsigned'.
-;;; * Size specifiers: `short' and `long'.
-;;; * Type specifiers: `void', `char', `int', `float', and `double',
-;;;
-;;; The C standard acknowledges the category of type qualifiers (6.7.3), but
-;;; groups the other three kinds together and calls them all `type
-;;; specifiers' (6.7.2).
-
-;; Let's not repeat ourselves.
-(macrolet ((define-declaration-specifiers (&rest defs)
- (let ((mappings nil)
- (deftypes nil)
- (hashvar (gensym "HASH"))
- (keyvar (gensym "KEY"))
- (valvar (gensym "VAL")))
- (dolist (def defs)
- (destructuring-bind (kind &rest clauses) def
- (let ((maps (mapcar (lambda (clause)
- (if (consp clause)
- clause
- (cons (string-downcase clause)
- clause)))
- clauses)))
- (push `(deftype ,(symbolicate 'decl- kind) ()
- '(member ,@(mapcar #'cdr maps)))
- deftypes)
- (setf mappings (nconc (remove-if-not #'car maps)
- mappings)))))
- `(progn
- ,@(nreverse deftypes)
- (defparameter *declspec-map*
- (let ((,hashvar (make-hash-table :test #'equal)))
- (mapc (lambda (,keyvar ,valvar)
- (setf (gethash ,keyvar ,hashvar) ,valvar))
- ',(mapcar #'car mappings)
- ',(mapcar #'cdr mappings))
- ,hashvar))))))
- (define-declaration-specifiers
- (type :char :int :float :double :void)
- (size :short :long (nil . :long-long))
- (sign :signed :unsigned)
- (qualifier :const :restrict :volatile)
- (tagged :enum :struct :union)))
-
-(defstruct (declspec
- (:predicate declspecp))
- "Represents a declaration specifier being built."
- (qualifiers nil :type list)
- (sign nil :type (or decl-sign null))
- (size nil :type (or decl-size null))
- (type nil :type (or decl-type c-type null)))
-
-(defun check-declspec (spec)
- "Check that the declaration specifiers in SPEC are a valid combination.
-
- This is surprisingly hairy.
-
- It could be even worse: at least validity is monotonic. Consider an
- alternate language where `double' is a size specifier like `long' rather
- than being a primary type specifier like `float' (so you'd be able to say
- things like `long double float'). Then `long float' would be invalid, but
- `long float double' would be OK. We'd therefore need an additional
- argument to know whether we were preparing a final set of specifiers (in
- which case we'd have to reject `long float') or whether this is an
- intermediate step (in which case we'd have to tentatively allow it in the
- hope that the user added the necessary `double' later)."
-
- (let ((sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
-
- (and (loop for (good-type good-signs good-sizes) in
-
- ;; The entries in this table have the form (GOOD-TYPE
- ;; GOOD-SIGNS GOOD-SIZES). The GOOD-TYPE is either a keyword
- ;; or T (matches anything); the GOOD-SIZES and GOOD-SIGNS are
- ;; lists. The SPEC must match at least one entry, as follows:
- ;; the type must be NIL or match GOOD-TYPE; and the size and
- ;; sign must match one of the elements of the corresponding
- ;; GOOD list.
- '((:int (nil :signed :unsigned) (nil :short :long :long-long))
- (:char (nil :signed :unsigned) (nil))
- (:double (nil) (nil :long))
- (t (nil) (nil)))
-
- thereis (and (or (eq type nil)
- (eq good-type t)
- (eq type good-type))
- (member sign good-signs)
- (member size good-sizes)))
- spec)))
-
-(defun update-declspec-qualifiers (spec qual)
- "Update the qualifiers in SPEC by adding QUAL.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (let ((new (copy-declspec spec)))
- (pushnew qual (declspec-qualifiers new))
- (check-declspec new)))
-
-(defun update-declspec-sign (spec sign)
- "Update the signedness in SPEC to be SIGN.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (and (null (declspec-sign spec))
- (let ((new (copy-declspec spec)))
- (setf (declspec-sign new) sign)
- (check-declspec new))))
-
-(defun update-declspec-size (spec size)
- "Update the size in SPEC according to SIZE.
-
- The new declspec is returned if it's valid; otherwise NIL. (This is a
- little subtle because :LONG in particular can modify an existing size
- entry.) SPEC is not modified."
-
- (let ((new-size (case (declspec-size spec)
- ((nil) size)
- (:long (if (eq size :long) :long-long nil)))))
- (and new-size
- (let ((new (copy-declspec spec)))
- (setf (declspec-size new) new-size)
- (check-declspec new)))))
-
-(defun update-declspec-type (spec type)
- "Update the type in SPEC to be TYPE.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (and (null (declspec-type spec))
- (let ((new (copy-declspec spec)))
- (setf (declspec-type new) type)
- (check-declspec new))))
-
-(defun canonify-declspec (spec)
- "Transform the declaration specifiers SPEC into a canonical form.
-
- The idea is that, however grim the SPEC, we can turn it into something
- vaguely idiomatic, and pick precisely one of the possible synonyms.
-
- The rules are that we suppress `signed' when it's redundant, and suppress
- `int' if a size or signedness specifier is present. (Note that `signed
- char' is not the same as `char', so stripping `signed' is only correct
- when the type is `int'.)
-
- The qualifiers are sorted and uniquified here; the relative ordering of
- the sign/size/type specifiers will be determined by DECLSPEC-KEYWORDS."
-
- (let ((quals (declspec-qualifiers spec))
- (sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
- (cond ((eq type :int)
- (when (eq sign :signed)
- (setf (declspec-sign spec) nil))
- (when (or sign size)
- (setf (declspec-type spec) nil)))
- ((not (or sign size type))
- (setf (declspec-type spec) :int)))
- (setf (declspec-qualifiers spec)
- (delete-duplicates (sort (copy-list quals) #'string<)))
- spec))
-
-(defun declspec-keywords (spec &optional qualsp)
- "Return a list of strings for the declaration specifiers SPEC.
-
- If QUALSP then return the type qualifiers as well."
-
- (let ((quals (declspec-qualifiers spec))
- (sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
- (nconc (and qualsp (mapcar #'string-downcase quals))
- (and sign (list (string-downcase sign)))
- (case size
- ((nil) nil)
- (:long-long (list "long long"))
- (t (list (string-downcase size))))
- (etypecase type
- (null nil)
- (keyword (list (string-downcase type)))
- (simple-c-type (list (c-type-name type)))
- (tagged-c-type (list (string-downcase (c-tagged-type-kind type))
- (c-type-tag type)))))))
-
-(defun declspec-c-type (spec)
- "Return a C-TYPE object corresponding to SPEC."
- (canonify-declspec spec)
- (let* ((type (declspec-type spec))
- (base (etypecase type
- (symbol (make-simple-type
- (format nil "~{~A~^ ~}"
- (declspec-keywords spec))))
- (c-type type))))
- (qualify-type base (declspec-qualifiers spec))))
-
-(defun declaration-specifier-p (lexer)
- "Answer whether the current token might be a declaration specifier."
- (and (eq (token-type lexer) :id)
- (let ((id (token-value lexer)))
- (or (gethash id *declspec-map*)
- (gethash id *type-map*)))))
-
-(defun parse-c-type (lexer)
- "Parse declaration specifiers from LEXER and return a C-TYPE."
-
- (let ((spec (make-declspec))
- (found-any nil)
- tok)
- (flet ((token (&optional (ty (next-token lexer)))
- (setf tok
- (or (and (eq ty :id)
- (gethash (token-value lexer) *declspec-map*))
- ty)))
- (update (func value)
- (let ((new (funcall func spec value)))
- (cond (new (setf spec new))
- (t (cerror* "Invalid declaration specifier ~(~A~) ~
- following `~{~A~^ ~}' (ignored)"
- (format-token tok (token-value lexer))
- (declspec-keywords spec t))
- nil)))))
- (token (token-type lexer))
- (loop
- (typecase tok
- (decl-qualifier (update #'update-declspec-qualifiers tok))
- (decl-sign (when (update #'update-declspec-sign tok)
- (setf found-any t)))
- (decl-size (when (update #'update-declspec-size tok)
- (setf found-any t)))
- (decl-type (when (update #'update-declspec-type tok)
- (setf found-any t)))
- (decl-tagged (let ((class (ecase tok
- (:enum 'c-enum-type)
- (:struct 'c-struct-type)
- (:union 'c-union-type))))
- (let ((tag (require-token lexer :id)))
- (when tag
- (update #'update-declspec-type
- (make-instance class :tag tag))))))
- ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
- (when (or found-any (not ty))
- (return))
- (when (update #'update-declspec-type ty)
- (setf found-any t))))
- (t (return)))
- (token))
- (unless found-any
- (cerror* "Missing type name (guessing at `int')"))
- (declspec-c-type spec))))
-
-;;;--------------------------------------------------------------------------
-;;; Parsing declarators.
-;;;
-;;; This is a whole different ball game. The syntax is simple enough, but
-;;; the semantics is inside-out in a particularly unpleasant way.
-;;;
-;;; The basic idea is that declarator operators closer to the identifier (or
-;;; where the identifier would be) should be applied last (with postfix
-;;; operators being considered `closer' than prefix).
-;;;
-;;; One might thing that we can process prefix operators immediately. For
-;;; outer prefix operators, this is indeed correct, but in `int (*id)[]', for
-;;; example, we must wait to process the array before applying the pointer.
-;;;
-;;; We can translate each declarator operator into a function which, given a
-;;; type, returns the appropriate derived type. If we can arrange these
-;;; functions in the right order during the parse, we have only to compose
-;;; them together and apply them to the base type in order to finish the job.
-;;;
-;;; Consider the following skeletal declarator, with <> as a parenthesized
-;;; subdeclarator within.
-;;;
-;;; * * <> [] [] ---> a b d c z
-;;; a b z c d
-;;;
-;;; The algorithm is therefore as follows. We first read the prefix
-;;; operators, translate them into closures, and push them onto a list. Each
-;;; parenthesized subdeclarator gets its own list, and we push those into a
-;;; stack each time we encounter a `('. We then parse the middle bit, which
-;;; is a little messy (see the comment there), and start an empty final list
-;;; of operators. Finally, we scan postfix operators; these get pushed onto
-;;; the front of the operator list as we find them. Each time we find a `)',
-;;; we reverse the current prefix-operators list, and attach it to the front
-;;; of the operator list, and pop a new prefix list off the stack: at this
-;;; point, the operator list reflects the type of the subdeclarator we've
-;;; just finished. Eventually we should reach the end with an empty stack
-;;; and a prefix list, which again we reverse and attach to the front of the
-;;; list.
-;;;
-;;; Finally, we apply the operator functions in order.
-
-(defun parse-c-declarator (lexer type &key abstractp dottedp)
- "Parse a declarator. Return two values: the complete type, and the name.
-
- Parse a declarator from LEXER. The base type is given by TYPE. If
- ABSTRACTP is NIL, then require a name; if T then forbid a name; if :MAYBE
- then don't care either way. If no name is given, return NIL.
-
- If DOTTEDP then the name may be a dotted item name `NICK.NAME', returned
- as a cons (NICK . NAME)."
-
- (let ((ops nil)
- (item nil)
- (stack nil)
- (prefix nil))
-
- ;; Scan prefix operators.
- (loop
- (case (token-type lexer)
-
- ;; Star: a pointer type.
- (#\* (let ((quals nil)
- (tok (next-token lexer)))
-
- ;; Gather following qualifiers.
- (loop
- (case tok
- ((:const :volatile :restrict)
- (pushnew tok quals))
- (t
- (return))))
-
- ;; And stash the item.
- (setf quals (sort quals #'string<))
- (push (lambda (ty)
- (make-instance 'c-pointer-type
- :qualifiers quals
- :subtype ty))
- prefix)))
-
- ;; An open-paren: start a new level of nesting. Maybe. There's an
- ;; unpleasant ambiguity (DR9, DR249) between a parenthesized
- ;; subdeclarator and a postfix function argument list following an
- ;; omitted name. If the next thing looks like it might appear as a
- ;; declaration specifier then assume it is one, push the paren back,
- ;; and leave; do the same if the parens are empty, because that's not
- ;; allowed otherwise.
- (#\( (let ((tok (next-token lexer)))
- (when (and abstractp
- (or (eql tok #\))
- (declaration-specifier-p lexer)))
- (pushback-token lexer #\()
- (return))
- (push prefix stack)
- (setf prefix nil)))
-
- ;; Anything else: we're done.
- (t (return))))
-
- ;; We're now at the middle of the declarator. If there's an item name
- ;; here, we want to snarf it.
- (when (and (not (eq abstractp t))
- (eq (token-type lexer) :id))
- (let ((name (token-value lexer)))
- (next-token lexer)
- (cond ((and dottedp (require-token lexer #\. :errorp nil))
- (let ((sub (require-token lexer :id :default (gensym))))
- (setf item (cons name sub))))
- (t
- (setf item name)))))
-
- ;; If we were meant to have a name, but weren't given one, make one up.
- (when (and (null item)
- (not abstractp))
- (cerror* "Missing name; inventing one")
- (setf item (gensym)))
-
- ;; Finally scan the postfix operators.
- (loop
- (case (token-type lexer)
-
- ;; Open-bracket: an array. The dimensions are probably some
- ;; gods-awful C expressions which we'll just tuck away rather than
- ;; thinking about too carefully. Our representation of C types is
- ;; capable of thinking about multidimensional arrays, so we slurp up
- ;; as many dimensions as we can.
- (#\[ (let ((dims nil))
- (loop
- (let* ((frag (scan-c-fragment lexer '(#\])))
- (dim (c-fragment-text frag)))
- (push (if (plusp (length dim)) dim nil) dims))
- (next-token lexer)
- (unless (eq (next-token lexer) #\[)
- (return)))
- (setf dims (nreverse dims))
- (push (lambda (ty)
- (when (typep ty 'c-function-type)
- (error "Array element type cannot be ~
- a function type"))
- (make-instance 'c-array-type
- :dimensions dims
- :subtype ty))
- ops)))
-
- ;; Open-paren: a function with arguments.
- (#\( (let ((args nil))
- (unless (eql (next-token lexer) #\))
- (loop
-
- ;; Grab an argument and stash it.
- (cond ((eql (token-type lexer) :ellipsis)
- (push :ellipsis args))
- (t
- (let ((base-type (parse-c-type lexer)))
- (multiple-value-bind (type name)
- (parse-c-declarator lexer base-type
- :abstractp :maybe)
- (push (make-argument name type) args)))))
-
- ;; Decide whether to take another one.
- (case (token-type lexer)
- (#\) (return))
- (#\, (next-token lexer))
- (t (cerror* "Missing `)' inserted before ~A"
- (format-token lexer))
- (return)))))
- (next-token lexer)
-
- ;; Catch: if the only thing in the list is `void' (with no
- ;; identifier) then kill the whole thing.
- (setf args
- (if (and args
- (null (cdr args))
- (eq (argument-type (car args)) (c-type void))
- (not (argument-name (car args))))
- nil
- (nreverse args)))
-
- ;; Stash the operator.
- (push (lambda (ty)
- (when (typep ty '(or c-function-type c-array-type))
- (error "Function return type cannot be ~
- a function or array type"))
- (make-instance 'c-function-type
- :arguments args
- :subtype ty))
- ops)))
-
- ;; Close-paren: exit a level of nesting. Prepend the current prefix
- ;; list and pop a new level. If there isn't one, this isn't our
- ;; paren, so we're done.
- (#\) (unless stack
- (return))
- (setf ops (nreconc prefix ops)
- prefix (pop stack))
- (next-token lexer))
-
- ;; Anything else means we've finished.
- (t (return))))
-
- ;; If we still have operators stacked then something went wrong.
- (setf ops (nreconc prefix ops))
- (when stack
- (cerror* "Missing `)'(s) inserted before ~A"
- (format-token lexer))
- (dolist (prefix stack)
- (setf ops (nreconc prefix ops))))
-
- ;; Finally, grind through the list of operations.
- (do ((ops ops (cdr ops))
- (type type (funcall (car ops) type)))
- ((endp ops) (values type item)))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (in "
-// int stat(struct stat *st)
-// void foo(void)
- int vsnprintf(size_t n, char *buf, va_list ap)
-// size_t size_t;
-// int (*signal(int sig, int (*handler)(int s)))(int t)
-")
- (let* ((stream (make-instance 'position-aware-input-stream
- :file "<string>"
- :stream in))
- (lex (make-instance 'sod-lexer :stream stream)))
- (next-char lex)
- (next-token lex)
- (let ((ty (parse-c-type lex)))
- (multiple-value-bind (type name) (parse-c-declarator lex ty)
- (list ty
- (list type name)
- (with-output-to-string (out)
- (pprint-c-type type out name)
- (format-token lex)))))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Position-aware stream type
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Compatibility hacking.
-
-;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions
-;; with the Gray generic versions.
-#-ecl
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (fdefinition 'stream-close) #'cl:close
- (fdefinition 'stream-elt-type) #'cl:stream-element-type))
-
-;;;--------------------------------------------------------------------------
-;;; File names.
-
-(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 TRUENAMEd,
- ;; which isn't ideal. We'll hack around this later.
- (:method ((stream stream))
- nil)
- (:method ((stream file-stream))
- (pathname stream)))
-
-;;;--------------------------------------------------------------------------
-;;; Locations.
-
-(defclass file-location ()
- ((pathname :initarg :pathname :type (or pathname null)
- :accessor file-location-pathname)
- (line :initarg :line :type (or fixnum null) :accessor file-location-line)
- (column :initarg :column :type (or fixnum null)
- :accessor file-location-column))
- (:documentation
- "A simple structure containing file location information.
-
- Construct using MAKE-FILE-LOCATION; the main useful function is
- ERROR-FILE-LOCATION."))
-
-(defun make-file-location (pathname line column)
- "Constructor for FILE-LOCATION objects.
-
- Returns a FILE-LOCATION object with the given contents."
- (make-instance 'file-location
- :pathname (and pathname (pathname pathname))
- :line line :column column))
-
-(defgeneric file-location (thing)
- (:documentation
- "Convert THING into a FILE-LOCATION, if possible.")
- (:method ((thing null)) (make-file-location nil nil nil))
- (:method ((thing file-location)) thing)
- (:method ((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)
- (with-slots (pathname line column) object
- (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
- pathname line column))))
-
-(defmethod make-load-form ((object file-location) &optional environment)
- (make-load-form-saving-slots object :environment environment))
-
-;;;--------------------------------------------------------------------------
-;;; 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 stream-close ((stream proxy-stream) &key abort)
- (with-slots (ustream) stream
- (close ustream :abort abort)))
-
-(defmethod stream-elt-type ((stream proxy-stream))
- (with-slots (ustream) stream
- (stream-elt-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.
-
-(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.
-
-(declaim (inline update-position))
-(defun update-position (char line column)
- "Updates LINE and COLUMN according to the character CHAR.
-
- Returns the new LINE and COLUMN numbers resulting from having read CHAR."
- (case char
- ((#\newline #\vt #\page)
- (values (1+ line) 0))
- ((#\tab)
- (values line (logandc2 (+ column 7) 7)))
- (t
- (values line (1+ column)))))
-
-(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."
-
- (let ((streamvar (gensym "STREAM"))
- (linevar (gensym "LINE"))
- (colvar (gensym "COLUMN"))
- (charvar (gensym "CHAR")))
- `(let* ((,streamvar ,stream)
- (,linevar (position-aware-stream-line ,streamvar))
- (,colvar (position-aware-stream-column ,streamvar)))
- (macrolet ((update (,charvar)
- ;; This gets a little hairy. Hold tight.
- `(multiple-value-setq (,',linevar ,',colvar)
- (update-position ,,charvar ,',linevar ,',colvar))))
- (unwind-protect
- (progn ,@body)
- (setf (position-aware-stream-line ,streamvar) ,linevar
- (position-aware-stream-column ,streamvar) ,colvar))))))
-
-;; 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)
-
- ;; Tweak the position so that the next time the character is read, it will
- ;; end up here. 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.
- (with-slots (line column) stream
- (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)
- (decf line)
- (setf column 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.
- (#\tab
- (decf column))
-
- ;; Anything else: just decrement the column and cross fingers.
- (t
- (decf column))))
-
- ;; And actually do it. (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.)
- (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.
-
-(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
-;;; -*-lisp-*-
-;;;
-;;; Collections of properties
-;;;
-;;; (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)
-
-;;;--------------------------------------------------------------------------
-;;; Expression parser.
-
-(defun parse-expression (lexer)
- "Parse an expression from the LEXER.
-
- The return values are the expression's VALUE and TYPE; currently the types
- are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value
- being produced, the TYPE :INVALID is returned.
-
- Expression syntax is rather limited at the moment:
-
- expression : term | expression `+' term | expression `-' term
- term : factor | term `*' factor | term `/' factor
- factor : primary | `+' factor | `-' factor
- primary : integer | identifier | string
- | `(' expression `)'
- | `?' lisp-expression
-
- Identifiers are just standalone things. They don't name values. The
- operators only work on integer values at the moment. (Confusingly, you
- can manufacture rational numbers using the division operator, but they
- still get called integers.)"
-
- (let ((valstack nil)
- (opstack nil))
-
- ;; The following is a simple operator-precedence parser: the
- ;; recursive-descent parser I wrote the first time was about twice the
- ;; size and harder to extend.
- ;;
- ;; The parser flips between two states, OPERAND and OPERATOR. It starts
- ;; out in OPERAND state, and tries to parse a sequence of prefix
- ;; operators followed by a primary expression. Once it's found one, it
- ;; pushes the operand onto the value stack and flips to OPERATOR state;
- ;; if it fails, it reports a syntax error and exits. The OPERAND state
- ;; tries to read a sequence of postfix operators followed by an infix
- ;; operator; if it fails, it assumes that it hit the stuff following the
- ;; expression and stops.
- ;;
- ;; Each operator is pushed onto a stack consisting of lists of the form
- ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean
- ;; tighter binding. The TY* are operand types; operands are popped off
- ;; the operand stack, checked against the requested types, and passed to
- ;; the FUNC, which returns a new operand to be pushed in their place.
- ;;
- ;; Usually, when a binary operator is pushed, existing stacked operators
- ;; with higher precedence are applied. Whether operators with /equal/
- ;; precedence are also applied depends on the associativity of the
- ;; operator: apply equal precedence operators for left-associative
- ;; operators, don't apply for right-associative. When we reach the end
- ;; of the expression, all the remaining operators on the stack are
- ;; applied.
- ;;
- ;; Parenthesized subexpressions are implemented using a hack: when we
- ;; find an open paren in operand position, a fake operator is pushed with
- ;; an artificially low precedece, which protects the operators beneath
- ;; from premature application. The fake operator's function reports an
- ;; error -- this will be triggered only if we reach the end of the
- ;; expression before a matching close-paren, because the close-paren
- ;; handler will pop the fake operator before it does any harm.
-
- (restart-case
- (labels ((apply-op (op)
- ;; Apply the single operator list OP to the values on the
- ;; value stack.
- (let ((func (pop op))
- (args nil))
- (dolist (ty (reverse (cdr op)))
- (let ((arg (pop valstack)))
- (cond ((eq (car arg) :invalid)
- (setf func nil))
- ((eq (car arg) ty)
- (push (cdr arg) args))
- (t
- (cerror* "Type mismatch: wanted ~A; found ~A"
- ty (car arg))
- (setf func nil)))))
- (if func
- (multiple-value-bind (type value) (apply func args)
- (push (cons type value) valstack))
- (push '(:invalid . nil) valstack))))
-
- (apply-all (prec)
- ;; Apply all operators with precedence PREC or higher.
- (loop
- (when (or (null opstack) (< (cadar opstack) prec))
- (return))
- (apply-op (pop opstack)))))
-
- (tagbody
-
- operand
- ;; Operand state. Push prefix operators, and try to read a
- ;; primary operand.
- (case (token-type lexer)
-
- ;; Aha. A primary. Push it onto the stack, and see if
- ;; there's an infix operator.
- ((:integer :id :string :char)
- (push (cons (token-type lexer)
- (token-value lexer))
- valstack)
- (go operator))
-
- ;; Look for a Lisp S-expression.
- (#\?
- (with-lexer-stream (stream lexer)
- (let ((value (eval (read stream t))))
- (push (cons (property-type value) value) valstack)))
- (go operator))
-
- ;; Arithmetic unary operators. Push an operator for `+' for
- ;; the sake of type-checking.
- (#\+
- (push (list (lambda (x) (values :integer x))
- 10 :integer)
- opstack))
- (#\-
- (push (list (lambda (x) (values :integer (- x)))
- 10 :integer)
- opstack))
-
- ;; The open-paren hack. Push a magic marker which will
- ;; trigger an error if we hit the end of the expression.
- ;; Inside the paren, we're still looking for an operand.
- (#\(
- (push (list (lambda ()
- (error "Expected `)' but found ~A"
- (format-token lexer)))
- -1)
- opstack))
-
- ;; Failed to find anything. Report an error and give up.
- (t
- (error "Expected expression but found ~A"
- (format-token lexer))))
-
- ;; Assume prefix operators as the default, so go round for more.
- (next-token lexer)
- (go operand)
-
- operator
- ;; Operator state. Push postfix operators, and try to read an
- ;; infix operator. It turns out that we're always a token
- ;; behind here, so catch up.
- (next-token lexer)
- (case (token-type lexer)
-
- ;; Binary operators.
- (#\+ (apply-all 3)
- (push (list (lambda (x y) (values :integer (+ x y)))
- 3 :integer :integer)
- opstack))
- (#\- (apply-all 3)
- (push (list (lambda (x y) (values :integer (- x y)))
- 3 :integer :integer)
- opstack))
- (#\* (apply-all 5)
- (push (list (lambda (x y) (values :integer (* x y)))
- 5 :integer :integer)
- opstack))
- (#\/ (apply-all 5)
- (push (list (lambda (x y)
- (if (zerop y)
- (progn (cerror* "Division by zero")
- (values nil :invalid))
- (values (/ x y) :integer)))
- 5 :integer :integer)
- opstack))
-
- ;; The close-paren hack. Finish off the operators pushed
- ;; since the open-paren. If the operator stack is now empty,
- ;; this is someone else's paren, so exit. Otherwise pop our
- ;; magic marker, and continue looking for an operator.
- (#\) (apply-all 0)
- (when (null opstack)
- (go done))
- (pop opstack)
- (go operator))
-
- ;; Nothing useful. Must have hit the end, so leave.
- (t (go done)))
-
- ;; Assume we found the binary operator as a default, so snarf a
- ;; token and head back.
- (next-token lexer)
- (go operand)
-
- done)
-
- ;; Apply all the pending operators. If there's an unmatched
- ;; open paren, this will trigger the error message.
- (apply-all -99)
-
- ;; If everything worked out, we should have exactly one operand
- ;; left. This is the one we want.
- (assert (and (consp valstack)
- (null (cdr valstack))))
- (values (cdar valstack) (caar valstack)))
- (continue ()
- :report "Return an invalid value and continue."
- (values nil :invalid)))))
-
-;;;--------------------------------------------------------------------------
-;;; Property set parsing.
-
-(defun parse-property (lexer pset)
- "Parse a single property from LEXER; add it to PSET."
- (let ((name (require-token lexer :id)))
- (require-token lexer #\=)
- (multiple-value-bind (value type) (parse-expression lexer)
- (unless (eq type :invalid)
- (add-property pset name value :type type :location lexer)))))
-
-(defun parse-property-set (lexer)
- "Parse a property set from LEXER.
-
- If there wasn't one to parse, return nil; this isn't considered an error,
- and GET-PROPERTY will perfectly happily report defaults for all requested
- properties."
-
- (when (require-token lexer #\[ :errorp nil)
- (let ((pset (make-pset)))
- (loop
- (parse-property lexer pset)
- (unless (require-token lexer #\, :errorp nil)
- (return)))
- (require-token lexer #\])
- pset)))
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]")
- (let* ((in (make-instance 'position-aware-input-stream :stream raw))
- (lexer (make-instance 'sod-lexer :stream in)))
- (next-char lexer)
- (next-token lexer)
- (multiple-value-call #'values
- (parse-property-set lexer)
- (token-type lexer))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /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)))))
-
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; System definition for SOD
-;;;
-;;; (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:defpackage #:sod-package
- (:use #:common-lisp #:asdf))
-
-(cl:in-package #:sod-package)
-
-;;;--------------------------------------------------------------------------
-;;; 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 Definition 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."
-
- ;; And now for how to build it.
- ;;
- ;; The big tables in parser.lisp need to be earlier. CLEAR-THE-DECKS ought
- ;; to do more stuff, including calling BOOTSTRAP-CLASSES. Generally, the
- ;; code isn't very well organized at the moment.
- :components
- ((:file "package")
- (:file "utilities" :depends-on ("package"))
- (:file "tables" :depends-on ("package"))
- (:file "c-types" :depends-on ("utilities"))
- (:file "codegen" :depends-on ("c-types"))
- (:file "posn-stream" :depends-on ("utilities"))
- (:file "errors" :depends-on ("posn-stream"))
- (:file "lex" :depends-on ("posn-stream" "errors"))
- (:file "pset" :depends-on ("lex"))
- (:file "parse-c-types" :depends-on ("lex" "c-types" "tables"))
- (:file "class-defs" :depends-on ("parse-c-types"))
- (:file "cpl" :depends-on ("class-defs"))
- (: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" "class-defs" "tables"))
- (:file "builtin" :depends-on ("module" "class-layout"))
- (:file "output" :depends-on ("module"))
- (: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-*-
-;;;
-;;; Main tables for the 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)
-
-;;;--------------------------------------------------------------------------
-;;; Main tables.
-
-(defvar *module-map* (make-hash-table :test #'equal)
- "A hash table mapping file truenames (pathnames) to modules.
-
- This is used to prevent multiple inclusion of a single module, which would
- be bad. Usually it maps pathnames to MODULE objects. As a special case,
- the truename a module which is being parsed maps to :IN-PROGRESS, which
- can be used to detect dependency cycles.")
-
-(defvar *type-map* (make-hash-table :test #'equal)
- "A hash table mapping type names to the C types they describe.
-
- Since a class is a C type, it gets its own entry in here as a C-CLASS-TYPE
- object. This is how we find classes by name: the C-CLASS-TYPE object has
- a reference to the underlying SOD-CLASS instance.")
-
-(defparameter *builtin-module* nil
- "Built-in module; populated later.")
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-(defparameter *clear-the-decks-functions*
- '(reset-type-and-module-map
- reset-builtin-module))
-
-(defun reset-type-and-module-map ()
- "Reset the main hash tables, clearing the translator's state.
-
- One of the *CLEAR-THE-DECKS-FUNCTIONS*."
-
- (setf *module-map* (make-hash-table :test #'equal)
- *type-map* (make-hash-table :test #'equal)))
-
-(defun populate-type-map ()
- "Store some important simple types in the type map."
- (dolist (name '("va_list" "size_t" "ptrdiff_t"))
- (setf (gethash name *type-map*)
- (make-simple-type name))))
-
-(defun clear-the-decks ()
- "Reinitialize the translator's state.
-
- This is mainly useful when testing the translator from a Lisp REPL."
- (dolist (func *clear-the-decks-functions*)
- (funcall func)))
-
-#+test
-(clear-the-decks)
-
-;;;----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff