Hello,
I try to extend the slot definition using metaclasses. I thought that
creating direct-slot-definition class with a corresponding make-
instance definition would do the trick, but the make-instance method
never gets called. Here is what I tried (behaves the same in sbcl and
clisp, where in clisp I used clos instead of sb-mop):
(defpackage clos-test
(:use common-lisp sb-mop))
(in-package :clos-test)
(defclass my-metaclass (standard-class)
())
(defmethod validate-superclass
((class my-metaclass) superclass)
t)
(defmethod make-instance ((class my-metaclass) &rest args)
(call-next-method class args))
(defmethod direct-slot-definition-class
((class my-metaclass) &rest args)
(find-class 'my-direct-slot-definition))
(defclass my-direct-slot-definition
(standard-direct-slot-definition)
((required :initform nil)
(property)))
(defmethod make-instance ((class my-direct-slot-definition) &rest
args)
(let (required (getf args :required))
(remf args :required)
(let ((slot-definition (call-next-method class args)))
(setf (slot-value slot-definition 'required) t)
slot-definition)))
(defclass my-class ()
((my-slot :initform "" :required t))
(:metaclass my-metaclass))
So can someone tell me, what I'm doing wrong? Thanks.
Regards,
Christian
Hi Christian,
I have an implementation of what I think you are trying
to achieve, although it needs some polishing to handle classes
redefinition and consider metaclass composition.
Maybe it's useful for you.
Cheers, Mariano
(defpackage #:required-slots
(:use :cl :sb-mop)
(:export #:required-slots-class))
(in-package :required-slots)
(defclass required-slots-object ()
()
(:documentation "We need this super class just to be able to
dispatch initialization methods for required slots checking"))
(defclass required-slots-class (standard-class)
((required-slots :initform '()
:accessor required-slots)))
(defclass required-slot-mixin ()
((required :initarg :required :initform nil :accessor required-slot-
p)
(error-msg :initarg :error-msg :accessor error-msg)))
(defmethod print-object ((slot-definition required-slot-mixin) stream)
(print-unreadable-object (slot-definition stream :type t :identity
t)
(format stream "name: ~A required: ~A"
(slot-definition-name slot-definition)
(required-slot-p slot-definition))))
(defmethod initialize-instance ((slot-definition required-slot-mixin)
&rest initargs)
"We set the default :error-msg string"
(call-next-method)
(when (not (getf initargs :error-msg))
(setf (error-msg slot-definition) (format nil "~A is
required" (slot-definition-name slot-definition)))))
(defclass required-direct-slot-definition (required-slot-mixin
standard-direct-slot-definition)
())
(defclass required-effective-slot-definition (required-slot-mixin
standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class required-slots-class)
&rest initargs)
(declare (ignore initargs))
(find-class 'required-direct-slot-definition))
(defmethod effective-slot-definition-class ((class required-slots-
class) &rest initargs)
(declare (ignore initargs))
(find-class 'required-effective-slot-definition))
(defmethod compute-effective-slot-definition ((class required-slots-
class) name direct-slots)
(let ((effective-slot (call-next-method)))
(setf (required-slot-p effective-slot)
(some #'required-slot-p direct-slots))
(setf (error-msg effective-slot)
(loop for direct-slot in direct-slots
when (error-msg direct-slot)
return (error-msg direct-slot)))
effective-slot))
(defmethod required-slot-p ((slot-definition slot-definition))
nil)
(defmethod error-msg ((slot-definition slot-definition))
nil)
;; The above code is not tested at all!!
;; Now, I would like to be able to combine several metaclasses
somehow.
;; example: (defclass getalt-model-class (required-slots-class
persistent-object-class))
;; But I don't think that will work so easily!!
;; required-slots-class test
(defmethod validate-superclass ((class required-slots-class)
(superclass standard-class))
t)
(defmethod shared-initialize :around ((class required-slots-class)
slot-names &rest args &key direct-superclasses)
"Ensures we inherit from require-slots-object"
(let* ((required-slots-metaclass (find-class 'required-slots-class))
(required-slots-class (find-class 'required-slots-object))
(not-already-required-slots
(loop for superclass in direct-superclasses
never (eq (class-of superclass) required-slots-
metaclass))))
(if (and (not (eq class required-slots-class)) not-already-
required-slots)
(apply #'call-next-method class slot-names
:direct-superclasses (append direct-superclasses (list
required-slots-class)) args)
(call-next-method))))
(defun make-keyword (name)
(values (intern (string-upcase name) "KEYWORD")))
(defmethod shared-initialize :after ((obj required-slots-object) slot-
names &rest initargs)
"Initialize the dataflow slots of the object"
(loop for slot-definition in (class-slots (class-of obj))
do
(when (and (required-slot-p slot-definition)
(not (getf initargs (make-keyword (slot-definition-name slot-
definition)))))
;; The slot is required but the user didn't pass an initarg
;; Trigger the error string
(error (error-msg slot-definition)))))
(defclass person ()
((name :initarg :name :required t)
(lastname :initarg :lastname :required t :error-msg "Please give me
a lastname!!")
(phone :initarg :phone :initform "" :required nil)
(address :initarg :address :initform ""))
(:metaclass required-slots-class)
(:documentation "The class definition to test required slots"))
(defmethod print-object ((person person) stream)
(print-unreadable-object (person stream :type t :identity t)
(format stream "name: ~A lastname: ~A phone: ~A address: ~A"
(slot-value person 'name)
(slot-value person 'lastname)
(slot-value person 'phone)
(slot-value person 'address))))
;; Examples (evaluate the following)
(make-instance 'person)
(make-instance 'person :name "Mariano")
(make-instance 'person :lastname "Montone")
(make-instance 'person :name "Mariano" :lastname "Montone")
(make-instance 'person :address "Mi casa")
;; Some other designs:
;; 1) If the user doesn't provide an initform, then the slot is
required. If he provides it, then it's not.
;; 2) Implement the error message as code in the :initform. We don't
need a required-slots-object class neither a shared-initialize on it.
;; 3) Investigate more about metaclass composition and class
redefinition and MOP
On 30 mayo, 06:14, Chriss <······@muon.de> wrote:
> Hello,
>
> I try to extend the slot definition using metaclasses. I thought that
> creating direct-slot-definition class with a corresponding make-
> instance definition would do the trick, but the make-instance method
> never gets called. Here is what I tried (behaves the same in sbcl and
> clisp, where in clisp I used clos instead of sb-mop):
>
> (defpackage clos-test
> (:use common-lisp sb-mop))
>
> (in-package :clos-test)
>
> (defclass my-metaclass (standard-class)
> ())
>
> (defmethod validate-superclass
> ((class my-metaclass) superclass)
> t)
>
> (defmethod make-instance ((class my-metaclass) &rest args)
> (call-next-method class args))
>
> (defmethod direct-slot-definition-class
> ((class my-metaclass) &rest args)
> (find-class 'my-direct-slot-definition))
>
> (defclass my-direct-slot-definition
> (standard-direct-slot-definition)
> ((required :initform nil)
> (property)))
>
> (defmethod make-instance ((class my-direct-slot-definition) &rest
> args)
> (let (required (getf args :required))
> (remf args :required)
> (let ((slot-definition (call-next-method class args)))
> (setf (slot-value slot-definition 'required) t)
> slot-definition)))
>
> (defclass my-class ()
> ((my-slot :initform "" :required t))
> (:metaclass my-metaclass))
>
> So can someone tell me, what I'm doing wrong? Thanks.
>
> Regards,
> Christian
On 30 May, 18:42, Mariano Montone <··············@gmail.com> wrote:
> Hi Christian,
> I have an implementation of what I think you are trying
> to achieve, although it needs some polishing to handle classes
> redefinition and consider metaclass composition.
>
> Maybe it's useful for you.
Thanks. But I cannot figure out how you get rid of the :required
property in the class definition before it gets passed down in make-
instance and will cause an error.
Regards,
Christian
On 31 mayo, 06:00, Chriss <······@muon.de> wrote:
> Thanks. But I cannot figure out how you get rid of the :required
> property in the class definition before it gets passed down in make-
> instance and will cause an error.
Have you tried my code?? Play a little with it.
I guess it has to do with plugging the correct slot type with the
following code:
(defmethod direct-slot-definition-class ((class required-slots-class)
&rest initargs)
(declare (ignore initargs))
(find-class 'required-direct-slot-definition))
(defmethod effective-slot-definition-class ((class required-slots-
class) &rest initargs)
(declare (ignore initargs))
(find-class 'required-effective-slot-definition))
I may be wrong though, as I'm not a MOP expert and don't have time
right now.
There was a tutorial on the MOP, but I can't find it. This may help,
though: http://cdr.eurolisp.org/document/1/spec.pdf
Cheers, Mariano
Hi
On 31 May, 15:55, Mariano Montone <··············@gmail.com> wrote:
> Have you tried my code?? Play a little with it.
Yes, I have. And I wondered why it worked, while mine did not. I found
the difference now and it is quite subtle: You intern the REQUIRED
into the KEYWORD package. I do not really understand why this helps,
but it does.
I added a working version of my test. The :REQUIRED in the slot
definition does nothing useful, but it does not signal an error (and
that was my goal for the experiment).
Thanks again for the help.
Regards,
Christian
(defpackage clos-test
(:use common-lisp clos))
(in-package :clos-test)
(intern "REQUIRED" :keyword)
(defclass my-metaclass (standard-class)
())
(defmethod validate-superclass
((class my-metaclass) superclass)
t)
(defclass my-slot-mixin ()
((required :initarg :required
:initform nil
:accessor required-slot-p)))
(defclass my-direct-slot-definition
(my-slot-mixin standard-direct-slot-definition)
())
(defclass my-effective-slot-definition
(my-slot-mixin standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class my-metaclass) &rest
args)
(declare (ignore args))
(find-class 'my-direct-slot-definition))
(defmethod effective-slot-definition-class ((class my-metaclass) &rest
args)
(declare (ignore args))
(find-class 'my-effective-slot-definition))
(defclass my-class ()
((my-slot :initform "" :required t))
(:metaclass my-metaclass))
Chriss <······@muon.de> writes:
> Hello,
>
> I try to extend the slot definition using metaclasses. I thought that
> creating direct-slot-definition class with a corresponding make-
> instance definition would do the trick, but the make-instance method
> never gets called. Here is what I tried (behaves the same in sbcl and
> clisp, where in clisp I used clos instead of sb-mop):
>
> (defpackage clos-test
> (:use common-lisp sb-mop))
>
> (in-package :clos-test)
>
> (defclass my-metaclass (standard-class)
> ())
>
> (defmethod validate-superclass
> ((class my-metaclass) superclass)
> t)
>
> (defmethod make-instance ((class my-metaclass) &rest args)
> (call-next-method class args))
>
> (defmethod direct-slot-definition-class
> ((class my-metaclass) &rest args)
> (find-class 'my-direct-slot-definition))
>
> (defclass my-direct-slot-definition
> (standard-direct-slot-definition)
> ((required :initform nil)
> (property)))
>
> (defmethod make-instance ((class my-direct-slot-definition) &rest
> args)
> (let (required (getf args :required))
You're defining a variable named required bound to NIL and a variable
named getf bound to args with a syntactic error at :required.
What do you expect?
> (remf args :required)
> (let ((slot-definition (call-next-method class args)))
> (setf (slot-value slot-definition 'required) t)
> slot-definition)))
> (defclass my-class ()
> ((my-slot :initform "" :required t))
> (:metaclass my-metaclass))
>
> So can someone tell me, what I'm doing wrong? Thanks.
>
> Regards,
> Christian
--
__Pascal Bourguignon__
On 30 May, 13:25, ····@informatimago.com (Pascal J. Bourguignon)
wrote:
> > (defmethod make-instance ((class my-direct-slot-definition) &rest
> > args)
> > (let (required (getf args :required))
>
> You're defining a variable named required bound to NIL and a variable
> named getf bound to args with a syntactic error at :required.
This generic function make-instance is not even invoked. So while the
definition might be wrong, it is not the real problem.
> What do you expect?
I expect that the method gets invoked at some stage when I call
(defclass my-class ()
((my-slot :initform "" :required t))
(:metaclass my-metaclass))
And I expect that required gets bound to t, because :required should
be in args.
But what I do get is an error (I forgot to write that in my previous
post):
---
Invalid initialization argument:
:REQUIRED
in call for class #<STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION>.
[Condition of type SB-PCL::INITARG-ERROR]
See also:
Common Lisp Hyperspec, 7.1.2 [:section]
Restarts:
0: [ABORT] Return to SLIME's top level.
1: [TERMINATE-THREAD] Terminate this thread (#<THREAD "worker"
RUNNING {BA227D1}>)
Backtrace:
0: (SB-PCL::CHECK-INITARGS-2-PLIST (:CLASS #<MY-METACLASS MY-
CLASS> :INITFUNCTION #<FUNCTION (LAMBDA NIL) {BA31085}> :NAME MY-
SLOT ...) #<STANDARD-CLASS STANDARD-DIRECT-SLOT-DEFINITION>
(:NAME :INITFORM :INITFUNCTION :READERS :WRITERS :INITARGS ...) T)
1: ((SB-PCL::FAST-METHOD MAKE-INSTANCE (CLASS)) #<unavailable
argument> #<unavailable argument> #<STANDARD-CLASS STANDARD-DIRECT-
SLOT-DEFINITION>)[:EXTERNAL]
---
Regards,
Christian