Using CLOS class instances as hash-table keys? - common-lisp

I have the following class:
(defclass category ()
((cat-channel-name
:accessor cat-channel-name :initarg :cat-channel-name :initform "" :type string
:documentation "Name of the channel of this category")
(cat-min
:accessor cat-min :initarg :min :initform 0 :type number
:documentation "Mininum value of category")
(cat-max
:accessor cat-max :initarg :max :initform 1 :type number
:documentation "Maximum value of category"))
(:documentation "A category"))
Now, I would like to use this class as a key for a hash-table. The addresses of instances can be easily compared with eq. The problem is however, there might be multiple identical instances of this category class and I would like the hash-table to recognize this as a key as well.
So, I was trying to overwrite the :test argument of the make-hash-table function like this:
(make-hash-table :test #'(lambda (a b) (and (equal (cat-channel-name a) (cat-channel-name b))
(eq (cat-min a) (cat-min b))
(eq (cat-max a) (cat-max b)))
Unfortunately, this is not allowed. :test needs to be a designator for one of the functions eq, eql, equal, or equalp.
One way to solve this would be to turn the class category into a struct, but I need it to be a class. Is there any way I can solve this?

Many Common Lisp implementations provide extensions to the ANSI Common Lisp standard to support different test and hash functions (and a lot more).
CL-CUSTOM-HASH-TABLE is a compatibility layer.

