I'm looking for a way to clone CLOS objects in a shallow manner, so the created object would be of the same type with the same values in each slot, but a new instance. The closest thing I found is a standard function copy-structure which does this for structures.
There is no standard predefined way to copy CLOS objects in general. It is not trivial, if possible at all, to provide a reasonable default copy operation that does the right thing (at least) most of the time for arbitrary objects, since the correct semantics change from class to class and from application to application. The extended possibilities the MOP provides make it even harder to provide such a default. Also, in CL, being a garbage collected language, copying of objects is not really needed very often, e.g. when passed as parameters or being returned. So, implementing your copy operations as needed would probably be the cleanest solution.
That being said, here is what I found in one of my snippet files, which might do what you want:
(defun shallow-copy-object (original)
(let* ((class (class-of original))
(copy (allocate-instance class)))
(dolist (slot (mapcar #'slot-definition-name (class-slots class)))
(when (slot-boundp original slot)
(setf (slot-value copy slot)
(slot-value original slot))))
copy))
You will need some MOP support for class-slots and slot-definition-name.
(I probably adopted this from an old c.l.l thread, but I can't remember. I never really needed something like this, so it's utterly untested.)
You can use it like this (tested with CCL):
CL-USER> (defclass foo ()
((x :accessor x :initarg :x)
(y :accessor y :initarg :y)))
#<STANDARD-CLASS FOO>
CL-USER> (defmethod print-object ((obj foo) stream)
(print-unreadable-object (obj stream :identity t :type t)
(format stream ":x ~a :y ~a" (x obj) (y obj))))
#<STANDARD-METHOD PRINT-OBJECT (FOO T)>
CL-USER> (defparameter *f* (make-instance 'foo :x 1 :y 2))
*F*
CL-USER> *f*
#<FOO :x 1 :y 2 #xC7E5156>
CL-USER> (shallow-copy-object *f*)
#<FOO :x 1 :y 2 #xC850306>
Here's a slightly different version of the function submitted by danlei. I wrote this a while ago and just stumbled across this post. For reasons that I don't entirely recall, this calls REINITIALIZE-INSTANCE after copying. I think it's so you could make some changes to the new object by passing additional initargs to this function
e.g.
(copy-instance *my-account* :balance 100.23)
This is also defined as generic function over objects that are 'standard-object's. Which might or might not be the right thing to do.
(defgeneric copy-instance (object &rest initargs &key &allow-other-keys)
(:documentation "Makes and returns a shallow copy of OBJECT.
An uninitialized object of the same class as OBJECT is allocated by
calling ALLOCATE-INSTANCE. For all slots returned by
CLASS-SLOTS, the returned object has the
same slot values and slot-unbound status as OBJECT.
REINITIALIZE-INSTANCE is called to update the copy with INITARGS.")
(:method ((object standard-object) &rest initargs &key &allow-other-keys)
(let* ((class (class-of object))
(copy (allocate-instance class)))
(dolist (slot-name (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots class)))
(when (slot-boundp object slot-name)
(setf (slot-value copy slot-name)
(slot-value object slot-name))))
(apply #'reinitialize-instance copy initargs))))
This solution does not require sl-mob:
(defun copy-slot (s d slot)
`(setf (,slot ,d) (,slot ,s)))
(defun copy-by-slots (s d slots)
(assert (eql (class-of s) (class-of d)))
(let ((f (lambda (s$) (eval (copy-slot s d s$)))))
(mapcar f slots)))
(copy-by-slots src dest quoted-list-of-slots)
I mention a dirty trick producing a clone of a CLOS instance.
(defclass cl () ((sl1 :initarg :sl1) (sl2 :initarg :sl2)))
(defmethod update-instance-for-different-class ((copy cl) (original cl) &key)
(setf clone copy))
(setf a (make-instance 'cl :sl1 111 :sl2 222))
(change-class a 'cl)
(eq clone a) -> NIL
(eql (slot-value a 'sl1) (slot-value clone 'sl1)) -> T
Implies CLOS itself needs a notion of clone.
Related
I am trying to build a common lisp implementation of the channel construct of Golang for a personal project (also to learn lisp). So far I've implemented the channels as objects of a class, containing a queue, a lock and a condition variable to signal listening functions that a new message has been added to the queue. I'm using bordeaux threads to create threads, locks, condition variables and join the executions (from the lisp cookbook).
This is the channel class and the recive function:
(defclass channel ()
((messages :initform '()
:accessor messages
:documentation "Messages in the channel")
(lock :initform (bt:make-lock)
:accessor lock
:documentation
"Lock to push/pop messages in the channel")
(cv :initarg :cv
:initform (bt:make-condition-variable)
:accessor cv
:documentation
"Condtional variable to notify the channel of a new message")))
(defmethod recive-loop ((self channel))
(with-slots (lock cv messages) self
(let ((to-ret nil))
(loop
(bt:with-lock-held (lock)
(if (not (null messages))
(setf to-ret (car (pop messages)))
(bt:condition-wait cv lock))
(if to-ret (return to-ret)))))))
(defmethod recive ((self channel))
(with-slots (name thread) self
(let ((thread
(bt:make-thread #'(lambda() (recive-loop self))
:name name)))
(bt:join-thread thread))))
(defmacro gorun (f &rest args)
(flet ((fn () (apply f args)))
(bt:make-thread #'fn
:initial-bindings (list args)
:name "gorun worker")))
gorun should be the equivalent of go routine() for go (without the light threading). To test the setup I've built a printer function over a channel
(defvar printch (channel))
(defun printover (ch)
(let ((x (recive ch)))
(format t "Recived variable x: ~d~%" x)))
but when I run
(gorun printover printch)
The interpreter (using sbcl, but with clisp the same happens) gives back an error:
There is no applicable method for the generic function
#<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::RECIVE (1)>
when called with arguments
(PRINTCH).
[Condition of type SB-PCL::NO-APPLICABLE-METHOD-ERROR]
See also:
Common Lisp Hyperspec, 7.6.6 [:section]
Restarts:
0: [RETRY] Retry calling the generic function.
1: [ABORT] abort thread (#<THREAD "gorun worker" RUNNING {100293E9F3}>)
Backtrace:
0: ((:METHOD NO-APPLICABLE-METHOD (T)) #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::RECIVE (1)> PRINTCH) [fast-method]
Locals:
SB-PCL::ARGS = (PRINTCH)
GENERIC-FUNCTION = #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::RECIVE (1)>
1: (SB-PCL::CALL-NO-APPLICABLE-METHOD #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::RECIVE (1)> (PRINTCH))
Locals:
ARGS = (PRINTCH)
GF = #<STANDARD-GENERIC-FUNCTION COMMON-LISP-USER::RECIVE (1)>
2: (PRINTOVER PRINTCH)
Locals:
CH = PRINTCH
3: ((LAMBDA NIL :IN BORDEAUX-THREADS::BINDING-DEFAULT-SPECIALS))
[No Locals]
I'm confused, since the method to run over the channel printch should be the one I've defined.
Trying to call a class method inside of a new thread, but got no applicable method
A macros is supposed to return code to run in place of the original call. Your macro is creating the thread at expansion time.
If you're not using backtick in a macro definition, there's usually something wrong with it. You should figure out what the code would look like without the macro, then define a macro that returns code with that same structure in a backticked list, replacing the places that need to vary with the parameters, using comma to expand them.
(defmacro gorun (f &rest args)
`(bt:make-thread (function ,f)
:initial-bindings (list ,#args)
:name "gorun worker"))
In the above, you need to substitute the function name into a (function ...) expression, and the args list as the :initial-bindings argument.
In multi-threaded environments it is often the case that special variables are thread-local. The global binding is visible from all threads, but if you bind one locally its value will not automatically be transferred to a thread created in that context. It has to be done explicitly, and I wrote a pair of macros recently just for that.
The first one captures bindings into lexically-scoped variables; the other bind the original variables back to the values captured in a different context.
I am using an intermediate data structure in the code to store bindings:
(defstruct bindings data)
The first macro is with-captured-bindings:
(defmacro with-captured-bindings ((&rest symbols) as name &body body)
(assert (eq as :as))
(loop for s in (alexandria:flatten
(sublis
'((:stdio *standard-output* *error-output* *standard-input*)
(:path *default-pathname-defaults*))
symbols))
for g = (gensym)
collect (list g s) into capture
collect (list s g) into rebind
finally
(return
`(let ,capture
,#(subst (make-bindings :data rebind)
name
body)))))
The capture variable holds a list of bindings to initialize the lexically-scoped variables. The rebind variables is a list of bindings to set back special variables to their values in another thread.
I inject with subst an instance of the bindings struct in the code. It helps to have a dedicated data structure, but the crude search-and-replace approach means the symbols name will not be usable as a function, local macro, etc. in body. I don't think it is too much of a problem.
Also, I define aliases like :stdio and :path for commonly used variables.
The second macro is with-bindings:
(defmacro with-bindings (bindings &body body)
(check-type bindings bindings)
`(let ,(bindings-data bindings)
,#body))
This replaces the intermediate struct with the proper code. The final code does not have this struct anymore and can be processed as usual.
For example:
(defvar *my-var* "hello")
(with-captured-bindings (:stdio :path *my-var*) :as <bindings>
(sb-thread:make-thread
(lambda ()
(with-bindings <bindings>
(print *var*)))))
A first application of macroexpand gives:
(LET ((#:G3882 *STANDARD-OUTPUT*)
(#:G3883 *ERROR-OUTPUT*)
(#:G3884 *STANDARD-INPUT*)
(#:G3885 *DEFAULT-PATHNAME-DEFAULTS*)
(#:G3886 *MY-VAR*))
(SB-THREAD:MAKE-THREAD
(LAMBDA ()
(WITH-BINDINGS #S(BINDINGS
:DATA ((*STANDARD-OUTPUT* #:G3882)
(*ERROR-OUTPUT* #:G3883)
(*STANDARD-INPUT* #:G3884)
(*DEFAULT-PATHNAME-DEFAULTS* #:G3885)
(*MY-VAR* #:G3886)))
(PRINT *MY-VAR*)))))
Notice that there is #S(BINDINGS ...) object in the tree.
The full expansion is:
(LET ((#:G3887 *STANDARD-OUTPUT*)
(#:G3888 *ERROR-OUTPUT*)
(#:G3889 *STANDARD-INPUT*)
(#:G3890 *DEFAULT-PATHNAME-DEFAULTS*)
(#:G3891 *MY-VAR*))
(SB-THREAD:MAKE-THREAD
(LAMBDA ()
(LET ((*STANDARD-OUTPUT* #:G3887)
(*ERROR-OUTPUT* #:G3888)
(*STANDARD-INPUT* #:G3889)
(*DEFAULT-PATHNAME-DEFAULTS* #:G3890)
(*MY-VAR* #:G3891))
(PRINT *MY-VAR*)))))
When using emacs or my android app I run
(defun big (num) (setf num2 5)(little num)))
(defun little (num)(+ num2 num))
Little happily accepts num2 but when I run it in my SBCL repl (with sublimetext3) it does not.
Is this correct?
What is a workaround without creating a global variable for num2?
I could just pass a second argument (little num num2)
But this wont work when I am trying to mapcar little over a list. Because I can only have one argument when mapcaring correct?
Please read ยง6. Variables from Practical Common Lisp.
Unlike Emacs Lisp, Common Lisp relies on lexical scope by default (Emacs Lisp is dynamic by default). Dynamic scope (i.e. indefinite scope and dynamic extent) is provided by declaring variables special, and by convention, they are written with asterisks around their names (named "earmuffs"), like *standard-output*. You use defparameter or defvar to declare those variables. Since it has a global effect, you should never use them from inside functions; likewise, your usage of setf is not defined in Common Lisp: no variable named num2 was declared previously in the scope; besides, even if it did, using a global/special variable for local variable is bad style.
Dynamic scope
With special variables, you can for example locally rebind the standard output: the new value is only visible while the code is inside the body of the let binding:
(let ((*standard-output* *error-output*))
(print "Stream redirection"))
By default, print writes to the stream bound to *standard-output*; here, the stream is locally bound to the one given by *error-output*. As soon as you escape the let, *standard-output* reverts to its previous value (imagine there is a stack).
Lexical scope
With lexical scope, your code can only access the bindings that are visible in the text surrounding your code (and the global scope), and the extent is indefinite: it is possible to access a binding (sometimes indirectly) even after the code returns from the let:
(let ((closure
(let ((count 0))
(lambda () (print (incf count))))))
(funcall closure)
(funcall closure))
;; prints:
;; 1
;; 2
The lambda expression creates a closure, which captures the variable named count. Every time you call it, it will increase the count variable and print it. If you evaluate the same code another time, you define another closure and create another variable, with the same name.
Mapcar
Because I can only have one argument when mapcaring correct?
Not exactly; the function called by mapcar should be able to accept at least as many elements as the number of lists that are given to it (and it should also not require more mandatory arguments):
(mapcar (lambda (x y) (* x y))
'(1 2 3)
'(0 3 6))
=> (0 6 18)
(mapcar #'list '(1 2) '(a b) '(+ /))
=> ((1 a +) (2 b /))
The function can also be a closure, and can use special variables.
... with a closure
(defun adder (x)
(lambda (y) (+ x y)))
(mapcar (adder 10) '(0 1 2))
=> (10 11 12)
The adder functions takes a number x and returns a closure which accepts a number y and returns (+ x y).
... with a special variable
If you prefer dynamic scope, use earmuffs and give it a meaningful name:
(defparameter *default-offset* 0)
... and define:
(defun offset (x)
(+ x *default-offset*))
You can then mapcar too:
(let ((*default-offset* 20))
(mapcar #'offset '(1 2 3)))
=> (21 22 23)
As said by jkiiski in comments, you can also declare special variables with (declare (special ...)) where you usually put declarations (when entering a let, a defun, ...). You could also use the special operator progv. This can be useful to have "invisible" variables that are only known by a set of functions to exchange information. You rarely need them.
Suppose I have some function which returns a struct:
(struct layer (points lines areas))
(define (build-new-layer height)
...
(layer list-a list-b list-c))
I want to keep track of the last returned result something like:
(define top-side (build-new-layer 0)) ; store the first result
...
(set! top-side (build-new-layer 0.5)) ; throw away the first result and store the new one
However, for that particular code I get the error:
set!: assignment disallowed;
cannot modify a constant
constant: top-side
Please, tell me what would be the right way to do what I want
What language are you using? it seems it's a matter of configuration, because in principle what you're doing should work. Go to the "choose language" window (Ctrl+L in Windows), click on "show details" and see if one of the options of the language currently in use disallows redefinition of variables. Alternatively, try using a different language.
Depending on where exactly you're going to use the stored result (I can't tell from the code in the question), you could pass it around as function parameters, in such a way that using a global variable is no longer necessary. This might be a better idea, relying on global state and mutation (the set! operation) is discouraged in Scheme.
If you always want to keep around the last layer, then you might prefer setting the last-layer every time one is built. Like this.
(define last-layer #f)
(define build-new-layer
(let ((save-layer #f))
(lambda (height)
(let ((new-layer (layer list-a ...)))
(set! last-layer save-layer)
(set! save-layer new-layer)
new-layer))))
Note: if the real problem is the 'constant-ness' of last-layer then build yourself a little abstraction as:
(define-values (last-layer-get last-layer-set!)
(begin
(define last-layer-access
(let ((last-layer #f))
(lambda (type . layer)
(case type
((get) last-layer)
((set) (set! last-layer (car layer)))))))
(values (lambda () (last-layer-access 'get))
(lambda (layer) (last-layer-access 'set layer))))
The code below "compiles", but doesn't function properly:
(defstruct (image-info
(:conc-name img-)
(:constructor %make-img-info (&key file))
(:print-function print-img-info))
(file nil :type string)
(gd-image nil :type (or cl-gd::image null))
(size '(0 . 0) :type cons)
(position '(0 . 0) :type cons))
(defun print-img-info (info stream level)
(declare (ignore level))
(let ((size (img-size info))
(pos (img-position info)))
(format stream "~s[width: ~d, height: ~d, x: ~d, y: ~d]"
(img-file info)
(car size) (cdr size) (car pos) (cdr pos))))
(defun make-img-info (path)
(let ((image (cl-gd:create-image-from-file path))
(info (%make-img-info :file path))) ; <--- problem here
(setf (img-gd-image info) image
(img-size info)
(cons (cl-gd:image-width image)
(cl-gd:image-height image))) info))
SBCL infers correctly the type of the argument to %make-img-info, as can be seen here:
(describe '%make-img-info)
SPRITESHEET::%MAKE-IMG-INFO
[symbol]
%MAKE-IMG-INFO names a compiled function:
Lambda-list: (&KEY (FILE NIL))
Declared type: (FUNCTION (&KEY (:FILE STRING))
(VALUES IMAGE-INFO &OPTIONAL))
But when I try to compile the make-img-info, I get this:
note: deleting unreachable code
warning:
Derived type of PATH is
(VALUES CL-GD::IMAGE &OPTIONAL),
conflicting with its asserted type
STRING.
I'm passing the correct argument (a string) to this function, but it still fails to call it because it "believes" that it has to be cl-gd:image. I suspect that the problem is that the layout is somehow alphabetical, and gd-image comes up before file in the list... but how do I then address this? I don't really want to rename the field?
Now I believe this was some sort of a glitch related to SLIME and SBCL not cooperating very well when compiling structs. I cannot consistently reproduce this behaviour, but it happens now and then with other structs too so that some times I need to kill SLIME and SWANK, restart SBCL and recompile because recompiling only the related parts of the struct will not work.
I'm not deleting the question because if anyone will come across similar behaviour, maybe it will help to restart the Lisp, so this experience can be useful.
I've written a small Scheme interpreter in C#, and realised that the way I had implemented it, it was very easy to add support for proper continuations.
So I added them... but want to "prove" that they way that I've added them is correct.
My Scheme interpreter however has no support for "mutating" state - everything is immutable.
So it was pretty easy to write a unit test to expose "upwards" continuations:
AssertEqual(Eval("(call/cc (lambda (k) (+ 56 (k 3))))"), 3);
However, I also want to write a unit test that demonstrates that if the continuation "escapes" then that still works too:
AssertEqual(Eval("(call/cc (lambda (k) k))", <some continuation>);
But of course, the above would just test that "I got a continuation"... not that it's actually a valid continuation.
All of the examples I can find, however, always end up using "set!" to demonstrate the escaped continuation.
What's the simplest Scheme example that demonstrates proper support for backwards continuations without relying on mutation?
Are backwards continuations any use without mutation? I am beginning to suspect that they are not, because you could only use it to execute the exact same calculation again... which is meaningless if there are no side-effects. Is this why Haskell does not have continuations?
I don't know if this is the simplest, but here's an example of using backwards continuations without any call to set! or similar:
(apply
(lambda (k i) (if (> i 5) i (k (list k (* 2 i)))))
(call/cc (lambda (k) (list k 1))))
This should evaluate to 8.
Slightly more interesting is:
(apply
(lambda (k i n) (if (= i 0) n (k (list k (- i 1) (* i n)))))
(call/cc (lambda (k) (list k 6 1))))
which computes 6! (that is, it should evaluate to 720).
You can even do the same thing with let*:
(let* ((ka (call/cc (lambda (k) `(,k 1)))) (k (car ka)) (a (cadr ka)))
(if (< a 5) (k `(,k ,(* 2 a))) a))
(Man, stackoverflow's syntax highlighting fails massively on scheme.)
I think you're right -- without mutation, backwards continuations do nothing that forward continuations can't.
Here's the best I've come up with:
AssertEqual(Eval("((call/cc (lambda (k) k)) (lambda (x) 5))", 5);
Not amazing, but it is a backwards continuation which I then "call" with the actual function I wish to invoke, a function that returns the number 5.
Ah and I've also come up with this as a good unit test case:
AssertEqual(Eval("((call/cc call/cc) (lambda (x) 5))", 5);
I agree with Jacob B - I don't think it's that useful without mutable state... but would be still be interested in a counter-example.
Functional Threads:
You can use a recursive loop to update state without mutation. including the state of the next continuation to be called. Now this is more complicated than the other examples given, but all you really need is the thread-1 and main loop. The other thread and "update" function are there to show that continuations can be used for more than a trivial example. Additionally, for this example to work you need an implementation with the named let. This can be translated into an equivalent form made with define statements.
Example:
(let* ((update (lambda (data) data)) ;is identity to keep simple for example
(thread-1
(lambda (cc) ;cc is the calling continuation
(let loop ((cc cc)(state 0))
(printf "--doing stuff state:~A~N" state)
(loop (call/cc cc)(+ state 1))))) ;this is where the exit hapens
(thread-2
(lambda (data) ;returns the procedure to be used as
(lambda (cc) ;thread with data bound
(let loop ((cc cc)(data data)(state 0))
(printf "--doing other stuff state:~A~N" state)
(loop (call/cc cc)(update data)(+ state 1)))))))
(let main ((cur thread-1)(idle (thread-2 '()))(state 0))
(printf "doing main stuff state:~A~N" state)
(if (< state 6)
(main (call/cc idle) cur (+ state 1)))))
Which outputs
doing main stuff state:0
--doing other stuff state:0
doing main stuff state:1
--doing stuff state:0
doing main stuff state:2
--doing other stuff state:1
doing main stuff state:3
--doing stuff state:1
doing main stuff state:4
--doing other stuff state:2
doing main stuff state:5
--doing stuff state:2
doing main stuff state:6