+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Equipment for building classes and friends
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Finding things by name
-
-(defun find-superclass-by-nick (class nick)
- "Returns the superclass of CLASS with nickname NICK, or signals an error."
-
- ;; Slightly tricky. The class almost certainly hasn't been finalized, so
- ;; trundle through its superclasses and hope for the best.
- (if (string= nick (sod-class-nickname class))
- class
- (or (some (lambda (super)
- (find nick (sod-class-precedence-list super)
- :key #'sod-class-nickname
- :test #'string=))
- (sod-class-direct-superclasses class))
- (error "No superclass of `~A' with nickname `~A'" class nick))))
-
-(flet ((find-item-by-name (what class list name key)
- (or (find name list :key key :test #'string=)
- (error "No ~A in class `~A' with name `~A'" what class name))))
-
- (defun find-instance-slot-by-name (class super-nick slot-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-class-slot-by-name (class super-nick slot-name)
- (let* ((meta (sod-class-metaclass class))
- (super (find-superclass-by-nick meta super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-message-by-name (class super-nick message-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "message" super (sod-class-messages super)
- message-name #'sod-message-name))))
-
-;;;--------------------------------------------------------------------------
-;;; Class construction.
-
-(defun make-sod-class (name superclasses pset &optional location)
- "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
-
- This is the main constructor function for classes. The protocol works as
- follows. The :LISP-CLASS property in PSET is checked: if it exists, it
- must be a symbol naming a (CLOS) class, which is used in place of
- SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further
- behaviour is left to the standard CLOS instance construction protocol; for
- example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
-
- Minimal sanity checking is done during class construction; most of it is
- left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
-
- Unused properties in PSET are diagnosed as errors."
-
- (with-default-error-location (location)
- (let ((class (make-instance (get-property pset :lisp-class :symbol
- 'sod-class)
- :name name
- :superclasses superclasses
- :location (file-location location)
- :pset pset)))
- (check-unused-properties pset)
- class)))
-
-(defgeneric guess-metaclass (class)
- (:documentation
- "Determine a suitable metaclass for the CLASS.
-
- The default behaviour is to choose the most specific metaclass of any of
- the direct superclasses of CLASS, or to signal an error if that failed."))
-
-;;;--------------------------------------------------------------------------
-;;; Slot construction.
-
-(defgeneric make-sod-slot (class name type pset &optional location)
- (:documentation
- "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
-
- This is the main constructor function for slots. This is a generic
- function primarily so that the CLASS can intervene in the construction
- process. The default method uses the :LISP-CLASS property (defaulting to
- SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then
- constructed by MAKE-INSTANCE passing the arguments as initargs; further
- behaviour is left to the standard CLOS instance construction protocol; for
- example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
-
- Unused properties on PSET are diagnosed as errors."))
-
-;;;--------------------------------------------------------------------------
-;;; Slot initializer construction.
-
-;;;--------------------------------------------------------------------------
-;;; Message construction.
-
-;;;--------------------------------------------------------------------------
-;;; Method construction.
-
-;;;--------------------------------------------------------------------------
-;;; Builder macros.
-
-;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff