[pro] Initialization of shared slots

[Samium Gromoff]

On Sat, 8 Jan 2011 15:48:33 +0100, Pascal Costanza <pc at p-cos.net> wrote:
> 
> On 8 Jan 2011, at 14:15, Samium Gromoff wrote:
> 
> > On Fri, 7 Jan 2011 23:42:23 +0100, Pascal Costanza <pc at p-cos.net> wrote:
> >> There is no real advantage in having shared slots over global special
> >> variables. On top of that, the slot access protocols in the CLOS MOP
> >> also don't work that well in conjunction with shared slots. So it's
> >> better to avoid them. Fortunately, this is the only feature in CLOS that
> >> doesn't make any sense, as far as I can tell.
> > 
> > This is sad, indeed, as shared slots could have been used to associate
> > information with sub-lattice of the class relationship lattice.  I have
> > been tempted to do exactly this, multiple times, having, instead, to
> > resort to manual storage of this information.
> 
> What exactly would you like to do? There are ways to do such things using the CLOS MOP...

Ok, real world code, beware.  While reading, only pay attention how
VCS-TYPE-MIXIN threads through the "slices".

(defclass vcs-type-mixin ()
 (# the following slot is absent in real code, I have to emulate it
  (enabled-p :accessor vcs-type-enabled-p :allocation :class)
  (vcs-type :reader vcs-type :initarg :vcs-type)))

;;;;; VCS slice (protocol classes)
;;; exhaustive partition of VCS-TYPE-MIXIN
(defclass git (vcs-type-mixin)                            () (:default-initargs :vcs-type 'git))
(defclass nongit-mixin ()                                 ())
(defclass hg (vcs-type-mixin nongit-mixin)                () (:default-initargs :vcs-type 'hg))
(defclass darcs (vcs-type-mixin nongit-mixin)             () (:default-initargs :vcs-type 'darcs))
(defclass cvs (vcs-type-mixin wrinkle-mixin nongit-mixin) () (:default-initargs :vcs-type 'cvs))
(defclass svn (vcs-type-mixin wrinkle-mixin nongit-mixin) () (:default-initargs :vcs-type 'svn))
(defclass tarball (vcs-type-mixin nongit-mixin)           () (:default-initargs :vcs-type 'tarball))

;;;;; product slice (protocol classes)
;;; exhaustive partition of type product of VCS-TYPE, TRANSPORT-MIXIN, CLONE-SEPARATION-MIXIN, and
;;;   FETCH-INDIRECTION-MIXIN
(defclass git-native   (git        native   direct-fetch   clone-is-fetch) () (:default-initargs :schema 'git))
(defclass git-http     (git        http     direct-fetch   clone-is-fetch) ())
;;; ...... 8< ......
(defclass git-combined (git-native git-http combined) ())
;;; ...... >8 ......
(defclass hg-http      (hg         http     indirect-fetch separate-clone) ())
(defclass darcs-http   (darcs      http     indirect-fetch separate-clone) ())
(defclass cvs-rsync    (cvs        rsync    indirect-fetch clone-is-fetch) ())
(defclass cvs-native   (cvs        native   direct-fetch   clone-is-fetch) () (:default-initargs :schema '|:PSERVER|))
(defclass tarball-http (tarball    http     direct-fetch   clone-is-fetch) ((initial-version :accessor initial-tarball-version :initarg :initial-version)))
(defclass svn-rsync    (svn        rsync    indirect-fetch clone-is-fetch) ())
;;; ...... 8< ......
(defclass svn-direct   (svn                 direct-fetch) ())
;;; ...... >8 ......
(defclass svn-http     (svn-direct http     #| direct |#   clone-is-fetch) ())
(defclass svn-native   (svn-direct native   #| direct |#   clone-is-fetch) () (:default-initargs :schema 'svn))

;;;;; intermediate slice (protocol classes)
;;; Location * VCS
(defclass git-remote (remote git) ())
(defclass darcs-remote (remote darcs) ())
(defclass hg-remote (remote hg) ())
(defclass cvs-remote (remote cvs) ())
(defclass svn-remote (remote svn) ())
(defclass tarball-remote (remote tarball) ())

;;;;; instantiable classes
;;; almost most specific (due to GATE mixin), exhaustive partition of REMOTE
(defclass git-native-remote (git-remote git-native) ())
(defclass git-http-remote (git-remote git-http) ())
(defclass git-combined-remote (git-remote git-combined) ())
(defclass hg-http-remote (hg-remote hg-http) ())
(defclass darcs-http-remote (darcs-remote darcs-http) ())
(defclass cvs-rsync-remote (cvs-remote cvs-rsync) ())
(defclass cvs-native-remote (cvs-remote cvs-native) ())
(defclass svn-rsync-remote (svn-remote svn-rsync) ())
(defclass svn-http-remote (svn-remote svn-http) ())
(defclass svn-native-remote (svn-remote svn-native) ())
(defclass tarball-http-remote (tarball-remote tarball-http) ())

(defun vcs-enabled-p (type)
  "Problem function."
  (class-slot type 'enabled-p))

...I want to be able to use VCS-ENABLED-P on any slice before
instantiable classes are instantiated.

-- 
regards,
  Samium Gromoff
--
"Actually I made up the term 'object-oriented', and I can tell you I
did not have C++ in mind." - Alan Kay (OOPSLA 1997 Keynote)