From: mac
Subject: MOP custom defclass options
Date: 
Message-ID: <1145420379.821719.33420@e56g2000cwe.googlegroups.com>
Hi all,

I want to use one of the techniques presented in AMOP (Chapter 3,
extending the language)

On Page 83, section #3.5, the authors illustrated how to add extra
functionality to a slot of a class.

By implementing a meta object attribute-class and adding a new slot arg
:attributes, you can do something like this:

(defclass monitored-credit-rating (credit-rating)
 ((level :attributes (last-checked interval)))
 (:metaclass attribute-class))

(setq cr (make-instance 'credit-rating))
(setf (slot-attribute cr 'level 'date-set) "12/15/90")

(slot-attribute cr 'level 'date-set) => "12/15/90"


The implementation is straightforward. First define a custom meta
object

(defclass attributes-class (standard-class) ())

Then, you can specialize on 'compute-effective-slot-definition and
'compute-slots so that there will be an extra 'all-attributes slot
created for each object to hold the slot-attribute properties.

The only reminding work is to find a way so that defclass macro will
accept the extra slot arg :attributes.

CL-USER 1 > (defclass monitored-credit-rating (credit-rating)
 ((level :attributes (last-checked interval)))
(:metaclass attribute-class))

Error: MAKE-INSTANCE is called with unknown keyword :ATTRIBUTES among
the arguments (STANDARD-DIRECT-SLOT-DEFINITION :NAME LEVEL :ATTRIBUTES
(LAST-CHECKED INTERVAL)) which is not one of (:DOCUMENTATION :FLAGS
:INITARGS :ALLOCATION :TYPE :INITFUNCTION :INITFORM :NAME :WRITERS
:READERS).


On page 95, there's a reference implementation of defclass, which
calls a generic function canonicalize-defclass-option so that a
specialized attributes-class can process the :attributes arg.

But canonicalize-defclass-option is not part of MOP. So the only option
that I can think of is to write another defclass* to bypass defclass
and mess with ensure-class directly.

Is there an alternative to this? If I want to add another feature to
the slot, I'd have to write another macro, defclass**, but then I
cannot use defclass* and defclass** at the same time.

Thanks,
-- Mac
From: Pascal Costanza
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <4am1i3Ftqh6tU1@individual.net>
mac wrote:
> Hi all,
> 
> I want to use one of the techniques presented in AMOP (Chapter 3,
> extending the language)
> 
> On Page 83, section #3.5, the authors illustrated how to add extra
> functionality to a slot of a class.
> 
> By implementing a meta object attribute-class and adding a new slot arg
> :attributes, you can do something like this:
> 
> (defclass monitored-credit-rating (credit-rating)
>  ((level :attributes (last-checked interval)))
>  (:metaclass attribute-class))
> 
> (setq cr (make-instance 'credit-rating))
> (setf (slot-attribute cr 'level 'date-set) "12/15/90")
> 
> (slot-attribute cr 'level 'date-set) => "12/15/90"
> 
> 
> The implementation is straightforward. First define a custom meta
> object
> 
> (defclass attributes-class (standard-class) ())
> 
> Then, you can specialize on 'compute-effective-slot-definition and
> 'compute-slots so that there will be an extra 'all-attributes slot
> created for each object to hold the slot-attribute properties.
> 
> The only reminding work is to find a way so that defclass macro will
> accept the extra slot arg :attributes.
> 
> CL-USER 1 > (defclass monitored-credit-rating (credit-rating)
>  ((level :attributes (last-checked interval)))
> (:metaclass attribute-class))
> 
> Error: MAKE-INSTANCE is called with unknown keyword :ATTRIBUTES among
> the arguments (STANDARD-DIRECT-SLOT-DEFINITION :NAME LEVEL :ATTRIBUTES
> (LAST-CHECKED INTERVAL)) which is not one of (:DOCUMENTATION :FLAGS
> :INITARGS :ALLOCATION :TYPE :INITFUNCTION :INITFORM :NAME :WRITERS
> :READERS).
> 
> 
> On page 95, there's a reference implementation of defclass, which
> calls a generic function canonicalize-defclass-option so that a
> specialized attributes-class can process the :attributes arg.
> 
> But canonicalize-defclass-option is not part of MOP. So the only option
> that I can think of is to write another defclass* to bypass defclass
> and mess with ensure-class directly.
> 
> Is there an alternative to this? 

Yes, define a new direct slot definition class, roughly like this:

(defclass attribute-direct-slot-definition
           (standard-direct-slot-definition)
   ((attributes :initarg :attributes)))

...and make sure that it is used by your metaclass:

(defmethod direct-slot-definition-class
            ((class attribute-class) &rest initargs)
   (declare (ignore initargs))
   (find-class 'attribute-direct-slot-definition))

Then the standard ANSI defclass form will accept your new :attributes 
for all slots for that metaclass. You can access those attributes in 
compute-effective-slot-definition, but note that they are not 
automatically copied to the resulting effective slot definition - you 
have to do this yourself.

I hope this helps,

Pascal


-- 
3rd European Lisp Workshop
July 3-4 - Nantes, France - co-located with ECOOP 2006
http://lisp-ecoop06.bknr.net/
From: mac
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <1145432311.915808.301800@e56g2000cwe.googlegroups.com>
Thanks Pascal, that's definitely helpful.

I tried the following (slightly modifying the compute-slots as
presented in AMOP p.88).

When I evaluated the defclass form, lispworks and sbcl gave (different)
error message.

SBCL complains that meta-classes #<STANDARD-CLASS STANDARD-CLASS> and
#<STANDARD-CLASS ATTRIBUTES-CLASS> are incompatible. But as defined in
the code, ATTRIBUTES-CLASS is a subclass of STANDARD-CLASS.

Lispworks still gives the same error as I posted in the original
message.

I'm learning how MOP works and read the other post "MOP and slot
definition meta objects". Too bad the first few chapters of AMOP use a
reference CLOS like implementation, which you cannot apply to CLOS
directly.

-- Mac

(in-package :cl-user)

#+sbcl (use-package :sb-mop)

(defclass attributes-class (standard-class) ())

(defclass attribute-direct-slot-definition
    (standard-direct-slot-definition)
  ((attributes :initarg :attributes :initform nil :accessor
slot-definition-attributes)))

(defmethod direct-slot-definition-class
    ((class attributes-class) &rest initargs)
  (declare (ignore initargs))
  (find-class 'attribute-direct-slot-definition))

(defmethod compute-slots ((class attributes-class))
  (let* ((normal-slots (call-next-method))
         (alist
          (mapcar
           #'(lambda (slot)
               (cons (slot-definition-name slot)
                     (mapcar #'(lambda (attr) (cons attr nil))
                             (slot-definition-attributes slot))))
           normal-slots)))
    (cons (make-instance 'standard-direct-slot-definition
                         :name 'all-attributes
                         :initform `',alist
                         :initfunction #'(lambda () alist))
          normal-slots)))

(defclass credit-rating ()
  ((level :attributes (date-set time-set)))
  (:metaclass attributes-class))


;; SBCL

The class #<STANDARD-CLASS STANDARD-OBJECT> was specified as a
super-class of
the class #<ATTRIBUTES-CLASS CREDIT-RATING>, but the meta-classes
#<STANDARD-CLASS STANDARD-CLASS> and #<STANDARD-CLASS ATTRIBUTES-CLASS>
are
incompatible.  Define a method for VALIDATE-SUPERCLASS to avoid this
error.
   [Condition of type SIMPLE-ERROR]

Backtrace:
  0: ((SB-PCL::FAST-METHOD SHARED-INITIALIZE :AFTER (SB-PCL::STD-CLASS
T)) (#(NIL 16 5 17) . #()) #<unavailable argument> #<ATTRIBUTES-CLASS
CREDIT-RATING> T (:NAME CREDIT-RATING :DIRECT-SUPERCLASSES NIL
:DIRECT-SLOTS ((:NAME LEVEL :READERS NIL :WRITERS NIL :INITARGS NIL
:ATTRIBUTES #)) :DEFINITION-SOURCE #S(SB-C:DEFINITION-SOURCE-LOCATION
:NAMESTRING NIL :TOPLEVEL-FORM-NUMBER 0 :PLIST NIL)))
  1: ((LAMBDA (SB-PCL::.PV-CELL. SB-PCL::.NEXT-METHOD-CALL.
SB-PCL::.ARG0. SB-PCL::.ARG1. SB-PCL::.DFUN-REST-ARG.)) #<unavailable
argument> #<unavailable argument> #<ATTRIBUTES-CLASS CREDIT-RATING> T
(:NAME CREDIT-RATING :DIRECT-SUPERCLASSES NIL :DIRECT-SLOTS ((:NAME
LEVEL :READERS NIL :WRITERS NIL :INITARGS NIL :ATTRIBUTES #))
:DEFINITION-SOURCE #S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL
:TOPLEVEL-FORM-NUMBER 0 :PLIST NIL)))
  2: ((SB-PCL::FAST-METHOD MAKE-INSTANCE (CLASS)) #<unavailable
argument> #<unavailable argument> #<STANDARD-CLASS ATTRIBUTES-CLASS>
(:NAME CREDIT-RATING :DIRECT-SUPERCLASSES NIL :DIRECT-SLOTS ((:NAME
LEVEL :READERS NIL :WRITERS NIL :INITARGS NIL :ATTRIBUTES #))
:DEFINITION-SOURCE #S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL
:TOPLEVEL-FORM-NUMBER 0 :PLIST NIL)))
  3: ((SB-PCL::FAST-METHOD ENSURE-CLASS-USING-CLASS (NULL T))
#<unavailable argument> #<unavailable argument> NIL CREDIT-RATING
(:METACLASS ATTRIBUTES-CLASS :DIRECT-SUPERCLASSES NIL :DIRECT-SLOTS
((:NAME LEVEL :READERS NIL :WRITERS NIL :INITARGS NIL :ATTRIBUTES #))
:DEFINITION-SOURCE #S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL
:TOPLEVEL-FORM-NUMBER 0 :PLIST NIL)))
  4: (SB-PCL::REAL-LOAD-DEFCLASS CREDIT-RATING ATTRIBUTES-CLASS NIL
((:NAME LEVEL :READERS NIL :WRITERS NIL :INITARGS NIL :ATTRIBUTES
(DATE-SET TIME-SET))) NIL NIL NIL (LEVEL)
#S(SB-C:DEFINITION-SOURCE-LOCATION :NAMESTRING NIL
:TOPLEVEL-FORM-NUMBER 0 :PLIST NIL))



;; LISPWORKS

MAKE-INSTANCE is called with unknown keyword :ATTRIBUTES among the
arguments (STANDARD-DIRECT-SLOT-DEFINITION

      :NAME

      LEVEL

      :ATTRIBUTES

      (DATE-SET

       TIME-SET)) which is not one of (:DOCUMENTATION

                                       :FLAGS

                                       :INITARGS

                                       :ALLOCATION

                                       :TYPE

                                       :INITFUNCTION

                                       :INITFORM

                                       :NAME

                                       :WRITERS

                                       :READERS).
   [Condition of type CONDITIONS:UNKNOWN-KEYWORD-ERROR]

Backtrace:
  0: CONDITIONS::CONDITIONS-ERROR (:INVISIBLEP T
CONDITIONS:UNKNOWN-KEYWORD-ERROR (:UNKNOWN-ITEM :ATTRIBUTES :KEYWORDS
(:DOCUMENTATION :FLAGS :INITARGS :ALLOCATION :TYPE :INITFUNCTION
:INITFORM :NAME :WRITERS :READERS) :FUNCTION MAKE-INSTANCE :ARGLIST
(STANDARD-DIRECT-SLOT-DEFINITION :NAME LEVEL :ATTRIBUTES (DATE-SET
TIME-SET))))
  1: CERROR ("Ignore the keyword ~*~s" CONDITIONS:UNKNOWN-KEYWORD-ERROR
&REST (:UNKNOWN-ITEM :ATTRIBUTES :KEYWORDS (:DOCUMENTATION :FLAGS
:INITARGS :ALLOCATION :TYPE :INITFUNCTION :INITFORM :NAME :WRITERS
:READERS) :FUNCTION MAKE-INSTANCE :ARGLIST
(STANDARD-DIRECT-SLOT-DEFINITION :NAME LEVEL :ATTRIBUTES (DATE-SET
TIME-SET))))
  2: CLOS::CHECK-MAKE-INSTANCE-ARGS NIL
  3: CLOS::MAKE-INSTANCE-FROM-CLASS-1 (#<STANDARD-CLASS
STANDARD-DIRECT-SLOT-DEFINITION 203B8794> (:NAME LEVEL :ATTRIBUTES
(DATE-SET TIME-SET)))
  4: (METHOD SHARED-INITIALIZE :AFTER (STANDARD-CLASS T))
(#<ATTRIBUTES-CLASS CREDIT-RATING 21A76EC4> :DONT-KNOW &KEY
"<(DIRECT-SUPERCLASSES SUPERCLASSES)>" NIL NIL "<(DIRECT-SLOTS SLOTS)>"
NIL NIL T ...)
  5: #<function 207A811A> NIL
  6: #<function 203DF95A> NIL
  7: #<function 203DF712> NIL
  8: CLOS::MAKE-INSTANCE-FROM-CLASS-1 (#<STANDARD-CLASS
ATTRIBUTES-CLASS 220A7FFC> (:NAME CREDIT-RATING :DIRECT-SLOTS ((:NAME
LEVEL :ATTRIBUTES #)) :DIRECT-SUPERCLASSES (#<STANDARD-CLASS
STANDARD-OBJECT 203B8E54>) :LOCATION :LISTENER))
  9: CLOS::ENSURE-CLASS-USING-CLASS-INTERNAL (NIL CREDIT-RATING &REST
(:DIRECT-SLOTS ((:NAME LEVEL :ATTRIBUTES #)) :DIRECT-SUPERCLASSES
(#<STANDARD-CLASS STANDARD-OBJECT 203B8E54>) :LOCATION :LISTENER) &KEY
#<STANDARD-CLASS ATTRIBUTES-CLASS 220A7FFC> NIL (STANDARD-OBJECT)
:LISTENER "<&ALLOW-OTHER-KEYS>")
 10: CLOS::ENSURE-CLASS-WITHOUT-LOD (CREDIT-RATING &REST (:METACLASS
ATTRIBUTES-CLASS :DIRECT-SLOTS ((:NAME LEVEL :ATTRIBUTES #))
:DIRECT-SUPERCLASSES (STANDARD-OBJECT) :LOCATION :LISTENER) &KEY
:DONT-KNOW "<&ALLOW-OTHER-KEYS>")
From: Pascal Costanza
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <4amj22Ftmpn9U1@individual.net>
mac wrote:
> Thanks Pascal, that's definitely helpful.
> 
> I tried the following (slightly modifying the compute-slots as
> presented in AMOP p.88).
> 
> When I evaluated the defclass form, lispworks and sbcl gave (different)
> error message.
> 
> SBCL complains that meta-classes #<STANDARD-CLASS STANDARD-CLASS> and
> #<STANDARD-CLASS ATTRIBUTES-CLASS> are incompatible. But as defined in
> the code, ATTRIBUTES-CLASS is a subclass of STANDARD-CLASS.

That's not sufficient, you also have to define a silly method on 
validate-superclass, like this:

(defmethod validate-superclass
            ((class attribute-class) (superclass standard-class))
   t)

> Lispworks still gives the same error as I posted in the original
> message.

Maybe try the following:

(defmethod direct-slot-definition-class
            ((class attribute-class) &key &allow-other-keys)
   (find-class 'attribute-direct-slot-definition))

It shouldn't make a difference compared to using &rest initargs, but 
maybe it does...


Pascal

-- 
3rd European Lisp Workshop
July 3-4 - Nantes, France - co-located with ECOOP 2006
http://lisp-ecoop06.bknr.net/
From: mac
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <1145482322.481057.294430@t31g2000cwb.googlegroups.com>
So finally I get this working with sbcl. I'm still confused with the
relationship between direct and effective slots and what does it buy
for the user of MOP. I know there must be a reason but I haven't
studied hard enough.

The sbcl source code helps a lot. Without that it'll be very hard to
figure this out.
Just a side note though, what tools do most lispers use when reading
the source code and figure things out?

For me, I go to the definition of the defclass macro, and see what it
does. But since there are so many functions / macro it uses, I pick the
one that is likely to show me what I need to and then set a trace on
them.

(trace compute-effective-slot-definition-initargs)
(trace canonize-defclass-slots)
(trace std-compute-slots)
(trace make-instance)

BTW, is there a way to link the symbols in sbcl core to the source code
on my disk so that slime-edit-definition will jump to the source file?
It's much better than using etags IMO.

Anyway, thanks for your help. I still have to factor the code so it
works on all lisp implementions that I use (and at the same time brush
up my MOP knowledge).

(in-package :cl-user)
(use-package :sb-mop)

(defclass attributes-class (standard-class) ())

(defmethod sb-pcl:validate-superclass
    ((class attributes-class) (superclass sb-mop:standard-class))
  t)

(defclass attribute-direct-slot-definition
    (sb-pcl:standard-direct-slot-definition)
  ((attributes :initarg :attributes :initform nil
               :accessor slot-definition-attributes)))

(defmethod sb-pcl:direct-slot-definition-class
    ((class attributes-class) &key &allow-other-keys)
  (find-class 'attribute-direct-slot-definition))

(defclass attribute-effective-slot-definition
    (sb-pcl:standard-effective-slot-definition)
  ((attributes :initarg :attributes :initform nil
               :accessor slot-definition-attributes)))

(defmethod sb-pcl:effective-slot-definition-class
    ((class attributes-class) &key &allow-other-keys)
  (find-class 'attribute-effective-slot-definition))

(defmethod sb-pcl::compute-effective-slot-definition-initargs
    ((class attributes-class) direct-slotds)
  (let* ((attributes nil))
    (dolist (slotd direct-slotds)
      (when slotd
        (unless attributes
          (setq attributes (slot-definition-attributes slotd)))))
    (append (call-next-method) (list :attributes attributes))))

(defmethod sb-pcl:compute-slots ((class attributes-class))
  (let* ((normal-slots (call-next-method))
         (alist
          (mapcar
           #'(lambda (slot)
               (cons (sb-pcl:slot-definition-name slot)
                     (mapcar #'(lambda (attr) (cons attr nil))
                             (slot-definition-attributes slot))))
           normal-slots)))
    (cons (make-instance 'sb-pcl:standard-effective-slot-definition
                         :name 'all-attributes
                         :initform `',alist
                         :initfunction #'(lambda () alist))
          normal-slots)))

(defun slot-attribute (instance slot-name attribute)
  (cdr (slot-attribute-bucket instance slot-name attribute)))

(defun (setf slot-attribute) (new-value instance slot-name attribute)
  (setf (cdr (slot-attribute-bucket instance slot-name attribute))
        new-value))

(defun slot-attribute-bucket (instance slot-name attribute)
  (let* ((all-buckets (slot-value instance 'all-attributes))
         (slot-bucket (assoc slot-name all-buckets)))
    (unless slot-bucket
      (error "The slot named ~S of ~S has no attributes."
             slot-name instance))
    (let ((attr-bucket (assoc attribute (cdr slot-bucket))))
      (unless attr-bucket
        (error "The slot named ~S of ~S has no attribute named ~S."
             slot-name instance attribute))
      attr-bucket)))

(defclass credit-rating ()
  ((level :initform 1 :initarg :level :attributes (date-set time-set)))
  (:metaclass attributes-class))


(defparameter *credit-rating* (make-instance 'credit-rating))
(slot-value *credit-rating* 'all-attributes)
(slot-attribute *credit-rating* 'level 'date-set)
(setf (slot-attribute *credit-rating* 'level 'date-set) "12/15/90")
From: Ken Tilton
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <zjy1g.125$lA.44@fe10.lga>
mac wrote:
> So finally I get this working with sbcl. I'm still confused with the
> relationship between direct and effective slots and what does it buy
> for the user of MOP. I know there must be a reason but I haven't
> studied hard enough.

Join the club. I hate doc, so doing MOP was a bitch. Are you reading 
AMOP? On-line I think.

To answer your Q, do not forget that a slot named XXX can be listed in 
several defclasses in an inheritance tree. Each appearance produces a 
direct slot defintion (DSD) to make /that/ defclass happy. (Pardon the 
tech jargon.) Now you call make-instance on an actual class way down the 
inheritance tree and CLOS has to make a real live slot. So now it needs 
to take all the relevant DSDs and come up with a working (aka 
"effective") slot definition. ESD. compute-esd is your shot to customize 
  how DSDs get cooked into one ESD.

hth, ken
From: Juho Snellman
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <slrne4dfsd.ll9.jsnell@sbz-30.cs.Helsinki.FI>
mac <········@gmail.com> wrote:
> BTW, is there a way to link the symbols in sbcl core to the source code
> on my disk so that slime-edit-definition will jump to the source file?
> It's much better than using etags IMO.

Yes, that's controlled by the SYS logical pathname host
(http://www.sbcl.org/manual/Lisp-Pathnames.html). For example:

  (push '("SYS:SRC;**;*.*.*" #P"/path/to/the/source/src/**/*.*")
        (logical-pathname-translations "SYS"))
  (push '("SYS:CONTRIB;**;*.*.*" #P"/path/to/the/source/contrib/**/*.*")
        (logical-pathname-translations "SYS"))

Alternatively you can build SBCL from source, which should set the
default translations up correctly for your installation.

-- 
Juho Snellman
From: mac
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <1145511033.911209.89940@i39g2000cwa.googlegroups.com>
Hi Kenny and Juho,
Thanks for taking the time to answer my questions. I've had a very
productive day with lisp :-)
From: Pascal Costanza
Subject: Re: MOP custom defclass options
Date: 
Message-ID: <4aooafFu378oU1@individual.net>
mac wrote:

> Anyway, thanks for your help. I still have to factor the code so it
> works on all lisp implementions that I use (and at the same time brush
> up my MOP knowledge).

Writing portable MOP code isn't that easy because all implementations 
deviate in one way or the other. My Closer to MOP compatibility layer 
helps a little in that regard, so you may want to consider using it.


Pascal

-- 
3rd European Lisp Workshop
July 3-4 - Nantes, France - co-located with ECOOP 2006
http://lisp-ecoop06.bknr.net/
comp.lang.lisp / 2006 / apr