Re: MAKE-INSTANCE and STRUCTURE-CLASS
"David McClain (as dbm at refined-audiometrics dot com)" <[email protected]> Sun, 5 Jul 2026 08:45:37 -0700
| Newsgroups | gmane.lisp.lispworks.general,gmane.lisp.cl-pro |
|---|---|
| Message-ID | <[email protected]> |
--Apple-Mail=_5F3F1958-358A-49CE-96BE-257D9F4C6D89
Content-Transfer-Encoding: quoted-printable
Content-Type: text/plain;
charset=utf-8
(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))
> 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
--Apple-Mail=_5F3F1958-358A-49CE-96BE-257D9F4C6D89
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;"><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></body></html>=
--Apple-Mail=_5F3F1958-358A-49CE-96BE-257D9F4C6D89--
_______________________________________________
Lisp Hug - the mailing list for LispWorks users
[email protected]
http://www.lispworks.com/support/lisp-hug.html