Re: MAKE-INSTANCE and STRUCTURE-CLASS
"David McClain (as dbm at refined-audiometrics dot com)" <[email protected]> Sun, 5 Jul 2026 08:46:33 -0700
| Newsgroups | gmane.lisp.lispworks.general,gmane.lisp.cl-pro |
|---|---|
| Message-ID | <[email protected]> |
--Apple-Mail=_1257F216-DEA8-4797-ACFA-431BAD1EC4C6
Content-Transfer-Encoding: quoted-printable
Content-Type: text/plain;
charset=utf-8
Nope=E2=80=A6.
(defun restore-type-object (obj-type metaclass data)
(destructuring-bind (class-name slot-names slot-values) data
(let* ((class (sdle-store::find-or-create-class class-name
obj-type
slot-names
metaclass))
(new-instance (allocate-instance class)))
(loop for slot-name in slot-names
for val in slot-values
do
(setf (slot-value new-instance slot-name) val))
new-instance)
))
> On Jul 5, 2026, at 08:45, David McClain <[email protected]> =
wrote:
>=20
> (defun restore-type-object (stream obj-type metaclass)
> ;; (declare (xoptimize speed))
> (let* ((class-name (restore-object stream))
> (count (read-count stream))
> (slot-names (loop repeat count
> collect (restore-object stream)))
> (class (find-or-create-class class-name obj-type =
slot-names metaclass))
> (new-instance (allocate-instance class)))
> =20
> (resolving-object (obj new-instance)
> (loop for slot-name in slot-names
> do
> ;; slot-names are always symbols so we don't
> ;; have to worry about circularities
> (let ((val (restore-object stream)))
> (when #+:LISPWORKS (clos:slot-exists-p new-instance =
slot-name)
> #-:LISPWORKS (slot-exists-p new-instance =
slot-name)
> (setting (slot-value obj slot-name) val))) ))
> new-instance))
>=20
>=20
>> On Jul 5, 2026, at 08:43, David McClain =
<[email protected]> wrote:
>>=20
>> (defun find-or-create-class (class-name obj-type slot-names =
metaclass)
>> (or (find-class class-name nil)
>> (ensure-class class-name
>> :direct-slots (mapcar (lambda (slot-name)
>> `(:name ,slot-name
>> :allocation :instance
>> :initargs nil
>> :readers nil
>> :type t
>> :writers nil))
>> slot-names)
>> :direct-superclasses (list obj-type)
>> ;; :metaclass 'standard-class
>> :metaclass metaclass
>> ) ))
>>=20
>>=20
>>> On Jul 5, 2026, at 08:42, David McClain =
<[email protected]> wrote:
>>>=20
>>> =E2=80=A6taken from my Serialization system:
>>>=20
>>> ;; --------------------------------------------
>>> ;; General Structs
>>>=20
>>> #+:LISPWORKS
>>> (defmethod make-serializable ((obj structure-object))
>>> (values :STRUCT
>>> (let* ((obj-class (class-of obj))
>>> (class-name (class-name obj-class))
>>> (slot-names (structure:structure-class-slot-names =
obj-class)))
>>> (list class-name
>>> slot-names
>>> (mapcar (um:curry #'slot-value obj) slot-names))
>>> )))
>>>=20
>>> #+:LISPWORKS
>>> (defmethod deserialize-type ((type (eql :STRUCT)) data)
>>> (destructuring-bind (class-name slot-names slot-values) data
>>> (let ((class (sdle-store::find-or-create-class class-name
>>> 'standard-object
>>> slot-names
>>> =
'standard-class)))
>>> (cond ((eq (type-of class) 'structure-class)
>>> ;; we apparently found the class and it was a struture
>>> (let* ((new-instance (structure::allocate-instance =
class))
>>> (allowed-slots =
(structure:structure-class-slot-names class)))
>>> (loop for slot-name in slot-names
>>> for val in slot-values
>>> do
>>> (let ((slot-sym (find slot-name allowed-slots
>>> :test #'string-equal)))
>>> (when slot-sym
>>> (setf (slot-value new-instance slot-sym) =
val)
>>> )))
>>> new-instance))
>>>=20
>>> (t ;; else -- no such struture known to mankind
>>> ;; dummy up as a new standard-object instead of a =
struct
>>> ;; (to avoid non-portability issues regarding =
internals of struct implementation)
>>> (let ((new-instance (allocate-instance class)))
>>> (loop for slot-name in slot-names
>>> for val in slot-values
>>> do
>>> (setf (slot-value new-instance slot-name) =
val))
>>> new-instance))
>>> ))))
>>>=20
>>> #+:SBCL
>>> (defmethod make-serializable ((obj structure-object))
>>> (values :STRUCT
>>> (gather-instance-data obj)))
>>>=20
>>> #+:SBCL
>>> (defmethod deserialize-type ((type (eql :STRUCT)) data)
>>> (restore-type-object 'structure-object 'structure-class data))
>>>=20
>>>=20
>>>=20
>>>=20
>>>=20
>>>> On Jul 5, 2026, at 05:23, Marco Antoniotti (as marco dot antoniotti =
at unimib dot it) <[email protected]> wrote:
>>>>=20
>>>> Hi
>>>>=20
>>>> I am sure this has come up a godzillion times before, but how do =
you write methods for MAKE-INSTANCE with structure classes?
>>>>=20
>>>> Just writing a method on the class name then hits a MISSING-METHOD =
on MAKE-INSTANCE and STRUCTURE-CLASS (at least on LW).
>>>>=20
>>>> Thanks
>>>>=20
>>>> MA
>>>>=20
>>>=20
>>=20
>=20
--Apple-Mail=_1257F216-DEA8-4797-ACFA-431BAD1EC4C6
Content-Transfer-Encoding: quoted-printable
Content-Type: text/html;
charset=utf-8
<html aria-label=3D"message body"><head><meta http-equiv=3D"content-type" =
content=3D"text/html; charset=3Dutf-8"></head><body =
style=3D"overflow-wrap: break-word; -webkit-nbsp-mode: space; =
line-break: after-white-space;">Nope=E2=80=A6.<div><br></div><div><div><fo=
nt face=3D"Monaco">(defun restore-type-object (obj-type metaclass =
data)</font></div><div><font face=3D"Monaco"> (destructuring-bind =
(class-name slot-names slot-values) data</font></div><div><font =
face=3D"Monaco"> (let* ((class =
(sdle-store::find-or-create-class =
class-name</font></div><div><font face=3D"Monaco"> =
=
=
obj-type</font></div><div><font =
face=3D"Monaco"> =
=
=
slot-names</font></div><div><font face=3D"Monaco"> =
=
=
metaclass))</font></div><div><font =
face=3D"Monaco"> (new-instance =
(allocate-instance class)))</font></div><div><font face=3D"Monaco"> =
(loop for slot-name in slot-names</font></div><div><font =
face=3D"Monaco"> for val in =
slot-values</font></div><div><font face=3D"Monaco"> =
do</font></div><div><font face=3D"Monaco"> =
(setf (slot-value new-instance =
slot-name) val))</font></div><div><font face=3D"Monaco"> =
new-instance)</font></div><div><font face=3D"Monaco"> =
))</font></div><div><br></div><div><br></div><div><br><blockquote =
type=3D"cite"><div>On Jul 5, 2026, at 08:45, David McClain =
<[email protected]> wrote:</div><br =
class=3D"Apple-interchange-newline"><div><meta http-equiv=3D"content-type"=
content=3D"text/html; charset=3Dutf-8"><div style=3D"overflow-wrap: =
break-word; -webkit-nbsp-mode: space; line-break: =
after-white-space;"><div><font face=3D"Monaco">(defun =
restore-type-object (stream obj-type metaclass)</font></div><div><font =
face=3D"Monaco"> ;; (declare (xoptimize =
speed))</font></div><div><font face=3D"Monaco"> (let* ((class-name =
(restore-object stream))</font></div><div><font =
face=3D"Monaco"> (count =
(read-count stream))</font></div><div><font =
face=3D"Monaco"> (slot-names =
(loop repeat count</font></div><div><font face=3D"Monaco"> =
=
collect (restore-object =
stream)))</font></div><div><font face=3D"Monaco"> =
(class (find-or-create-class =
class-name obj-type slot-names metaclass))</font></div><div><font =
face=3D"Monaco"> (new-instance =
(allocate-instance class)))</font></div><div><font face=3D"Monaco"> =
</font></div><div><font face=3D"Monaco"> =
(resolving-object (obj new-instance)</font></div><div><font =
face=3D"Monaco"> (loop for slot-name in =
slot-names</font></div><div><font face=3D"Monaco"> =
do</font></div><div><font face=3D"Monaco"> =
;; slot-names are always symbols so =
we don't</font></div><div><font face=3D"Monaco"> =
;; have to worry about =
circularities</font></div><div><font face=3D"Monaco"> =
(let ((val (restore-object =
stream)))</font></div><div><font face=3D"Monaco"> =
(when #+:LISPWORKS (clos:slot-exists-p =
new-instance slot-name)</font></div><div><font face=3D"Monaco"> =
=
#-:LISPWORKS (slot-exists-p new-instance =
slot-name)</font></div><div><font face=3D"Monaco"> =
(setting (slot-value obj slot-name) =
val))) ))</font></div><div><font face=3D"Monaco"> =
new-instance))</font></div><div><br></div><div><br><blockquote =
type=3D"cite"><div>On Jul 5, 2026, at 08:43, David McClain =
<[email protected]> wrote:</div><br =
class=3D"Apple-interchange-newline"><div><meta http-equiv=3D"content-type"=
content=3D"text/html; charset=3Dutf-8"><div style=3D"overflow-wrap: =
break-word; -webkit-nbsp-mode: space; line-break: =
after-white-space;"><div><font face=3D"Monaco">(defun =
find-or-create-class (class-name obj-type slot-names =
metaclass)</font></div><div><font face=3D"Monaco"> (or (find-class =
class-name nil)</font></div><div><font face=3D"Monaco"> =
(ensure-class class-name</font></div><div><font =
face=3D"Monaco"> =
:direct-slots (mapcar (lambda =
(slot-name)</font></div><div><font face=3D"Monaco"> =
=
`(:name =
,slot-name</font></div><div><font =
face=3D"Monaco"> =
=
:allocation =
:instance</font></div><div><font face=3D"Monaco"> =
=
=
:initargs nil</font></div><div><font face=3D"Monaco"> =
=
=
:readers nil</font></div><div><font =
face=3D"Monaco"> =
=
:type =
t</font></div><div><font face=3D"Monaco"> =
=
:writers =
nil))</font></div><div><font face=3D"Monaco"> =
=
=
slot-names)</font></div><div><font face=3D"Monaco"> =
:direct-superclasses =
(list obj-type)</font></div><div><font face=3D"Monaco"> =
;; :metaclass =
'standard-class</font></div><div><font face=3D"Monaco"> =
:metaclass =
metaclass</font></div><div><font face=3D"Monaco"> =
) =
))</font></div><div><br></div><div><br><blockquote type=3D"cite"><div>On =
Jul 5, 2026, at 08:42, David McClain =
<[email protected]> wrote:</div><br =
class=3D"Apple-interchange-newline"><div><meta http-equiv=3D"content-type"=
content=3D"text/html; charset=3Dutf-8"><div style=3D"overflow-wrap: =
break-word; -webkit-nbsp-mode: space; line-break: =
after-white-space;">=E2=80=A6taken from my Serialization =
system:<div><br></div><div><div>;; =
--------------------------------------------</div><div>;; General =
Structs</div><div><br></div><div><font =
face=3D"Monaco">#+:LISPWORKS</font></div><div><font =
face=3D"Monaco">(defmethod make-serializable ((obj =
structure-object))</font></div><div><font face=3D"Monaco"> (values =
:STRUCT</font></div><div><font face=3D"Monaco"> =
(let* ((obj-class (class-of =
obj))</font></div><div><font face=3D"Monaco"> =
(class-name (class-name =
obj-class))</font></div><div><font face=3D"Monaco"> =
(slot-names =
(structure:structure-class-slot-names =
obj-class)))</font></div><div><font face=3D"Monaco"> =
(list class-name</font></div><div><font =
face=3D"Monaco"> =
slot-names</font></div><div><font face=3D"Monaco"> =
(mapcar (um:curry =
#'slot-value obj) slot-names))</font></div><div><font =
face=3D"Monaco"> =
)))</font></div><div><font face=3D"Monaco"><br></font></div><div><font =
face=3D"Monaco">#+:LISPWORKS</font></div><div><font =
face=3D"Monaco">(defmethod deserialize-type ((type (eql :STRUCT)) =
data)</font></div><div><font face=3D"Monaco"> (destructuring-bind =
(class-name slot-names slot-values) data</font></div><div><font =
face=3D"Monaco"> (let ((class =
(sdle-store::find-or-create-class =
class-name</font></div><div><font face=3D"Monaco"> =
=
=
'standard-object</font></div><div><font =
face=3D"Monaco"> =
=
=
slot-names</font></div><div><font face=3D"Monaco"> =
=
=
'standard-class)))</font></div><div><font =
face=3D"Monaco"> (cond ((eq (type-of class) =
'structure-class)</font></div><div><font face=3D"Monaco"> =
;; we apparently found the class and =
it was a struture</font></div><div><font face=3D"Monaco"> =
(let* ((new-instance =
(structure::allocate-instance class))</font></div><div><font =
face=3D"Monaco"> =
(allowed-slots (structure:structure-class-slot-names =
class)))</font></div><div><font face=3D"Monaco"> =
(loop for slot-name in =
slot-names</font></div><div><font face=3D"Monaco"> =
for val =
in slot-values</font></div><div><font face=3D"Monaco"> =
=
do</font></div><div><font face=3D"Monaco"> =
(let =
((slot-sym (find slot-name allowed-slots</font></div><div><font =
face=3D"Monaco"> =
=
:test #'string-equal)))</font></div><div><font =
face=3D"Monaco"> =
(when slot-sym</font></div><div><font =
face=3D"Monaco"> =
(setf (slot-value new-instance =
slot-sym) val)</font></div><div><font face=3D"Monaco"> =
=
)))</font></div><div><font face=3D"Monaco"> =
=
new-instance))</font></div><div><font =
face=3D"Monaco"><br></font></div><div><font face=3D"Monaco"> =
(t ;; else -- no such struture known =
to mankind</font></div><div><font face=3D"Monaco"> =
;; dummy up as a new standard-object =
instead of a struct</font></div><div><font face=3D"Monaco"> =
;; (to avoid non-portability =
issues regarding internals of struct =
implementation)</font></div><div><font face=3D"Monaco"> =
(let ((new-instance =
(allocate-instance class)))</font></div><div><font face=3D"Monaco"> =
(loop for =
slot-name in slot-names</font></div><div><font face=3D"Monaco"> =
=
for val in slot-values</font></div><div><font =
face=3D"Monaco"> =
do</font></div><div><font =
face=3D"Monaco"> =
(setf (slot-value new-instance =
slot-name) val))</font></div><div><font face=3D"Monaco"> =
=
new-instance))</font></div><div><font face=3D"Monaco"> =
))))</font></div><div><font =
face=3D"Monaco"><br></font></div><div><div><font =
face=3D"Monaco">#+:SBCL</font></div><div><font face=3D"Monaco">(defmethod =
make-serializable ((obj structure-object))</font></div><div><font =
face=3D"Monaco"> (values :STRUCT</font></div><div><font =
face=3D"Monaco"> (gather-instance-data =
obj)))</font></div><div><font =
face=3D"Monaco"><br></font></div><div><div><font =
face=3D"Monaco">#+:SBCL</font></div><div><font face=3D"Monaco">(defmethod =
deserialize-type ((type (eql :STRUCT)) data)</font></div><div><font =
face=3D"Monaco"> (restore-type-object 'structure-object =
'structure-class data))</font></div><div><font =
face=3D"Monaco"><br></font></div></div><div><br></div><div><br></div></div=
><div><br></div><div><br><blockquote type=3D"cite"><div>On Jul 5, 2026, =
at 05:23, Marco Antoniotti (as marco dot antoniotti at unimib dot it) =
<[email protected]> wrote:</div><br =
class=3D"Apple-interchange-newline"><div><div =
dir=3D"ltr"><div>Hi</div><div><br></div><div>I am sure this has come up =
a godzillion times before, but how do you write methods for =
MAKE-INSTANCE with structure classes?</div><div><br></div><div>Just =
writing a method on the class name then hits a MISSING-METHOD on =
MAKE-INSTANCE and STRUCTURE-CLASS (at least on =
LW).</div><div><br></div><div>Thanks</div><div><br></div><div>MA</div><br>=
</div>
=
</div></blockquote></div><br></div></div></div></blockquote></div><br></di=
v></div></blockquote></div><br></div></div></blockquote></div><br></div></=
body></html>=
--Apple-Mail=_1257F216-DEA8-4797-ACFA-431BAD1EC4C6--
_______________________________________________
Lisp Hug - the mailing list for LispWorks users
[email protected]
http://www.lispworks.com/support/lisp-hug.html