Kinda sorta related to the defstruct thread...
Given:
(defclass cls ()
((this :initarg :this)
(that :initarg :that)
(dirty :initarg :dirty)))
(defmethod make-dirty ((o cls))
(setf (slot-value o 'dirty) T)
o)
(defmethod make-clean ((o cls))
(setf (slot-value o 'dirty) nil)
o)
(defmethod cls-this ((o cls))
(slot-value o 'this))
(defmethod set-cls-this ((o cls) v)
(setf (slot-value o 'this) v)
(make-dirty o))
(defsetf cls-this set-cls-this)
(defmethod cls-that ((o cls))
(slot-value o 'that))
(defmethod set-cls-that ((o cls) v)
(setf (slot-value o 'that) v)
(make-dirty o))
(defsetf cls-that set-cls-that)
Besides a custom macro, is this the best way to create a class that
gets dirty whenever its changed (besides the fact that I don't test for
an actual values change in my SET-* methods).
Any ways to leverage more off of DEFCLASS?
Should I be using (defmethod (setf cls-that) ...) instead? How does
that differ from my (defsetf ...)?
Or should I just:
(defclass cls ()
(this :accessor this)...)
and redefine the SETF functions?
Finally, what kind of land mines am I laying in my path?
Thanx!
--
Will Hartung - Rancho Santa Margarita. It's a dry heat. ······@netcom.com
1990 VFR750 - VFR=Very Red "Ho, HaHa, Dodge, Parry, Spin, HA! THRUST!"
1993 Explorer - Cage? Hell, it's a prison. -D. Duck
In article <················@netcom.com>,
Will Hartung <······@netcom.com> wrote:
>Besides a custom macro, is this the best way to create a class that
>gets dirty whenever its changed (besides the fact that I don't test for
>an actual values change in my SET-* methods).
I would make use of the built-in accessor methods, and then define
:BEFORE or :AFTER methods for (setf this) and (setf that) that update the
DIRTY slot.
--
Barry Margolin, ······@bbnplanet.com
GTE Internetworking, Powered by BBN, Cambridge, MA
*** DON'T SEND TECHNICAL QUESTIONS DIRECTLY TO ME, post them to newsgroups.
Barry Margolin <······@bbnplanet.com> writes:
> In article <················@netcom.com>,
> Will Hartung <······@netcom.com> wrote:
> >Besides a custom macro, is this the best way to create a class that
> >gets dirty whenever its changed (besides the fact that I don't test for
> >an actual values change in my SET-* methods).
>
> I would make use of the built-in accessor methods, and then define
> :BEFORE or :AFTER methods for (setf this) and (setf that) that update the
> DIRTY slot.
I concur with Barry. I often make a DEFINE-CLASS macro to automate
such things, allowing me to specify additional slot options. It then
expands into DEFCLASS + maybe some generated DEFMETHODs. Doing it by
hand really risks errors creeping in if you get lazy/sloppy.
From: Laurence Kramer
Subject: Re: Better way to do this?
Date:
Message-ID: <3524EDD2.4375@stsci.edu>
Kent M Pitman wrote:
>
> Barry Margolin <······@bbnplanet.com> writes:
>
> > In article <················@netcom.com>,
> > Will Hartung <······@netcom.com> wrote:
> > >Besides a custom macro, is this the best way to create a class that
> > >gets dirty whenever its changed (besides the fact that I don't test for
> > >an actual values change in my SET-* methods).
> >
> > I would make use of the built-in accessor methods, and then define
> > :BEFORE or :AFTER methods for (setf this) and (setf that) that update the
> > DIRTY slot.
>
> I concur with Barry. I often make a DEFINE-CLASS macro to automate
> such things, allowing me to specify additional slot options. It then
> expands into DEFCLASS + maybe some generated DEFMETHODs. Doing it by
> hand really risks errors creeping in if you get lazy/sloppy.
If this behavior is pervasive throughout a large system of classes
and slots, a more elegant method than Kent's "define-class" macro
would be to use the MetaObject Protocol to redefine slot access
so that your "dirty" flag is set automatically for any class and
slot augmented by the MOP. In essence you'd be redefining slot-value
to "report" that it's dirtying up a class.
Larry
Laurence Kramer <······@stsci.edu> writes:
> If this behavior is pervasive throughout a large system of classes
> and slots, a more elegant method than Kent's "define-class" macro
> would be to use the MetaObject Protocol to redefine slot access
> so that your "dirty" flag is set automatically for any class and
> slot augmented by the MOP. In essence you'd be redefining slot-value
> to "report" that it's dirtying up a class.
Well, assuming you don't want to port your system.
Many systems these days seem to have A MOP.
I'll start using MOP features when there's only THE MOP. :-)
Harlequin's Lisp has a MOP, so do many others. But each such system
differs in various ways. The AMOP book (appropriately acronym'd, even
if it doesn't stand for what my joke above implies) is written as if
it were a standard--and it would be nice if it were. But it's not. So
as a rule, I don't suggest using MOP features except where no other
more portable mechanism suffices (which is darned rare)...
Still, you're right to mention it as an option for those who have
the "luxury" of using it...
* Kent M Pitman wrote:
> Harlequin's Lisp has a MOP, so do many others. But each such system
> differs in various ways. The AMOP book (appropriately acronym'd, even
> if it doesn't stand for what my joke above implies) is written as if
> it were a standard--and it would be nice if it were. But it's not. So
> as a rule, I don't suggest using MOP features except where no other
> more portable mechanism suffices (which is darned rare)...
Can anyone who has understood and used the MOP described in AMOP
confirm my impression that it has a number of horrid problems? Apart
from a couple of tiny bugs I've always been very disturbed that
things like SLOT-VALUE end up calling SLOT-VALUE-USING-CLASS, and
there seem not to be enough restrictions on that to allow
implementations to not do any of this but compile SLOT-VALUE as
(inline) AREF or something when enough is known about the classes.
Or perhaps I just haven't read it hard enough.
--tim
> Can anyone who has understood and used the MOP described in AMOP
> confirm my impression that it has a number of horrid problems? Apart
Yes, it has a number of horrid problems, the most glaring is
the total performance loss (order of magnitude)
making it useful primarily for university research and not production
code applications.
But also you have infinite recursion. Given the example posted here
from Sunil:
(defmethod (setf slot-value-using-class) :after
(new-value (class standard-class) (object cls)
(slot standard-effective-slot-definition))
(declare (ignore new-value))
(setf (cls-dirty-p object) t))
The (setf (cls-dirty-p object) t) will infinitely and recursively invoke
this :after method!
99.9% of all code doesn't need and should use the MOP.
NOTE: there is the "Introspective MOP", which is a different animal,
this the specification that provides an API for getting at the internals,
but NOT allowing changing how they work.
For example, to find out the name of all the slots in a class
is an IMOP function.
-Kelly Murray ···@franz.com
In article <············@news2.franz.com> ···@math.ufl.edu (Kelly Murray) writes:
> Can anyone who has understood and used the MOP described in AMOP
> confirm my impression that it has a number of horrid problems? Apart
Yes, it has a number of horrid problems, the most glaring is
the total performance loss (order of magnitude)
making it useful primarily for university research and not production
code applications.
But also you have infinite recursion. Given the example posted here
from Sunil:
(defmethod (setf slot-value-using-class) :after
(new-value (class standard-class) (object cls)
(slot standard-effective-slot-definition))
(declare (ignore new-value))
(setf (cls-dirty-p object) t))
The (setf (cls-dirty-p object) t) will infinitely and recursively invoke
this :after method!
Oopsie! Didn't notice that recursion :-)
(I can think of a fix, but that's not the point right now.)
It's odd that you pick on performance loss. A big claim of the AMOP authors
was that having a MOP would allow the programmers to make customizations to
CLOS in a way that would help performance.
The point that I *think* you are trying to make is this: structs are far
more efficient than CLOS, but are far more limited in flexibility. This is
I think similar to the advantage that a MOP can give over vanilla
CLOS. However, a MOP requires CLOS to behave in a way that is inherently
less efficient. To give a programmer even the option to use a MOP is to
cause CLOS to become significantly less efficient. Is this right? I don't
know enough about CLOS or Lisp compilers to decide if this has to be the
case.
I doubt there is any way to have CLOS remain as efficient, and at the same
time introduce a MOP. There are some problems that beg for a MOP,
though. There are enough examples in AMOP that illustrate this. I'm at a
loss though as to how one might reconcile the need for a MOP with the
baggage they bring along.
Sunil
In article <···············@peachtree.cc.gatech.edu>, ·······@peachtree.cc.gatech.edu (Sunil Mishra) writes:
>> In article <············@news2.franz.com> ···@franz.com (Kelly Murray) writes:
>> > Can anyone who has understood and used the MOP described in AMOP
>> > confirm my impression that it has a number of horrid problems? Apart
>> Yes, it has a number of horrid problems, the most glaring is
>> the total performance loss (order of magnitude)
>>
>> It's odd that you pick on performance loss. A big claim of the AMOP authors
>> was that having a MOP would allow the programmers to make customizations to
>> CLOS in a way that would help performance.
What is odd is that the authors make this claim.
>>
>> The point that I *think* you are trying to make is this: structs are far
>> more efficient than CLOS, but are far more limited in flexibility. This is
>> I think similar to the advantage that a MOP can give over vanilla
>> CLOS. However, a MOP requires CLOS to behave in a way that is inherently
>> less efficient. To give a programmer even the option to use a MOP is to
>> cause CLOS to become significantly less efficient. Is this right? I don't
>> know enough about CLOS or Lisp compilers to decide if this has to be the
>> case.
Whenever pressed on the issue of speed, the CLOS designers always
replied "just use defstruct." Defstruct should be
buried as historical baggage.
Dylan was a good attempt to correct some of the design flaws of CLOS,
"primary classes", "class sealing", etc.
>>
>> I doubt there is any way to have CLOS remain as efficient, and at the same
>> time introduce a MOP. There are some problems that beg for a MOP,
>> though. There are enough examples in AMOP that illustrate this. I'm at a
>> loss though as to how one might reconcile the need for a MOP with the
>> baggage they bring along.
>>
>> Sunil
I haven't seen MOP examples that are compelling.
There is a loss of efficiency because the MOP may be used. Basically,
the MOP specifies an implementation of CLOS, so if someone finds a better,
more efficient way to implement CLOS, they couldn't use it unless it
conformed to the MOP as well. This is not good.
But if performance when using the MOP itself is very bad,
as it is today, then what is the point of having to support it?
-Kelly Murray
From: David Fox
Subject: Re: AMOP (was Re: Better way to do this?)
Date:
Message-ID: <y5aiuoje2lh.fsf@dsf.net>
···@franz.com writes:
> >> I doubt there is any way to have CLOS remain as efficient, and at the same
> >> time introduce a MOP. There are some problems that beg for a MOP,
> >> though. There are enough examples in AMOP that illustrate this. I'm at a
> >> loss though as to how one might reconcile the need for a MOP with the
> >> baggage they bring along.
> >>
> >> Sunil
>
> I haven't seen MOP examples that are compelling.
My most compelling use for a MOP is to implement delegation. I need
to create objects which are ``wrappers'' around existing instances:
they inherit all the slots of the existing instances and are
themselves instances of a subclass of the original object's class.
Think of passing a magic lens over some objects and seeing modified
and enhanced versions of those objects. The original objects I called
delegates, and the new objects I call principals (because they
delegate operations and slot references.)
I implement this by creating a subclass of <class> called <principal>
and (among other things) overriding apply-generic so that it uses a
class precedence list consisting of the CPL of the delegate objects's
actual class with the principal class appended. This has to be done
when the generic function is applied, because the delegate object
might be a subclass of the actual class the principal object expects
to be extending. There, clear as mud...
--
David Fox http://www.cat.nyu.edu/fox xoF divaD
NYU Media Research Lab ···@cat.nyu.edu baL hcraeseR aideM UYN
In article <···············@dsf.net>, f o x @ c a t . n y u . e d u (David Fox) writes:
>> ···@franz.com writes:
>>
>> > >> I doubt there is any way to have CLOS remain as efficient, and at the same
>> > >> time introduce a MOP. There are some problems that beg for a MOP,
>> > >> though. There are enough examples in AMOP that illustrate this. I'm at a
>> > >> loss though as to how one might reconcile the need for a MOP with the
>> > >> baggage they bring along.
>> > >>
>> > >> Sunil
>> >
>> > I haven't seen MOP examples that are compelling.
>>
>> My most compelling use for a MOP is to implement delegation. I need
>> to create objects which are ``wrappers'' around existing instances:
>> they inherit all the slots of the existing instances and are
>> themselves instances of a subclass of the original object's class.
>> Think of passing a magic lens over some objects and seeing modified
>> and enhanced versions of those objects. The original objects I called
>> delegates, and the new objects I call principals (because they
>> delegate operations and slot references.)
>>
>> I implement this by creating a subclass of <class> called <principal>
>> and (among other things) overriding apply-generic so that it uses a
>> class precedence list consisting of the CPL of the delegate objects's
>> actual class with the principal class appended. This has to be done
>> when the generic function is applied, because the delegate object
>> might be a subclass of the actual class the principal object expects
>> to be extending. There, clear as mud...
Sounds like academic research. I agree the MOP can be useful in this domain.
If I could understand what you're trying to do, I could probably show
you how to implement it without the MOP.
But in any case, why not just give you the source code for
a CLOS implementation, and then you can modify it to your hearts content
without actually changing the system's implementation?
Load the clos implementation in the FOXCLOS package, and have fun.
Then it doesn't constrain the system's implementation.
BTW, I am reminded of a talk I gave entitled "Hour Objects", in which
I described an object system. People thought I mispelled "Our",
but at the end of the talk (which some thought I was describing my research)
I disclosed that this object system took me 1-hour to implement
using Lisp, for the sole purpose of presenting it in the talk.
The point being: Lisp is very powerful and can easily create new object systems.
And I didn't use a MOP.
Understanding how to use CLOS itself is hard enough,
but by changing how it is working, it will be hopeless for someone else
to understand what your source code is actually doing.
Lisp macros have a similiar issue, but at least with macros you have a chance to
get a handle on it, by macroexpanding the code.
-Kelly Murray
-Kelly Murray
······@netcom.com (Will Hartung) writes:
> Kinda sorta related to the defstruct thread...
...
>
> Besides a custom macro, is this the best way to create a class that
> gets dirty whenever its changed (besides the fact that I don't test for
> an actual values change in my SET-* methods).
>
> Any ways to leverage more off of DEFCLASS?
>
> Should I be using (defmethod (setf cls-that) ...) instead? How does
> that differ from my (defsetf ...)?
>
> Or should I just:
>
> (defclass cls ()
> (this :accessor this)...)
>
> and redefine the SETF functions?
>
Not quite
(defclass cls ()
((this :accessor cls-this)
(thas :accessor cls-that)
(dirty-p :accessor cls-dirty-p :initform nil :type (member t nil))))
(defmethod (setf cls-this) :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
(defmethod (setf cls-that) :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
(defmethod clean ((o cls))
(setf (cls-dirty-p o) nil))
Will do what you want, without using SLOT-VALUE and in a cleaner way.
Of course you can separate the reader and the writer of the slots.
(defclass cls ()
((this :reader cls-this :writer set-cls-this)
(thas :reader cls-that :writer set-cls-that)
(dirty-p :accessor cls-dirty-p :initform nil :type (member t nil))))
(defmethod set-cls-that :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
etc...
--
Marco Antoniotti ===========================================
PARADES, Via San Pantaleo 66, I-00186 Rome, ITALY
tel. +39 - (0)6 - 68 80 79 23, fax. +39 - (0)6 - 68 80 79 26
http://www.parades.rm.cnr.it
In article <··············@galvani.parades.rm.cnr.it> Marco Antoniotti <·······@galvani.parades.rm.cnr.it> writes:
······@netcom.com (Will Hartung) writes:
> Kinda sorta related to the defstruct thread...
...
>
> Besides a custom macro, is this the best way to create a class that
> gets dirty whenever its changed (besides the fact that I don't test for
> an actual values change in my SET-* methods).
>
> Any ways to leverage more off of DEFCLASS?
>
> Should I be using (defmethod (setf cls-that) ...) instead? How does
> that differ from my (defsetf ...)?
>
> Or should I just:
>
> (defclass cls ()
> (this :accessor this)...)
>
> and redefine the SETF functions?
>
Not quite
(defclass cls ()
((this :accessor cls-this)
(thas :accessor cls-that)
(dirty-p :accessor cls-dirty-p :initform nil :type (member t nil))))
(defmethod (setf cls-this) :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
(defmethod (setf cls-that) :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
(defmethod clean ((o cls))
(setf (cls-dirty-p o) nil))
Will do what you want, without using SLOT-VALUE and in a cleaner way.
Of course you can separate the reader and the writer of the slots.
(defclass cls ()
((this :reader cls-this :writer set-cls-this)
(thas :reader cls-that :writer set-cls-that)
(dirty-p :accessor cls-dirty-p :initform nil :type (member t nil))))
(defmethod set-cls-that :after (value (o cls))
(declare (ignore value))
(setf (cls-dirty-p o) t))
etc...
Another thing that must be asked... Why are you trying to do this?
Do you want to do this for only a few slots in the class, or for every
slot? If you want to do this for only a few slots, or only one class, then
:after methods will do great, and ignore the rest of this message. If not,
you will probably have a huge number of methods floating around simply to
make the object dirty, and there would be better ways to do this.
The first step would be to find out if your implementation supports
metaobjects. (If not, ignore the rest.) Then, get your hands on a copy of
art of metaobject protocol. Upon reading it you should be able to write for
yourself a method something like the one below:
(defmethod (setf slot-value-using-class) :after
(new-value (class standard-class) (object cls)
(slot standard-effective-slot-definition))
(declare (ignore new-value))
(setf (cls-dirty-p object) t))
This will set dirty if you change any slot in the object. Or you could make
the above an :around method, and ensure the value is indeed changing. If
you want more control, you could even specialize
standard-effective-slot-definition or standard-class.
Sunil
* Sunil Mishra
| ... :type (member t nil) ...
probably a stupid question, but why (MEMBER T NIL) instead of BOOLEAN?
#:Erik
--
religious cult update in light of new scientific discoveries:
"when we cannot go to the comet, the comet must come to us."
Marco Antoniotti wrote:
> CMUCL idiosyncrasy.
>
> (typep nil 'boolean)
>
> generates an error. This is one for cmucl-bugs.
Types in CMU CL have a number of bugs. Here's
a subset of some test cases I've written for CL standards
compliance (see the CL Hyperspec). I've only written,
so far, test cases for symbols, cons, and some of types and
sequences. I'll put the whole thing on a server
at some point for general use.
The test cases use the Waters RT regression test
system.
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Thu Mar 19 21:48:39 1998
;;;; Contains: Data for testing type and class inclusions
;; We should check for every type that NIL is a subtype, and T a
supertype
;; (in-package :cl-test)
(use-package :rt)
(declaim (optimize (safety 3)))
(deftest types-1
(handler-case
(typep nil 'boolean)
(error (c) c))
t)
(deftest types-2
(handler-case
(typep t 'boolean)
(error (c) c))
t)
(defvar *subtype-table*
'(
(symbol t)
(boolean symbol)
(standard-object t)
(function t)
(compiled-function function)
(generic-function function)
(standard-generic-function generic-function)
(class standard-object)
(built-in-class class)
(structure-class class)
(standard-class class)
(method standard-object)
(standard-method method)
(structure-object t)
(method-combination t)
(condition t)
(serious-condition condition)
(error serious-condition)
(type-error error)
(simple-type-error type-error)
(simple-condition condition)
(simple-type-error simple-condition)
(parse-error error)
(hash-table t)
(cell-error error)
(unbound-slot cell-error)
(warning condition)
(style-warning warning)
(storage-condition serious-condition)
(simple-warning warning)
(simple-warning simple-condition)
(keyword symbol)
(unbound-variable cell-error)
(control-error error)
(program-error error)
(undefined-function cell-error)
(package t)
(package-error error)
(random-state t)
(number t)
(real number)
(complex number)
(float real)
(short-float float)
(single-float float)
(double-float float)
(long-float float)
(rational real)
(integer rational)
(ratio rational)
(signed-byte integer)
(integer signed-byte)
(unsigned-byte signed-byte)
(bit unsigned-byte)
(fixnum integer)
(bignum integer)
(bit fixnum)
(arithmetic-error error)
(division-by-zero arithmetic-error)
(floating-point-invalid-operation arithmetic-error)
(floating-point-inexact arithmetic-error)
(floating-point-overflow arithmetic-error)
(floating-point-underflow arithmetic-error)
(character t)
(base-char character)
(standard-char base-char)
(extended-char character)
(sequence t)
(list sequence)
(null list)
(null boolean)
(cons list)
(array t)
(simple-array array)
(vector sequence)
(vector array)
(string vector)
(bit-vector vector)
(simple-vector vector)
(simple-vector simple-array)
(simple-bit-vector bit-vector)
(simple-bit-vector simple-array)
(base-string string)
(simple-string string)
(simple-string simple-array)
(simple-base-string base-string)
(simple-base-string simple-string)
(pathname t)
(logical-pathname pathname)
(file-error error)
(stream t)
(broadcast-stream stream)
(concatenated-stream stream)
(echo-stream stream)
(file-stream stream)
(string-stream stream)
(synonym-stream stream)
(two-way-stream stream)
(stream-error error)
(end-of-file stream-error)
(print-not-readable error)
(readtable t)
(reader-error parse-error)
(reader-error stream-error)
))
(deftest types-3
(count-if
#'(lambda (pair)
(let ((t1 (first pair))
(t2 (second pair)))
(cond
((not (subtypep t1 t2))
(format t "~%~A not a subtype of ~A" t1 t2)
t)
(t nil))))
*subtype-table*)
0)
(defconstant +float-types+ '(long-float double-float short-float
single-float))
(defun types-4-body ()
(let ((parent-table (make-hash-table :test #'equal))
(types nil))
(loop
for p in *subtype-table* do
(let ((tp (first p))
(parent (second p)))
(pushnew tp types)
(pushnew parent types)
(let ((parents (gethash tp parent-table)))
(pushnew parent parents)
;; (format t "~A ==> ~A~%" tp parent)
(loop
for pp in (gethash parent parent-table) do
;; (format t "~A ==> ~A~%" tp pp)
(pushnew pp parents))
(setf (gethash tp parent-table) parents))))
;; parent-table now contains lists of ancestors
(loop
for tp in types sum
(let ((parents (gethash tp parent-table)))
(loop
for tp2 in types sum
(cond
((and (not (eq tp tp2))
(not (eq tp2 'standard-object))
(not (eq tp2 'structure-object))
(not (member tp2 parents))
(subtypep tp tp2)
(not (and (member tp +float-types+)
(member tp2 +float-types+)))
(not (and (eq tp2 'structure-object)
(member 'standard-object parents))))
(format t "~%Improper subtype: ~A of ~A"
tp tp2)
1)
(t 0)))))
))
(deftest types-4
(types-4-body)
0)
(deftest types-5
(subtypep 'simple-base-string 'sequence)
t t)
(defun types-6-body ()
(loop
for p in *subtype-table* count
(let ((tp (car p)))
(cond
((and (not (member tp '(sequence cons list t)))
(not (subtypep tp 'atom)))
(format t "~%Not an atomic type: ~A" tp)
t)))))
(deftest types-6
(types-6-body)
0)
(defvar *disjoint-types-list*
'(cons symbol array
number character hash-table function readtable package
pathname stream random-state condition restart))
(deftest types-7
(loop
for tp in *disjoint-types-list* sum
(loop for tp2 in *disjoint-types-list* count
(and (not (eq tp tp2))
(subtypep tp tp2))))
0)
(deftest types-8
(loop
for tp in *disjoint-types-list* count
(cond
((and (not (eq tp 'cons))
(not (subtypep tp 'atom)))
(format t "~%Not atomic: ~A" tp)
t)))
0)
(defun types-9-body ()
(let ((tp-list (append '(keyword atom list)
(loop for p in *subtype-table* collect (car p))))
(result-list))
(setf tp-list (remove-duplicates tp-list))
(let ((subs (make-hash-table :test #'eq))
(sups (make-hash-table :test #'eq)))
(loop
for x in tp-list do
(loop
for y in tp-list do
(multiple-value-bind (result good)
(subtypep x y)
(declare (ignore good))
(when result
(pushnew x (gethash y subs))
(pushnew y (gethash x sups))))))
(loop
for x in tp-list do
(let ((sub-list (gethash x subs))
(sup-list (gethash x sups)))
(loop
for t1 in sub-list do
(loop
for t2 in sup-list do
(multiple-value-bind (result good)
(subtypep t1 t2)
(when (and good (not result))
(pushnew (list t1 x t2) result-list
:test #'equal)))))))
result-list)))
(deftest types-9
(types-9-body)
nil)
---------------------------
Here's the result on CMU CL 17f (Linux):
* (do-tests)
Doing 9 pending tests of 9 tests total.
Test TYPES-1 failed
Form: (HANDLER-CASE (TYPEP NIL 'BOOLEAN) (ERROR (C) C))
Expected value: T
Actual value: #<SIMPLE-ERROR {911E80D}>.
Test TYPES-2 failed
Form: (HANDLER-CASE (TYPEP T 'BOOLEAN) (ERROR (C) C))
Expected value: T
Actual value: #<SIMPLE-ERROR {9129EFD}>.
BOOLEAN not a subtype of SYMBOL
CLASS not a subtype of STANDARD-OBJECT
UNBOUND-SLOT not a subtype of CELL-ERROR
KEYWORD not a subtype of SYMBOL
RATIO not a subtype of RATIONAL
BIGNUM not a subtype of INTEGER
NULL not a subtype of BOOLEAN
READER-ERROR not a subtype of PARSE-ERROR
Test TYPES-3 failed
Form: (COUNT-IF
#'(LAMBDA (PAIR)
(LET ((T1 (FIRST PAIR)) (T2 (SECOND PAIR)))
(COND
((NOT (SUBTYPEP T1 T2))
(FORMAT T "~%~A not a subtype of ~A" T1 T2) T)
(T NIL))))
*SUBTYPE-TABLE*)
Expected value: 0
Actual value: 8.
Improper subtype: READER-ERROR of SIMPLE-CONDITION
Improper subtype: ECHO-STREAM of TWO-WAY-STREAM
Improper subtype: SIMPLE-STRING of SIMPLE-BASE-STRING
Improper subtype: SIMPLE-STRING of BASE-STRING
Improper subtype: STRING of BASE-STRING
Improper subtype: EXTENDED-CHAR of READER-ERROR
Improper subtype: EXTENDED-CHAR of READTABLE
Improper subtype: EXTENDED-CHAR of PRINT-NOT-READABLE
Improper subtype: EXTENDED-CHAR of END-OF-FILE
Improper subtype: EXTENDED-CHAR of STREAM-ERROR
Improper subtype: EXTENDED-CHAR of TWO-WAY-STREAM
Improper subtype: EXTENDED-CHAR of SYNONYM-STREAM
Improper subtype: EXTENDED-CHAR of STRING-STREAM
Improper subtype: EXTENDED-CHAR of FILE-STREAM
Improper subtype: EXTENDED-CHAR of ECHO-STREAM
Improper subtype: EXTENDED-CHAR of CONCATENATED-STREAM
Improper subtype: EXTENDED-CHAR of BROADCAST-STREAM
Improper subtype: EXTENDED-CHAR of STREAM
Improper subtype: EXTENDED-CHAR of FILE-ERROR
Improper subtype: EXTENDED-CHAR of LOGICAL-PATHNAME
Improper subtype: EXTENDED-CHAR of PATHNAME
Improper subtype: EXTENDED-CHAR of SIMPLE-BASE-STRING
Improper subtype: EXTENDED-CHAR of SIMPLE-STRING
Improper subtype: EXTENDED-CHAR of BASE-STRING
Improper subtype: EXTENDED-CHAR of SIMPLE-BIT-VECTOR
Improper subtype: EXTENDED-CHAR of SIMPLE-VECTOR
Improper subtype: EXTENDED-CHAR of BIT-VECTOR
Improper subtype: EXTENDED-CHAR of STRING
Improper subtype: EXTENDED-CHAR of VECTOR
Improper subtype: EXTENDED-CHAR of SIMPLE-ARRAY
Improper subtype: EXTENDED-CHAR of ARRAY
Improper subtype: EXTENDED-CHAR of CONS
Improper subtype: EXTENDED-CHAR of NULL
Improper subtype: EXTENDED-CHAR of LIST
Improper subtype: EXTENDED-CHAR of SEQUENCE
Improper subtype: EXTENDED-CHAR of STANDARD-CHAR
Improper subtype: EXTENDED-CHAR of BASE-CHAR
Improper subtype: EXTENDED-CHAR of FLOATING-POINT-UNDERFLOW
Improper subtype: EXTENDED-CHAR of FLOATING-POINT-OVERFLOW
Improper subtype: EXTENDED-CHAR of FLOATING-POINT-INEXACT
Improper subtype: EXTENDED-CHAR of FLOATING-POINT-INVALID-OPERATION
Improper subtype: EXTENDED-CHAR of DIVISION-BY-ZERO
Improper subtype: EXTENDED-CHAR of ARITHMETIC-ERROR
Improper subtype: EXTENDED-CHAR of BIGNUM
Improper subtype: EXTENDED-CHAR of FIXNUM
Improper subtype: EXTENDED-CHAR of BIT
Improper subtype: EXTENDED-CHAR of UNSIGNED-BYTE
Improper subtype: EXTENDED-CHAR of SIGNED-BYTE
Improper subtype: EXTENDED-CHAR of RATIO
Improper subtype: EXTENDED-CHAR of INTEGER
Improper subtype: EXTENDED-CHAR of RATIONAL
Improper subtype: EXTENDED-CHAR of LONG-FLOAT
Improper subtype: EXTENDED-CHAR of DOUBLE-FLOAT
Improper subtype: EXTENDED-CHAR of SINGLE-FLOAT
Improper subtype: EXTENDED-CHAR of SHORT-FLOAT
Improper subtype: EXTENDED-CHAR of FLOAT
Improper subtype: EXTENDED-CHAR of COMPLEX
Improper subtype: EXTENDED-CHAR of REAL
Improper subtype: EXTENDED-CHAR of NUMBER
Improper subtype: EXTENDED-CHAR of RANDOM-STATE
Improper subtype: EXTENDED-CHAR of PACKAGE-ERROR
Improper subtype: EXTENDED-CHAR of PACKAGE
Improper subtype: EXTENDED-CHAR of UNDEFINED-FUNCTION
Improper subtype: EXTENDED-CHAR of PROGRAM-ERROR
Improper subtype: EXTENDED-CHAR of CONTROL-ERROR
Improper subtype: EXTENDED-CHAR of UNBOUND-VARIABLE
Improper subtype: EXTENDED-CHAR of KEYWORD
Improper subtype: EXTENDED-CHAR of SIMPLE-WARNING
Improper subtype: EXTENDED-CHAR of STORAGE-CONDITION
Improper subtype: EXTENDED-CHAR of STYLE-WARNING
Improper subtype: EXTENDED-CHAR of WARNING
Improper subtype: EXTENDED-CHAR of UNBOUND-SLOT
Improper subtype: EXTENDED-CHAR of CELL-ERROR
Improper subtype: EXTENDED-CHAR of HASH-TABLE
Improper subtype: EXTENDED-CHAR of PARSE-ERROR
Improper subtype: EXTENDED-CHAR of SIMPLE-CONDITION
Improper subtype: EXTENDED-CHAR of SIMPLE-TYPE-ERROR
Improper subtype: EXTENDED-CHAR of TYPE-ERROR
Improper subtype: EXTENDED-CHAR of ERROR
Improper subtype: EXTENDED-CHAR of SERIOUS-CONDITION
Improper subtype: EXTENDED-CHAR of CONDITION
Improper subtype: EXTENDED-CHAR of METHOD-COMBINATION
Improper subtype: EXTENDED-CHAR of STANDARD-METHOD
[GC threshold exceeded with 2,005,496 bytes in use. Commencing GC.]
[GC completed with 534,328 bytes retained and 1,471,168 bytes freed.]
[GC will next occur when at least 2,534,328 bytes are in use.]
Improper subtype: EXTENDED-CHAR of METHOD
Improper subtype: EXTENDED-CHAR of STANDARD-CLASS
Improper subtype: EXTENDED-CHAR of STRUCTURE-CLASS
Improper subtype: EXTENDED-CHAR of BUILT-IN-CLASS
Improper subtype: EXTENDED-CHAR of CLASS
Improper subtype: EXTENDED-CHAR of STANDARD-GENERIC-FUNCTION
Improper subtype: EXTENDED-CHAR of GENERIC-FUNCTION
Improper subtype: EXTENDED-CHAR of COMPILED-FUNCTION
Improper subtype: EXTENDED-CHAR of FUNCTION
Improper subtype: EXTENDED-CHAR of BOOLEAN
Improper subtype: EXTENDED-CHAR of SYMBOL
Improper subtype: CHARACTER of BASE-CHAR
Improper subtype: CONTROL-ERROR of SIMPLE-CONDITION
Improper subtype: STANDARD-GENERIC-FUNCTION of COMPILED-FUNCTION
Improper subtype: GENERIC-FUNCTION of COMPILED-FUNCTION
Improper subtype: FUNCTION of COMPILED-FUNCTION
Test TYPES-4 failed
Form: (TYPES-4-BODY)
Expected value: 0
Actual value: 99.
TYPES-5
Not an atomic type: SYMBOL
Not an atomic type: BOOLEAN
Not an atomic type: STANDARD-OBJECT
Not an atomic type: FUNCTION
Not an atomic type: COMPILED-FUNCTION
Not an atomic type: GENERIC-FUNCTION
Not an atomic type: STANDARD-GENERIC-FUNCTION
Not an atomic type: CLASS
Not an atomic type: BUILT-IN-CLASS
Not an atomic type: STRUCTURE-CLASS
Not an atomic type: STANDARD-CLASS
Not an atomic type: METHOD
Not an atomic type: STANDARD-METHOD
Not an atomic type: STRUCTURE-OBJECT
Not an atomic type: METHOD-COMBINATION
Not an atomic type: CONDITION
Not an atomic type: SERIOUS-CONDITION
Not an atomic type: ERROR
Not an atomic type: TYPE-ERROR
Not an atomic type: SIMPLE-TYPE-ERROR
Not an atomic type: SIMPLE-CONDITION
Not an atomic type: SIMPLE-TYPE-ERROR
Not an atomic type: PARSE-ERROR
Not an atomic type: HASH-TABLE
Not an atomic type: CELL-ERROR
Not an atomic type: UNBOUND-SLOT
Not an atomic type: WARNING
Not an atomic type: STYLE-WARNING
Not an atomic type: STORAGE-CONDITION
Not an atomic type: SIMPLE-WARNING
Not an atomic type: SIMPLE-WARNING
Not an atomic type: KEYWORD
Not an atomic type: UNBOUND-VARIABLE
Not an atomic type: CONTROL-ERROR
Not an atomic type: PROGRAM-ERROR
Not an atomic type: UNDEFINED-FUNCTION
Not an atomic type: PACKAGE
Not an atomic type: PACKAGE-ERROR
Not an atomic type: RANDOM-STATE
Not an atomic type: NUMBER
Not an atomic type: REAL
Not an atomic type: COMPLEX
Not an atomic type: FLOAT
Not an atomic type: SHORT-FLOAT
Not an atomic type: SINGLE-FLOAT
Not an atomic type: DOUBLE-FLOAT
Not an atomic type: LONG-FLOAT
Not an atomic type: RATIONAL
Not an atomic type: INTEGER
Not an atomic type: RATIO
Not an atomic type: SIGNED-BYTE
Not an atomic type: INTEGER
Not an atomic type: UNSIGNED-BYTE
Not an atomic type: BIT
Not an atomic type: FIXNUM
Not an atomic type: BIGNUM
Not an atomic type: BIT
Not an atomic type: ARITHMETIC-ERROR
Not an atomic type: DIVISION-BY-ZERO
Not an atomic type: FLOATING-POINT-INVALID-OPERATION
Not an atomic type: FLOATING-POINT-INEXACT
Not an atomic type: FLOATING-POINT-OVERFLOW
Not an atomic type: FLOATING-POINT-UNDERFLOW
Not an atomic type: CHARACTER
Not an atomic type: BASE-CHAR
Not an atomic type: STANDARD-CHAR
Not an atomic type: NULL
Not an atomic type: NULL
Not an atomic type: ARRAY
Not an atomic type: SIMPLE-ARRAY
Not an atomic type: VECTOR
Not an atomic type: VECTOR
Not an atomic type: STRING
Not an atomic type: BIT-VECTOR
Not an atomic type: SIMPLE-VECTOR
Not an atomic type: SIMPLE-VECTOR
Not an atomic type: SIMPLE-BIT-VECTOR
Not an atomic type: SIMPLE-BIT-VECTOR
Not an atomic type: BASE-STRING
Not an atomic type: SIMPLE-STRING
Not an atomic type: SIMPLE-STRING
Not an atomic type: SIMPLE-BASE-STRING
Not an atomic type: SIMPLE-BASE-STRING
Not an atomic type: PATHNAME
Not an atomic type: LOGICAL-PATHNAME
Not an atomic type: FILE-ERROR
Not an atomic type: STREAM
Not an atomic type: BROADCAST-STREAM
Not an atomic type: CONCATENATED-STREAM
Not an atomic type: ECHO-STREAM
Not an atomic type: FILE-STREAM
Not an atomic type: STRING-STREAM
Not an atomic type: SYNONYM-STREAM
Not an atomic type: TWO-WAY-STREAM
Not an atomic type: STREAM-ERROR
Not an atomic type: END-OF-FILE
Not an atomic type: PRINT-NOT-READABLE
Not an atomic type: READTABLE
Not an atomic type: READER-ERROR
Not an atomic type: READER-ERROR
Test TYPES-6 failed
Form: (TYPES-6-BODY)
Expected value: 0
Actual value: 100.
TYPES-7
Not atomic: SYMBOL
Not atomic: ARRAY
Not atomic: NUMBER
Not atomic: CHARACTER
Not atomic: HASH-TABLE
Not atomic: FUNCTION
Not atomic: READTABLE
Not atomic: PACKAGE
Not atomic: PATHNAME
Not atomic: STREAM
Not atomic: RANDOM-STATE
Not atomic: CONDITION
Not atomic: RESTART
Test TYPES-8 failed
Form: (LOOP FOR
TP
IN
*DISJOINT-TYPES-LIST*
COUNT
(COND
((AND (NOT (EQ TP 'CONS)) (NOT (SUBTYPEP TP 'ATOM)))
(FORMAT T "~%Not atomic: ~A" TP) T)))
Expected value: 0
Actual value: 13.
[GC threshold exceeded with 2,538,576 bytes in use. Commencing GC.]
[GC completed with 640,296 bytes retained and 1,898,280 bytes freed.]
[GC will next occur when at least 2,640,296 bytes are in use.]
TYPES-9
6 out of 9 total tests failed: TYPES-1, TYPES-2, TYPES-3, TYPES-4,
TYPES-6,
TYPES-8.
NIL
*