I'm still quite new to Common Lisp macros.
For an abstraction over a defclass with defgeneric I thought it'd be nice to make a macro.
A complitely naive implementation looks like:
(defmacro defgserver (name &key call-handler cast-handler)
"TODO: needs firther testing. Convenience macro to more easily create a new `gserver' class."
`(progn
(defclass ,name (gserver) ())
(defmethod handle-call ((server ,name) message current-state)
,(if call-handler call-handler nil))
(defmethod handle-cast ((server ,name) message current-state)
,(if cast-handler cast-handler nil))))
When used the error says that 'message' is not known.
I'm not sure. 'message' is the name of a parameter of defgeneric:
(defgeneric handle-call (gserver message current-state))
Using the macro I see a warning 'undefined variable message':
(defgserver foo :call-handler
(progn
(print message)))
; in: DEFGSERVER FOO
; (PRINT MESSAGE)
;
; caught WARNING:
; undefined variable: COMMON-LISP-USER::MESSAGE
Which when used has this consequence:
CL-USER> (defvar *my* (make-instance 'foo))
*MY*
CL-USER> (call *my* "Foo")
<WARN> [10:55:10] cl-gserver gserver.lisp (handle-message fun5) -
Error condition was raised on message processing: CL-GSERVER::C: #<UNBOUND-VARIABLE MESSAGE {1002E24553}>
So something has to happen with message and/or current-state.
Should they be interned into the current package where the macro is used?
Manfred
The problem, as mentioned, is that you are talking about different symbols.
However this is really a symptom of a more general problem: what you are trying to do is a sort of anaphora. If you fixed up the package structure so this worked:
(defgserver foo :call-handler
(progn
(print message)))
Then, well, what exactly is message? Where did it come from, what other bindings exist in that scope? Anaphora can be useful, but it also can be a source of obscure bugs like this.
So, I think a better way to do this, which avoids this problem is to say that the *-handler options should specify what arguments they expect. So instead of the above form you'd write something like this:
(defgserver foo
:call-handler ((server message state)
(print message)
(detonate server)))
So here, value of the :call-handler-option is the argument list and body of a function, which the macro will turn into a method specialising on the first argument. Because the methods it creates have argument lists provided by the user of the macro there's never a problem with names, and there is no anaphora.
So, one way to do that is to do two things:
make the default values of these options be suitable for processing into methods without any special casing;
write a little local function in the macro which turns one of these specifications into a suitable (defmethod ...) form.
The second part is optional of course, but it saves a little bit of code.
In addition to this I've also done a slightly dirty trick: I've changed the macro definition so it has an &body option, the value of which is ignored. The only reason I've done this is to help my editor indent it better.
So, here's a revised version:
(defmacro defgserver (name &body forms &key
(call-handler '((server message current-state)
(declare (ignorable
server message current-state))
nil))
(cast-handler '((server message current-state)
(declare (ignorable
server message current-state))
nil)))
"TODO: needs firther testing. Convenience macro to more easily
create a new `gserver' class."
(declare (ignorable forms))
(flet ((write-method (mname mform)
(destructuring-bind (args &body decls/forms) mform
`(defmethod ,mname ((,(first args) ,name) ,#(rest args))
,#decls/forms))))
`(progn
(defclass ,name (gserver) ())
,(write-method 'handle-call call-handler)
,(write-method 'handle-cast cast-handler))))
And now
(defgserver foo
:call-handler ((server message state)
(print message)
(detonate server)))
Expands to
(progn
(defclass foo (gserver) nil)
(defmethod handle-call ((server foo) message state)
(print message)
(detonate server))
(defmethod handle-cast ((server foo) message current-state)
(declare (ignorable server message current-state))
nil))
Related
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.
I have the following basic classes and methods:
(defgeneric connect-edge (edge))
(defclass Node ()
((forward-edges :initform nil)
(backward-edges :initform nil)
(value :initform 0.0)))
(defclass Edge ()
((value :initform 0.0)
(nodes :initform nil)))
(defmethod connect-edge ((edge Edge))
;; does nothing important. Simplified to cause the problem
(slot-value (car (slot-value edge 'nodes)) 'forward-edges))
I simplified the method enough to give me an error. Basically it doesn't do anything useful at this point, but it is enough to demonstrate the problem.
Setup:
The Edge class has nodes which is a list of Node objects. The Node class has lists of Edge objects.
Intention:
Read/ write the forward-edges and backward-edges in the Node objects encapsulated within an Edge object (the node list)
Problem/Question:
This "works" by returning nil as expected:
(defparameter *edge* (make-instance 'Edge))
(setf (slot-value *edge* 'nodes) (list (make-instance 'Node) (make-instance 'Node)))
(connect-edge *edge*)
This code gives me the error below, Why?
(connect-edge (make-instance 'Edge))
There is no applicable method for the generic function
#<STANDARD-GENERIC-FUNCTION (SB-PCL::SLOT-ACCESSOR :GLOBAL
COMMON-LISP-USER::FORWARD-EDGES
SB-PCL::READER) (1)>
when called with arguments
(NIL).
Also, if I do this, I get the error below, which I think I understand why: No generic function defined which takes nil:
(connect-edge nil)
There is no applicable method for the generic function
#<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::CONNECT-EDGE (1)>
when called with arguments
(NIL).
[Condition of type SIMPLE-ERROR]
Why am I doing all this?
I have the following code which causes (perhaps for different reason) similar error:
(defun make-classic (net)
(loop
for this-layer in net
for next-layer in (cdr net)
do
(loop
for this-node in this-layer
do
(loop
for next-node in next-layer
do
(let ((edge (make-instance 'Edge)))
(setf (slot-value edge 'nodes) '(this-node next-node))
(format t "Type of edge is ~a~%" (type-of edge))
;; Error is here
(connect-edge edge))))))
I wasn't sure if the error is due to passing a scoped variable, so I ended up trying to pass a (make-instance 'Edge) to cause the error.
This is all you need:
when called with arguments (NIL).
(slot-value (make-instance 'Edge) 'nodes)
is nil, so
(slot-value (car (slot-value edge 'nodes)) 'forward-edges))
fails.
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.
I want to retrieve the string, generated by write for further processing without doing any actual output, but write seems always to also output into the REPL
CL-USER>(let ((err-string (write (make-instance 'error) :stream nil)))
(do-awesome-stuff-with-string err-string))
<ERROR> ;;this is the printing I want to get rid of
"awesome-result"
Why does write still outputs into the REPL, and how do I get rid of that?
You can use with-output-to-string for this. Here's an example:
(flet ((do-awesome-stuff-with-string (string)
(concatenate 'string string " is awesome!")))
(let ((err-string (with-output-to-string (s)
(write (make-instance 'error) :stream s))))
(do-awesome-stuff-with-string err-string)))
;; => "#<ERROR {25813951}> is awesome!"
Here's here's the HyperSpec entry on with-output-to-string.
The reason (write (make-instance 'error) :stream nil) doesn't work is that the :stream argument to write is a stream designator and in that context nil is shorthand for *standard-output*. (The fact that format instead takes nil to mean that it should return a string is a common point of confusion).
Keep in mind that portably errors are made with MAKE-CONDITION. The standard does not say that errors are CLOS classes, so MAKE-INSTANCE might not work in some implementations.
There are two simple ways to get a string:
a) a textual description:
CL-USER 15 > (princ-to-string (make-condition 'error))
"The condition #<ERROR 4020311270> occurred"
b) the error object printed:
CL-USER 16 > (prin1-to-string (make-condition 'error))
"#<ERROR 402031158B>"
What I'm trying to do:
I want the functionality of simple-error in another error. I want this for these reasons:
to be able to handle it in a separate clause of handler-case.
to avoid specifying the message string over and over again...
to have debugger invoked when the error occurs.
I'm sort of puzzled this doesn't happen naturally by default, never paid enough attention to this issue, but this is apparently how it functions... What I am able to do is to signal an error, which I can later handle with handler-case or handler-bind, but this is bad, because I don't always remember whether the function throws or not, and when it does throw, but I forget to handle it, the function just returns early, as if nothing happened. But if I resume to using simple-error, then my code starts looking like:
...
(signal "Container ~S has no key ~S~&" :container foo :key bar)
...
(signal "Container ~S has no key ~S~&" :container foo :key baz)
...
And so on, all over the place :/ Of course I can dedicate a variable for saving the message text and maybe have a macro to make it shorter, but this doesn't help really, because it only hides the actual clutter instead of solving the problem.
What I could do so far:
(define-condition missing-key (condition)
((key :initarg :key
:accessor key-of)
(container :initarg :container
:accessor container-of))
(:documentation
"An error rised when a KEY is not in the CONTAINER"
:report
#'(lambda (condition stream)
(unless *print-escape*
(format stream "~&Container ~S has no key ~S"
(container-of condition)
(key-of condition))))))
(handler-bind
((missing-key
#'(lambda (condition)
(invoke-debugger condition))))
(signal 'missing-key :key 'foo :container 'bar))
What happens, however is that reporting function never gets called... when the error is signalled, instead it prints a generic message Condition MISSING-KEY was signalled.
EDIT:
Thanks to sds answer, this is what I have now:
(define-condition missing-key (error)
((key :initarg :key
:accessor key-of)
(container :initarg :container
:accessor container-of))
(:documentation
"An error rised when a KEY is not in the CONTAINER")
(:report
(lambda (condition stream)
(format stream "Container ~S has no key ~S"
(container-of condition)
(key-of condition)))))
(defmacro signal-missing-key (container key)
`(let ((*break-on-signals*
(cond
((null *break-on-signals*) 'missing-key)
((consp *break-on-signals*)
(list 'or 'missing-key (cdr *break-on-signals*)))
(t (list 'or *break-on-signals* 'missing-key)))))
(signal 'missing-key :key ,container :container ,key)))
I could probably make it more generic by passing more arguments down to signal, but this does what I wanted to do initially, so, unless there is a better way to do the same thing, I'll probably just use this.
You can use error or cerror with your own condition types, if you want the debugger to be invoked unless the conditions are handled otherwise. This also works for conditions that are not descendants of simple-error.
If you want this behavior for signal, too, you can set the variable *break-on-signals* to the according type. For example, you could set it to t in order to invoke the debugger for every unhandled condition.
Your code works as you intended with the following modifications: remove #' before lambda, remove ~& from format (error reporting does that and more), close the :documentation clause and open the :report clause:
(define-condition missing-key (condition)
((key :initarg :key
:accessor key-of)
(container :initarg :container
:accessor container-of))
(:documentation
"An error rised when a KEY is not in the CONTAINER")
(:report
(lambda (condition stream)
(unless *print-escape*
(format stream "Container ~S has no key ~S"
(container-of condition)
(key-of condition))))))
MISSING-KEY
(signal 'missing-key :key 'foo :container 'bar)
==> NIL
(handler-bind
((missing-key
#'(lambda (condition)
(invoke-debugger condition))))
(signal 'missing-key :key 'foo :container 'bar))
*** - Container BAR has no key FOO
The following restarts are available:
ABORT :R1 Abort main loop
Break 1 [46]>
i.e., signal prints nothing but handler invokes the debugger.
Make your condition a subclass of ERROR rather than CONDITION. Not all conditions are errors that require intervention via debugger, and the condition class hierarchy is designed to distinguish between them.