mdw@git.distorted.org.uk Git - sod/blob - pre-reorg/class-builder.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Equipment for building classes and friends
   4 ;;;
   5 ;;; (c) 2009 Straylight/Edgeware
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This file is part of the Simple Object Definition system.
  11 ;;;
  12 ;;; SOD is free software; you can redistribute it and/or modify
  13 ;;; it under the terms of the GNU General Public License as published by
  14 ;;; the Free Software Foundation; either version 2 of the License, or
  15 ;;; (at your option) any later version.
  16 ;;;
  17 ;;; SOD is distributed in the hope that it will be useful,
  18 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;;; GNU General Public License for more details.
  21 ;;;
  22 ;;; You should have received a copy of the GNU General Public License
  23 ;;; along with SOD; if not, write to the Free Software Foundation,
  24 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  25
  26 (cl:in-package #:sod)
  27
  28 ;;;--------------------------------------------------------------------------
  29 ;;; Finding things by name
  30
  31 (defun find-superclass-by-nick (class nick)
  32   "Returns the superclass of CLASS with nickname NICK, or signals an error."
  33
  34   ;; Slightly tricky.  The class almost certainly hasn't been finalized, so
  35   ;; trundle through its superclasses and hope for the best.
  36   (if (string= nick (sod-class-nickname class))
  37       class
  38       (or (some (lambda (super)
  39                   (find nick (sod-class-precedence-list super)
  40                         :key #'sod-class-nickname
  41                         :test #'string=))
  42                 (sod-class-direct-superclasses class))
  43           (error "No superclass of `~A' with nickname `~A'" class nick))))
  44
  45 (flet ((find-item-by-name (what class list name key)
  46          (or (find name list :key key :test #'string=)
  47              (error "No ~A in class `~A' with name `~A'" what class name))))
  48
  49   (defun find-instance-slot-by-name (class super-nick slot-name)
  50     (let ((super (find-superclass-by-nick class super-nick)))
  51       (find-item-by-name "slot" super (sod-class-slots super)
  52                          slot-name #'sod-slot-name)))
  53
  54   (defun find-class-slot-by-name (class super-nick slot-name)
  55     (let* ((meta (sod-class-metaclass class))
  56            (super (find-superclass-by-nick meta super-nick)))
  57       (find-item-by-name "slot" super (sod-class-slots super)
  58                          slot-name #'sod-slot-name)))
  59
  60   (defun find-message-by-name (class super-nick message-name)
  61     (let ((super (find-superclass-by-nick class super-nick)))
  62       (find-item-by-name "message" super (sod-class-messages super)
  63                          message-name #'sod-message-name))))
  64
  65 ;;;--------------------------------------------------------------------------
  66 ;;; Class construction.
  67
  68 (defun make-sod-class (name superclasses pset &optional location)
  69   "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
  70
  71    This is the main constructor function for classes.  The protocol works as
  72    follows.  The :LISP-CLASS property in PSET is checked: if it exists, it
  73    must be a symbol naming a (CLOS) class, which is used in place of
  74    SOD-CLASS.  All of the arguments are then passed to MAKE-INSTANCE; further
  75    behaviour is left to the standard CLOS instance construction protocol; for
  76    example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
  77
  78    Minimal sanity checking is done during class construction; most of it is
  79    left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
  80
  81    Unused properties in PSET are diagnosed as errors."
  82
  83   (with-default-error-location (location)
  84     (let ((class (make-instance (get-property pset :lisp-class :symbol
  85                                               'sod-class)
  86                                 :name name
  87                                 :superclasses superclasses
  88                                 :location (file-location location)
  89                                 :pset pset)))
  90       (check-unused-properties pset)
  91       class)))
  92
  93 (defgeneric guess-metaclass (class)
  94   (:documentation
  95    "Determine a suitable metaclass for the CLASS.
  96
  97    The default behaviour is to choose the most specific metaclass of any of
  98    the direct superclasses of CLASS, or to signal an error if that failed."))
  99
 100 ;;;--------------------------------------------------------------------------
 101 ;;; Slot construction.
 102
 103 (defgeneric make-sod-slot (class name type pset &optional location)
 104   (:documentation
 105    "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
 106
 107    This is the main constructor function for slots.  This is a generic
 108    function primarily so that the CLASS can intervene in the construction
 109    process.  The default method uses the :LISP-CLASS property (defaulting to
 110    SOD-SLOT) to choose a (CLOS) class to instantiate.  The slot is then
 111    constructed by MAKE-INSTANCE passing the arguments as initargs; further
 112    behaviour is left to the standard CLOS instance construction protocol; for
 113    example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
 114
 115    Unused properties on PSET are diagnosed as errors."))
 116
 117 ;;;--------------------------------------------------------------------------
 118 ;;; Slot initializer construction.
 119
 120 ;;;--------------------------------------------------------------------------
 121 ;;; Message construction.
 122
 123 ;;;--------------------------------------------------------------------------
 124 ;;; Method construction.
 125
 126 ;;;--------------------------------------------------------------------------
 127 ;;; Builder macros.
 128
 129 ;;;----- That's all, folks --------------------------------------------------