From 8f33dc2a5d924fc6747d32d047b8c52ab753331c Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 25 Aug 2015 17:46:54 +0100 Subject: [PATCH 1/1] pre-reorg/: Delete this old cruft. --- pre-reorg/builtin.lisp | 42 --- pre-reorg/c-types.lisp | 79 ----- pre-reorg/class-builder.lisp | 129 -------- pre-reorg/class-defs.lisp | 515 -------------------------------- pre-reorg/class-finalize.lisp | 31 -- pre-reorg/class-layout.lisp | 80 ----- pre-reorg/class-output.lisp | 579 ------------------------------------ pre-reorg/codegen.lisp | 89 ------ pre-reorg/combination.lisp | 34 --- pre-reorg/cpl.lisp | 133 --------- pre-reorg/cutting-room-floor.lisp | 491 ------------------------------- pre-reorg/errors.lisp | 243 --------------- pre-reorg/examples.lisp | 75 ----- pre-reorg/foo.lisp | 2 - pre-reorg/lex.lisp | 604 -------------------------------------- pre-reorg/methods.lisp | 43 --- pre-reorg/module-output.lisp | 40 --- pre-reorg/module.lisp | 340 --------------------- pre-reorg/output.lisp | 63 ---- pre-reorg/parse-c-types.lisp | 534 --------------------------------- pre-reorg/posn-stream.lisp | 437 --------------------------- pre-reorg/pset.lisp | 272 ----------------- pre-reorg/sift.lisp | 333 --------------------- pre-reorg/sod.asd | 94 ------ pre-reorg/tables.lisp | 80 ----- 25 files changed, 5362 deletions(-) delete mode 100644 pre-reorg/builtin.lisp delete mode 100644 pre-reorg/c-types.lisp delete mode 100644 pre-reorg/class-builder.lisp delete mode 100644 pre-reorg/class-defs.lisp delete mode 100644 pre-reorg/class-finalize.lisp delete mode 100644 pre-reorg/class-layout.lisp delete mode 100644 pre-reorg/class-output.lisp delete mode 100644 pre-reorg/codegen.lisp delete mode 100644 pre-reorg/combination.lisp delete mode 100644 pre-reorg/cpl.lisp delete mode 100644 pre-reorg/cutting-room-floor.lisp delete mode 100644 pre-reorg/errors.lisp delete mode 100644 pre-reorg/examples.lisp delete mode 100644 pre-reorg/foo.lisp delete mode 100644 pre-reorg/lex.lisp delete mode 100644 pre-reorg/methods.lisp delete mode 100644 pre-reorg/module-output.lisp delete mode 100644 pre-reorg/module.lisp delete mode 100644 pre-reorg/output.lisp delete mode 100644 pre-reorg/parse-c-types.lisp delete mode 100644 pre-reorg/posn-stream.lisp delete mode 100644 pre-reorg/pset.lisp delete mode 100644 pre-reorg/sift.lisp delete mode 100644 pre-reorg/sod.asd delete mode 100644 pre-reorg/tables.lisp diff --git a/pre-reorg/builtin.lisp b/pre-reorg/builtin.lisp deleted file mode 100644 index ef99571..0000000 --- a/pre-reorg/builtin.lisp +++ /dev/null @@ -1,42 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/c-types.lisp b/pre-reorg/c-types.lisp deleted file mode 100644 index 4a443cd..0000000 --- a/pre-reorg/c-types.lisp +++ /dev/null @@ -1,79 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/class-builder.lisp b/pre-reorg/class-builder.lisp deleted file mode 100644 index 5107ffb..0000000 --- a/pre-reorg/class-builder.lisp +++ /dev/null @@ -1,129 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/class-defs.lisp b/pre-reorg/class-defs.lisp deleted file mode 100644 index 59c8716..0000000 --- a/pre-reorg/class-defs.lisp +++ /dev/null @@ -1,515 +0,0 @@ -;;; -*-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 "~:@" - (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 -------------------------------------------------- diff --git a/pre-reorg/class-finalize.lisp b/pre-reorg/class-finalize.lisp deleted file mode 100644 index fc2d967..0000000 --- a/pre-reorg/class-finalize.lisp +++ /dev/null @@ -1,31 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/class-layout.lisp b/pre-reorg/class-layout.lisp deleted file mode 100644 index 8b6b1eb..0000000 --- a/pre-reorg/class-layout.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/class-output.lisp b/pre-reorg/class-output.lisp deleted file mode 100644 index b93a0a0..0000000 --- a/pre-reorg/class-output.lisp +++ /dev/null @@ -1,579 +0,0 @@ -;;; -*-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 "~@~%" - (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 -------------------------------------------------- diff --git a/pre-reorg/codegen.lisp b/pre-reorg/codegen.lisp deleted file mode 100644 index c177a6a..0000000 --- a/pre-reorg/codegen.lisp +++ /dev/null @@ -1,89 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/combination.lisp b/pre-reorg/combination.lisp deleted file mode 100644 index 2287fab..0000000 --- a/pre-reorg/combination.lisp +++ /dev/null @@ -1,34 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/cpl.lisp b/pre-reorg/cpl.lisp deleted file mode 100644 index eb7a3fa..0000000 --- a/pre-reorg/cpl.lisp +++ /dev/null @@ -1,133 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/cutting-room-floor.lisp b/pre-reorg/cutting-room-floor.lisp deleted file mode 100644 index 294e5b6..0000000 --- a/pre-reorg/cutting-room-floor.lisp +++ /dev/null @@ -1,491 +0,0 @@ -;;;-------------------------------------------------------------------------- -;;; 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 diff --git a/pre-reorg/errors.lisp b/pre-reorg/errors.lisp deleted file mode 100644 index 6ff6747..0000000 --- a/pre-reorg/errors.lisp +++ /dev/null @@ -1,243 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/examples.lisp b/pre-reorg/examples.lisp deleted file mode 100644 index 82702a6..0000000 --- a/pre-reorg/examples.lisp +++ /dev/null @@ -1,75 +0,0 @@ -(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=)))) diff --git a/pre-reorg/foo.lisp b/pre-reorg/foo.lisp deleted file mode 100644 index b5b8509..0000000 --- a/pre-reorg/foo.lisp +++ /dev/null @@ -1,2 +0,0 @@ -;;; -(write-line "stuff's a-goin' on") diff --git a/pre-reorg/lex.lisp b/pre-reorg/lex.lisp deleted file mode 100644 index d7fd2c0..0000000 --- a/pre-reorg/lex.lisp +++ /dev/null @@ -1,604 +0,0 @@ -;;; -*-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) "") - ((eql :string) "") - ((eql :char) "") - ((eql :id) (format nil "" 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 -------------------------------------------------- diff --git a/pre-reorg/methods.lisp b/pre-reorg/methods.lisp deleted file mode 100644 index 93782be..0000000 --- a/pre-reorg/methods.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/module-output.lisp b/pre-reorg/module-output.lisp deleted file mode 100644 index fd690ad..0000000 --- a/pre-reorg/module-output.lisp +++ /dev/null @@ -1,40 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/module.lisp b/pre-reorg/module.lisp deleted file mode 100644 index 2b339f4..0000000 --- a/pre-reorg/module.lisp +++ /dev/null @@ -1,340 +0,0 @@ -;;; -*-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 ; 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 ; ~ - 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 -------------------------------------------------- diff --git a/pre-reorg/output.lisp b/pre-reorg/output.lisp deleted file mode 100644 index dd8bc04..0000000 --- a/pre-reorg/output.lisp +++ /dev/null @@ -1,63 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/parse-c-types.lisp b/pre-reorg/parse-c-types.lisp deleted file mode 100644 index 63e8b9b..0000000 --- a/pre-reorg/parse-c-types.lisp +++ /dev/null @@ -1,534 +0,0 @@ -;;; -*-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 "" - :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 -------------------------------------------------- diff --git a/pre-reorg/posn-stream.lisp b/pre-reorg/posn-stream.lisp deleted file mode 100644 index ffc06d6..0000000 --- a/pre-reorg/posn-stream.lisp +++ /dev/null @@ -1,437 +0,0 @@ -;;; -*-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 "~:[~;~:*~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 -------------------------------------------------- diff --git a/pre-reorg/pset.lisp b/pre-reorg/pset.lisp deleted file mode 100644 index 20f0ff9..0000000 --- a/pre-reorg/pset.lisp +++ /dev/null @@ -1,272 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/sift.lisp b/pre-reorg/sift.lisp deleted file mode 100644 index 7d78774..0000000 --- a/pre-reorg/sift.lisp +++ /dev/null @@ -1,333 +0,0 @@ -;;; 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))))) - diff --git a/pre-reorg/sod.asd b/pre-reorg/sod.asd deleted file mode 100644 index 48dbcaa..0000000 --- a/pre-reorg/sod.asd +++ /dev/null @@ -1,94 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/pre-reorg/tables.lisp b/pre-reorg/tables.lisp deleted file mode 100644 index a639770..0000000 --- a/pre-reorg/tables.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*-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 -------------------------------------------------- -- 2.11.0