Better way to do this?
Marco Antoniotti
vfr...@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
Sunil Mishra
vfr...@netcom.com (Will Hartung) writes:
...
Not quite
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
Erik Naggum
* 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
Erik Naggum <cle...@naggum.no> writes:
> * Sunil Mishra
> | ... :type (member t nil) ...
>
> probably a stupid question, but why (MEMBER T NIL) instead of BOOLEAN?
>
CMUCL idiosyncrasy.
(typep nil 'boolean)
generates an error. This is one for cmucl-bugs.
Paul Dietz
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
*