You can use a more extensible hash table library, as explained in coredump's answer, but you could also use the approach that Common Lisp takes toward symbols: you can intern them. In this case, you just need an appropriate interning function that takes enough of a category to produce a canonical instance, and a hash table to store them. E.g., with a simplified category class:
(defclass category ()
((name :accessor cat-name :initarg :name)
(number :accessor cat-number :initarg :number)))
(defparameter *categories*
(make-hash-table :test 'equalp))
(defun intern-category (name number)
(let ((key (list name number)))
(multiple-value-bind (category presentp)
(gethash key *categories*)
(if presentp category
(setf (gethash key *categories*)
(make-instance 'category
:name name
:number number))))))
Then, you can call intern-category with the same arguments and get the same object back, which you can safely use as a hash table key:
(eq (intern-category "foo" 45)
(intern-category "foo" 45))
;=> T

Don't compare numbers with eq, use eql or =. From eq (emphasis mine):
Objects that appear the same when printed are not necessarily eq to each other. [...]
An implementation is permitted to make "copies" of characters and numbers at any time. The effect is that Common Lisp makes no guarantee that eq is true even when both its arguments are "the same thing" if that thing is a character or number.
You can use the genhash library. First, you define a new hash function (see also sxhash) and a test function for your type and you associate it with a test designator:
(genhash:register-test-designator
'category=
(lambda (category) <hashing>)
(lambda (a b)
(and (equal ... ...)
(= ... ...)
(= ... ...))))
Then, you can define a new table:
(genhash:make-generic-hashtable :test 'category=)

Related

Controlling the printing of special cons forms (e.g printing (function +) as #'+ etc)

I want some reader macros to print as as shortened expression that the macro understands. Lets say I want to extend the #' macro to take #'~[rest-of-symbol] and turn that into (complement #'rest-of-symbol).
What controls how that is printed? On SBCL, for instance, '(function +) prints as #'+. How do i make '(complement #'listp) print as #~listp?
My first thought was
(defmethod print-object :around ((obj cons) stream)
;; if #'~fn-name / (complement (function fn-name))
;; => fn-name otherwise NIL
(let ((fn-name
(ignore-errors
(destructuring-bind (complement (function fn-name))
obj
(when (and (eq complement 'complement)
(eq function 'function))
fn-name)))))
(if fn-name
(format stream "#'~~~S" fn-name)
(call-next-method))))
This works insofar as (print-object '(complement #'evenp) *standard-output*) prints it the way I want, but the REPL doesn't. Also (print-object '#'+ *standard-output*) prints it as (function +) so the REPL isn't using print-object. With defining the print-object method for user defined classes the REPL always picks up on the new definition.
This is my first post and I'm sorry I can't get the code to format properly. If someone can put a link on how to do that I would appreciate it.
Evaluation time
You are mixing code with data in your example:
(function +)
Is a special form that evaluates to a function object, which admits a shorter syntax:
#'+
But when you are writing:
'(function +)
or
'(complement fn)
Then in both cases you are writing quoted, literal lists, which evaluates to themselves (namely a list starting with symbol function or complement, followed respectively by symbol + and fn).
However, you want the code to be evaluated at runtime to actual function objects; if you type this in the REPL:
(complement #'alpha-char-p)
The result is a value that is printed as follows:
#<FUNCTION (LAMBDA (&REST SB-IMPL::ARGUMENTS) :IN COMPLEMENT) {101AAC8D9B}>
You have an actual function object that you can funcall. In other words, by the time you reach print-object, you no longer have access to source code, you are manipulating data at runtime which happens to be functions. So you cannot use destructuring-bind to get the complement symbol that was present in the source code.
What you need to do instead is to attach metadata to your function. There is a way to do that in Common Lisp by defining a new type of function, thanks to the Meta-Object Protocol.
Funcallable objects
I'm relying on Closer-MOP for all the symbols prefixed with c2cl: below. I define a new class of functions, annotated-fn, which is a function with addditional data:
(defclass annotated-fn (c2cl:funcallable-standard-object)
((data :initform :data :initarg :data :reader annotated-fn-data))
(:metaclass c2cl:funcallable-standard-class))
Notice that this class is a funcallable-standard-object (like the usual functions), and its metaclass is funcallable-standard-class. Such an object has an additional implicit slot that is a function to call.
More precisely, you have to call c2cl:set-funcallable-instance-function to set a function associated with the object, and when later you use funcall or apply with the object, then the wrapped function is called instead. So you can transparently use this class of functions wherever you usually use a function. It just has additional slots (here data).
For example, here is how I instantiate it, with a function to wrap additional data:
(defun annotate-fn (function data)
(let ((object (make-instance 'annotated-fn :data data)))
(prog1 object
(c2cl:set-funcallable-instance-function object function))))
Let's try it:
(describe
(annotate-fn (constantly 3)
'(:category :constantly)))
#<ANNOTATED-FN {1006275C7B}>
[funcallable-instance]
Lambda-list: UNKNOWN
Derived type: FUNCTION
Documentation:
T
Source file: SYS:SRC;CODE;FUNUTILS.LISP
Slots with :INSTANCE allocation:
DATA = (:CATEGORY :CONSTANTLY)
You can also use this object like any other function.
Now, your reader macros can expand into calls to annotate-fn, and add any kind of additional metadata you need to the function.
Reader macro
For our example, imagine you define a reader macros for constant functions:
(set-macro-character #\[ 'read-constantly t)
(set-macro-character #\] (get-macro-character #\) nil))
(defun read-constantly (stream char)
(declare (ignore char))
(let* ((list (read-delimited-list #\] stream t))
(value (if (rest list) list (first list)))
(var (gensym)))
`(let ((,var ,value))
(annotate-fn (constantly ,var)
(list :category :constantly
:constant ,var)))))
Using this syntax:
> [(+ 8 5)]
=> #<ANNOTATED-FN ...>
By the way, the syntax I defined also allows the following:
> [+ 8 5]
Pretty-printing
Let's define a generic function that prints an annotated function given its :category field:
(defgeneric print-for-category (category data object stream))
(defmethod print-object ((o annotated-fn) s)
(let* ((data (annotated-fn-data o))
(category (getf data :category)))
(print-for-category category data o s)))
Then, we can specialize it for :constantly, and here we assume also that the data associated with the function contains a :constant field:
(defmethod print-for-category ((_ (eql :constantly)) data o s)
(format s "[~s]" (getf data :constant)))
For example:
(let ((value (+ 8 6)))
(annotate-fn (constantly value)
`(:constant ,value
:category :constantly)))
This above is printed as:
[14]
Which would be the same as your hypothetical reader macro.
To do this you need to understand the pretty printer. I have understood it in the past but no longer do completely. It dispatches on type and the trick for things like this is that you can specify very specific types for trees of conses, although doing so is verbose.
Here is an example which is almost certainly not completely correct, but does achieve what you want in this case:
(defparameter *ppd* (copy-pprint-dispatch))
(defun pprint-complement-function (s form)
;; This is the thing that the pretty printer will call. It can
;; assume that the form it wants to print is already correct.
(destructuring-bind (complement (function name)) form
(declare (ignore complement function))
(format s "#'~~~W" name)))
;;; Now set this in the table with a suitable hairy type specification
;;;
(set-pprint-dispatch '(cons (eql complement)
(cons (cons (eql function)
(cons t null))
null))
'pprint-complement-function
0
*ppd*)
And now
> (let ((*print-pprint-dispatch* *ppd*))
(pprint '(complement (function foo)))
(pprint '((complement (function foo)) (function foo))))
#'~foo
(#'~foo #'foo)
You can make the awful nested cons type specifier easier by defining this (which, perhaps, should be the compound type specifier for list except you can't do that):
(deftype list-of-types (&rest types)
(labels ((lot (tt)
(if (null tt)
'null
`(cons ,(first tt) ,(lot (rest tt))))))
(lot types)))
And then
(set-pprint-dispatch '(list-of-types (eql complement)
(list-of-types (eql function)
*))
'pprint-complement-function
0
*ppd*)
is perhaps easier to read.

Using dot notation to access CLOS slots

When accessing class slots, instead of writing
(defmethod get-name ((somebody person) (slot-value somebody 'name))
is it possible to use the dot notation aka C++, namely
(defmethod get-name ((somebody person) somebody.name) ?
Otherwise, when there are many slot operations in a method, (slot-value... creates a lot of boilerplate code.
I have figured out the answer today and I am just posting it as a Q&A, but if there are better solutions or there are problems I should expect with my solution, feel free to add new answers or comments.
The library access provides a dot notation reader macro for accessing slots (and hash-tables and other things). After enabling the reader macro by calling (access:enable-dot-syntax) you'll able to use #D. to access a slot name with the dot syntax popular in other languages.
(defclass person ()
((name :initarg :name :reader name)))
CL-USER> (access:enable-dot-syntax)
; No values
CL-USER> (defvar *foo* (make-instance 'person :name "John Smith"))
*FOO*
CL-USER> #D*foo*
#<PERSON #x302001F1E5CD>
CL-USER> #D*foo*.name
"John Smith"
There is also a with-dot macro if you don't want to use a reader macro
CL-USER> (access:with-dot () *foo*.name)
"John Smith"
You should not write accessors by hand, nor use slot-value (outside of object lifecycle functions, where the accessors may not have been created yet). Use the class slot options instead:
(defclass foo ()
((name :reader foo-name
:initarg :name)
(bar :accessor foo-bar
:initarg :bar)))
Now you can use the named accessors:
(defun example (some-foo new-bar)
(let ((n (foo-name some-foo))
(old-bar (foo-bar some-foo)))
(setf (foo-bar some-foo) new-bar)
(values n old-bar)))
Often, you want your classes to be "immutable", you'd use :reader instead of :accessor then, which only creates the reader, not the setf expansion.
The easiest solutions seems to be a reader macro that overloads . so that (slot-value somebody 'name) can be written as .somebody.name My strategy is to read somebody.name as a string (we need to define a non-terminating macro character so that the reader does not stop mid-string), and then process the string to construct the appropriate (slot-value...
I will need two helper functions:
(defun get-symbol (str)
"Make an uppercase symbol"
(intern (string-upcase str)))
(defun split-string (str sep &optional (start 0))
"Split a string into lists given a character separator"
(let ((end (position sep str :start start)))
(cons (subseq str start end) (if end (split-string str sep (1+ end))))))
And then I can define my reader macro:
(defun dot-reader (stream char)
(declare (ignore char))
(labels ((make-query (list)
(let ((car (car list))
(cdr (cdr list)))
(if cdr `(slot-value ,(make-query cdr) (quote ,(get-symbol car)))
(get-symbol car)))))
(make-query (nreverse (split-string (symbol-name (read stream)) #\.)))))
Finally, I need to register this reader macro:
(set-macro-character #\. #'dot-reader t)
Now it is possible to write:
(defmethod get-name ((somebody person) .somebody.name)
or, if name is itself a class,
(defmethod get-name ((somebody person) .somebody.name.first-name)
One restriction is that s-expressions will not work between the dots, say
.(get-my-class).name
won't work.

Custom slot options don't apply any reduction to its argument

Say if I define a metaclass that enhances standard slots with a validator slot, when I pass :validator (clavier:valid-email "The email is invalid") as an option, instead of storing the result of of the expression, which is a funcallable, it stores the expression itself. Am I'm missing a step when extending the standard slots? How do I ensure the expression is evaluated before stored? I'm using SBCL 1.2.11 btw. Here is the code in question
(unless (find-package 'clavier)
(ql:quickload :clavier))
(unless (find-package 'c2mop)
(ql:quickload :c2mop))
(defpackage #:clos2web/validation
(:use #:cl)
(:import-from #:c2mop
#:standard-class
#:standard-direct-slot-definition
#:standard-effective-slot-definition
#:validate-superclass
#:direct-slot-definition-class
#:effective-slot-definition-class
#:compute-effective-slot-definition
#:slot-value-using-class))
(in-package #:clos2web/validation)
(defun true (value)
"Always return true."
(declare (ignore value))
t)
(defclass validation-class (standard-class)
()
(:documentation "Meta-class for objects whose slots know how to validate
their values."))
(defmethod validate-superclass
((class validation-class) (super standard-class))
t)
(defmethod validate-superclass
((class standard-class) (super validation-class))
t)
(defclass validation-slot (c2mop:standard-slot-definition)
((validator :initarg :validator :accessor validator :initform #'true
:documentation "The function to determine if the value is
valid. It takes as a parameter the value.")))
(defclass validation-direct-slot (validation-slot
standard-direct-slot-definition)
())
(defclass validation-effective-slot (validation-slot
standard-effective-slot-definition)
())
(defmethod direct-slot-definition-class ((class validation-class) &rest initargs)
(declare (ignore initargs))
(find-class 'validation-direct-slot))
(defmethod effective-slot-definition-class ((class validation-class) &rest initargs)
(declare (ignore initargs))
(find-class 'validation-effective-slot))
(defmethod compute-effective-slot-definition
((class validation-class) slot-name direct-slot-definitions)
(let ((effective-slot-definition (call-next-method)))
(setf (validator effective-slot-definition)
(some #'validator direct-slot-definitions))
effective-slot-definition))
(defmethod (setf slot-value-using-class) :before
(new (class validation-class) object (slot validation-effective-slot))
(when (slot-boundp slot 'validator)
(multiple-value-bind (validp msg)
(funcall (validator slot) new)
(unless validp
(error msg)))))
;; Example usage
(defclass user ()
((name :initarg :name)
(email :initarg :email :validator (clavier:valid-email "The email is invalid") :accessor email))
(:metaclass validation-class))
(let ((pepe (make-instance 'user :name "Pepe" :email "pepe#tumadre.com")))
(setf (email pepe) "FU!")) ;; should throw
The code fails when making an instance as (CLAVIER:VALID-EMAIL "The email is invalid") is not a funcallable.
(CLAVIER:VALID-EMAIL
"The email is invalid") fell through ETYPECASE expression.
Wanted one of (FUNCTION SYMBOL).
[Condition of type SB-KERNEL:CASE-FAILURE]
Like the comment above says, defclass does not evaluate arguments (it is a macro). While the usual advice is to avoid eval, I think that eval in this circumstance might be exactly what you want. While usually you would splice the form directly into some macro body, with defclass I think the answer is to eval the form in slot initialization and store the evaluation (if it has not yet been evaled).
This would probably occur in:
(defmethod initialize-instance :after ((obj validation-slot)
&key &allow-other-keys)
#| ... |#)
Optionally you could also store the :validation-message and :validation-fn as two separate arguments then call:
(multiple-value-bind (validp msg)
(funcall (funcall (validator-fn slot)
(validator-message slot))
new)
(unless validp
(error msg)))
Another alternative would be to store the evaluation of the form and pass that to the macro:
(defvar *email-validator* (CLAVIER:VALID-EMAIL "The email is invalid"))
(defun email-validator (val)
(funcall *email-validator* val))
Then pass email-validator to defclass.
Additionally I might suggest that your validation functions signal slot-validation-error type conditions instead of error type conditions. Then your condition could contain references to the validator that failed, the value, the slot and the instance. This could give you much better control than the raw error. You could also add some restarts (abort to skip setting the slot, use-value to provide a different value).
Depending on your setup, it might also make more sense for your validation function to signal these directly instead of returning multiple values that are then coerced to signals.

Is there a way to access slots in the superclass list in CLOS?

Is there a way to access slots of superclasses in CLOS?
E.g., in Objective C I can perform
- (void) frob {
[super frob]
}
This sends a message to the (sole) superclass of frob.
Perusing the CLOS documentation suggests that DEFCLASS merges all superclass information on class creation and thus this ability to communicate with the superclass is lost. Is this correct?
edit:
The scenario is somewhat unusual:
Given classes
(defclass animal ()
((behavior-types
:initform '(:eat :sleep :drink)
:reader behavior-types)))
(defclass cow (animal)
((behavior-types
:initform '(:moo :make-milk)
:reader behavior-types))
(defclass horse
((behavior-types
:initform '(:buck :gambol :neigh)
:reader behavior-types))
How to have a method, say, BEHAVIOR-TYPES or GET-BEHAVIOR that, when called with an object of type horse, returns '(:eat :sleep :drink :buck :gambol :neigh). That is to say, inheritance via a slot "adds" to the initform rather than replaces it.
An easy solution is, rather than to assign the data to the class, to have a generic method like so:
(defgeneric behavior-types (obj))
(defmethod behavior-types ((obj animal)) nil)
(defmethod behavior-types :around ((obj animal))
(append '(:eat :sleep :drink)
(call-next-method obj)))
(defmethod behavior-types :around ((obj horse))
(append '(:gambol :neigh :buck)
(call-next-method obj)))
However, this solution moves the data into the defgeneric rather than the class, where it properly belongs. So the motivation for the question came forth out of this.
At any rate - the question as asked reflected a misunderstanding of CLOS's design. It is not possible, as asked and within the normal framework, to perform this task. However, two separate approaches are given below using the MOP to solve the problem I posed.
The title of your question makes it sound like you're asking about how to access slots, but the code you show seems more like it's about calling methods that have been specialized for the superclass. If it's the latter that you're looking for, you should take a look at call-next-method, as well as 7.6 Generic Functions and Methods from the HyperSpec.
Calling “superclass methods”
In CLOS, methods don't belong to classes like they do in some other languages. Instead, there are generic functions on which specialized methods are defined. For a given argument list, a number of methods may be applicable, but only one is most specific. You can call the next most specific method with call-next-method. In the following transcript, there's a class FOO and a subclass BAR, and a generic function FROB which has methods specialized for FOO and BAR. In the method specialized for BAR, there's a call to call-next-method which, in this case, calls the method specialized for FOO.
CL-USER> (defclass foo () ())
;=> #<STANDARD-CLASS FOO>
CL-USER> (defclass bar (foo) ())
;=> #<STANDARD-CLASS BAR>
CL-USER> (defgeneric frob (thing))
;=> #<STANDARD-GENERIC-FUNCTION FROB (0)>
CL-USER> (defmethod frob ((foo foo))
(print 'frobbing-a-foo))
;=> #<STANDARD-METHOD FROB (FOO) {1002DA1E11}>
CL-USER> (defmethod frob ((bar bar))
(call-next-method)
(print 'frobbing-a-bar))
;=> #<STANDARD-METHOD FROB (BAR) {1002AA9C91}>
CL-USER> (frob (make-instance 'bar))
FROBBING-A-FOO
FROBBING-A-BAR
;=> FROBBING-A-BAR
Simulating it with method combinations
You can use method combinations to combine the results of the methods that are applicable to a list of arguments. For instance, you can define a method a with the method combination list that means when you call (a thing), all the methods on a applicable for the argument are called, and their results are combined into a list. If you give your slots in the different classes different names, and specialize methods on a that read those values, you can simulate the sort of thing you're looking for. This doens't prevent you from also using a traditional reader that accesses the slot, as well (e.g., get-a in the following example). The following code shows an example:
(defgeneric a (thing)
(:method-combination list))
(defclass animal ()
((animal-a :initform 'a :reader get-a)))
(defmethod a list ((thing animal))
(slot-value thing 'animal-a))
(defclass dog (animal)
((dog-a :initform 'b :reader get-a)))
(defmethod a list ((thing dog))
(slot-value thing 'dog-a))
(a (make-instance 'dog))
(get-a (make-instance 'animal))
;=> A
(get-a (make-instance 'dog))
;=> B
Using the MOP
This post from 1998 on Allegro CL archives is worth a read. It sounds like the author is looking for something similar to what you're looking for.
I need to define an inheritance behavior that concatenates
string-values of superclass-initforms with local slot initforms. E.g.
(defclass super()
((f :accessor f :initform "head")) (:metaclass user-class))
(defclass sub(super)
((f :accessor f :initform "tail")) (:metaclass user-class))
I'd like to get the following:
(f(make-instance'sub)) -> "head tail"
I didn't find a standard option in defclass slot-descriptions for
this. I'd like to define the concatenate combination for each
meta-class 'user-class'.
The response (by Heiko Kirschke, not me, but also see this response from Jon White with a similar approach), defines a new type of class:
(defclass user-class (standard-class) ())
and specializes clos:compute-effective-slot-definition to provide an initform that's computed from the slot definitions of the class and its superclass(es):
(defmethod clos:compute-effective-slot-definition
((the-class user-class) slot-name
;; The order of the direct slots in direct-slot-definitions may
;; be reversed in other LISPs (this is code written & tested with
;; ACL 4.3):
direct-slot-definitions)
(let ((slot-definition (call-next-method))
(new-initform nil))
(loop for slot in direct-slot-definitions
as initform = (clos:slot-definition-initform slot)
when (stringp initform)
do
;; Collecting the result string could be done perhaps more
;; elegant:
(setf new-initform (if new-initform
(concatenate 'string initform " "
new-initform)
initform)))
(when new-initform
;; Since at (call-next-method) both the initform and
;; initfunction of the effective-slot had been set, both must be
;; changed here, too:
(setf (slot-value slot-definition 'clos::initform) new-initform)
(setf (slot-value slot-definition 'clos::initfunction)
(constantly new-initform)))
slot-definition))
Then it's used like this:
(defclass super ()
((f :accessor f :initform "head"))
(:metaclass user-class))
(defclass sub(super)
((f :accessor f :initform "tail"))
(:metaclass user-class))
(f (make-instance 'sub))
==> "head tail"
This is getting into MOP functionality that's not specified by the spec, so you might have to adapt it for your particular implementation. There are some MOP compatibility layer packages out there that might be able to help you out, though.
There is no such concept as the instance slot of a superclass in CLOS.
If you create an instance, it has all slots. All slots from the class and its superclasses.
If a class has a slot FOO and some superclasses have also slots named FOO, all those are merged into one slot. Each instance of that CLOS class will have that slot.
Still you need to be more careful with your wording. Superclasses are objects themselves and they have slots themselves. But this has nothing to do with an instance having local slots and having superclasses with instance slots. The latter does not exist in CLOS.
CL-USER 18 > (defclass bar () (a b))
#<STANDARD-CLASS BAR 413039BD0B>
Above is then a superclass with two slots.
CL-USER 19 > (defclass foo (bar) (b c))
#<STANDARD-CLASS FOO 4130387C93>
Above is a class with two local and one inherited slot. The slot b is actually merged from this class and from the superclass.
CL-USER 20 > (describe (make-instance 'foo))
#<FOO 402000951B> is a FOO
B #<unbound slot>
C #<unbound slot>
A #<unbound slot>
Above shows that the instance has three slots and all can be directly accessed. Even the slot `a, which was defined in the superclass.
If we look at the actual superclass as an instance itself, we see its slots:
CL-USER 21 > (describe (find-class 'bar))
#<STANDARD-CLASS BAR 413039BD0B> is a STANDARD-CLASS
NAME BAR
DEFAULT-INITARGS NIL
DIRECT-DEFAULT-INITARGS NIL
DIRECT-SLOTS (#<STANDARD-DIRECT-SLOT-DEFINITION A 4020005A23> #<STANDARD-DIRECT-SLOT-DEFINITION B 4020005A93>)
DIRECT-SUBCLASSES (#<STANDARD-CLASS FOO 4130387C93>)
DIRECT-SUPERCLASSES (#<STANDARD-CLASS STANDARD-OBJECT 40F017732B>)
PRECEDENCE-LIST (#<STANDARD-CLASS BAR 413039BD0B> #<STANDARD-CLASS STANDARD-OBJECT 40F017732B> #<BUILT-IN-CLASS T 40F00394DB>)
PROTOTYPE NIL
DIRECT-METHODS NIL
WRAPPER #(1539 (A B) NIL #<STANDARD-CLASS BAR 413039BD0B> (#<STANDARD-EFFECTIVE-SLOT-DEFINITION A 4020005AFB> #<STANDARD-EFFECTIVE-SLOT-DEFINITION B 4020005B63>) 2)
LOCK #<MP::SHARING-LOCK "Lock for (STANDARD-CLASS BAR)" Unlocked 41303AD4E3>
DOCUMENTATION-SLOT NIL
PLIST (CLOS::COPYABLE-INSTANCE #<BAR 402000638B>)
POTENTIAL-INITARGS 0
MAKE-INSTANCE-FLAGS 509
OTHER-LOCK #<MP:LOCK "Lock for (OTHER STANDARD-CLASS BAR)" Unlocked 41303AD553>
REINITIALIZE-INITARGS 0
REDEFINE-INITARGS 0
DEPENDENTS NIL
This is really, really hasckish. I hope someone will step in and fix it, though it should illustrate the idea:
(defclass agent () ((behaviour :initform do-nothing :accessor behaviour-of)))
(defclass walk-agent (agent) ((behaviour :initform and-walk)))
(defclass talk-agent (walk-agent) ((behaviour :initform and-talk)))
(defmethod sb-mop:compute-effective-slot-definition
:after (class (name (eql 'behaviour)) sdlotds)
(setf *slot-def*
(loop
:for slot :in sdlotds :do
(format t "~&slot: ~s" (sb-mop:slot-definition-initform slot))
:collect (sb-mop:slot-definition-initform slot))))
(defmethod initialize-instance :before ((instance agent) &rest keyargs)
(declare (ignore keyargs))
(let (*slot-def*)
(declare (special *slot-def*))
(sb-mop:compute-slots (class-of instance))
(setf (behaviour-of instance) *slot-def*)))
;; (behaviour-of (make-instance 'talk-agent))
;; slot: AND-TALK
;; slot: AND-WALK
;; slot: DO-NOTHING
;; slot: AND-TALK
;; slot: AND-WALK
;; slot: DO-NOTHING
;; (AND-TALK AND-WALK DO-NOTHING)
PS. I see that the function that computes the list of slots definitions in SBCL is in std-class.lisp, std-compute-slots. So it isn't something that MOP defines in some way... But this one would be really helpful here.

Common Lisp case and quoted elements

I'm writing a dungeon crawler game in CL, and I'm having trouble with the case form.
Two things:
Common Lisp complains Duplicate keyform QUOTE in CASE statement
(make-instance 'cl-rogue:tile tile-type 'wall) should print as "#", but the object prints as " " no matter which tile-type I use.
The code:
(in-package :cl-user)
(defpackage :cl-rogue
(:use :common-lisp)
(:export
:*rows*
:*cols*
:*levels*
:tile
:tile-type
:tile-contents
:tile-hidden
:tile-locked
:tile-closed
:main))
(in-package :cl-rogue)
(defparameter *cols* 80)
(defparameter *rows* 24)
(defparameter *levels* 26)
The class:
(defclass tile ()
((tile-type
:initarg :tile-type
:accessor tile-type
:initform 'floor
:documentation "Type of tile")
(tile-contents
:initarg :tile-contents
:accessor tile-contents
:initform '()
:documentation "Any items the tile holds")
(tile-hidden
:initarg :tile-hidden
:accessor tile-hidden
:initform nil
:documentation "Whether the tile is hidden or shown")
(tile-locked
:initarg :tile-locked
:accessor tile-locked
:initform nil
:documentation "Whether the tile is locked")
(tile-closed
:initarg :tile-closed
:accessor tile-closed
:initform nil
:documentation "Whether the tile is open or closed")))
The print method:
(defmethod print-object ((object tile) stream)
(with-slots (tile-type tile-contents tile-hidden tile-locked tile-closed) object
(if tile-hidden
(format stream " ")
(let ((an-item (car tile-contents)))
(if an-item
(format stream "~a" an-item)
(format stream (case tile-type
('wall "#")
('upstair "<")
('downstair ">")
('door (if tile-closed "+" "\\"))
(otherwise " "))))))))
You don't need to quote the symbols in CASE.
Actually you shouldn't quote symbols in CASE clauses.
See:
CL-USER 31 > (case 'quote
('not-quote 'oops-really-quote)
('quote 'it-is-a-quote))
OOPS-REALLY-QUOTE
Above is the unintended consequence of using 'not-quote instead of the correct unquoted not-quote.
The following is correct:
CL-USER 32 > (case 'quote
(not-quote 'oops-really-quote)
(quote 'it-is-a-quote))
IT-IS-A-QUOTE
The syntax of CASE in Common Lisp
case keyform
{normal-clause}*
[otherwise-clause]
=> result*
normal-clause::= (keys form*)
otherwise-clause::= ({otherwise | t} form*)
clause::= normal-clause | otherwise-clause
keys ::= object | (object*)
As you can see the keys are either a single object or a list of objects. The objects are not evaluated.
Symbols in CASE clauses are not evaluated.
(case tile-type
(wall ...)
(door ...))
WALL and DOOR are purely symbols and not evaluated as variables.
The Lisp reader reads 'fooas (quote foo).
You wrote:
(case tile-type
('wall ...)
('door ...))
Which is the equivalent of:
(case tile-type
((quote wall) ...)
((quote door) ...))
But you can't quote a symbol in CASE. You have to provide the symbols as literal constants.
If you write:
(let ((bar 'foo)
(baz 'foo))
(case bar
(baz :we-have-a-foo-through-baz)
(foo :we-really-have-a-foo)))
This returns :WE-REALLY-HAVE-A-FOO. Because CASE uses constant data, not variables.
CASE accepts a list of items. Since you have QUOTE as a symbol in more than clause, the compiler showed a warning.
As I said, there is no quoting possible, since the items are not evaluated.
As for CASE accepting a list of items in the clauses, it looks like this:
(case tile-type
((door wall) ...)
((floor window painting) ...))
For the WALL symbol, you need to make sure that it is in the right package when you create the object.
Better use a keyword symbol, such as :wall. Then you don't need to export it and there is no confusion about in which package the symbol is.
About the formatting of the code:
You had a bullet list and right after it a code section. This is not rendered as you expect. I have added the text 'The code:' before the code. Then the rendering works as expected.

Resources