Infinite recursion in doubly linked list implementation - common-lisp

I am trying to implement a queue as a doubly linked list. However, the enqueue function goes into infinite recursion when I try to enqueue a second node, I can't seem to figure out what's causing it.
(defstruct node
value
(next nil)
(previous nil))
(defstruct (queue (:print-function print-queue))
(first nil)
(last nil))
(defun print-queue (queue s d)
(do ((node (queue-first queue) (node-next node)))
((null node) (format s "~%"))
(format s "~A " (node-value node))))
(defun enqueue (data queue)
(let ((node (make-node :value data)))
(if (null (queue-first queue))
(setf (queue-first queue) node (queue-last queue) node)
(setf (node-previous node) (queue-last queue)
(node-next (queue-last queue)) node
(queue-last queue) node))))
EDIT: Problematic test case
(setf queue (make-queue))
(enqueue 3 queue)
(enqueue 4 queue) ; this call never terminates and blows up the stack
The last statement on CLISP causes a
* - Program stack overflow. RESET
on SBCL it just goes into an infinite loop and I have to exit SBCL

Well, you still haven't really looked at the error. ;-)
If you use SBCL:
0] backtrace
...
11898: (SB-KERNEL::%DEFAULT-STRUCTURE-PRETTY-PRINT #1=#S(NODE :VALUE 4 :NEXT NIL :PREVIOUS #S(NODE :VALUE 3 :NEXT #1# :PREVIOUS NIL)) #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDOUT* {10001ACA23}>)
11899: ((LABELS SB-IMPL::HANDLE-IT :IN SB-KERNEL:OUTPUT-OBJECT) #<SYNONYM-STREAM :SYMBOL SB-SYS:*STDOUT* {10001ACA23}>)
11900: (PRIN1 #1=#S(NODE :VALUE 4 :NEXT NIL :PREVIOUS #S(NODE :VALUE 3 :NEXT #1# :PREVIOUS NIL)) NIL)
11901: (SB-IMPL::REPL-FUN NIL)
11902: ((LAMBDA NIL :IN SB-IMPL::TOPLEVEL-REPL))
11903: (SB-IMPL::%WITH-REBOUND-IO-SYNTAX #<CLOSURE (LAMBDA NIL :IN SB-IMPL::TOPLEVEL-REPL) {1002ACB00B}>)
11904: (SB-IMPL::TOPLEVEL-REPL NIL)
11905: (SB-IMPL::TOPLEVEL-INIT)
11906: ((FLET #:WITHOUT-INTERRUPTS-BODY-58 :IN SAVE-LISP-AND-DIE))
11907: ((LABELS SB-IMPL::RESTART-LISP :IN SAVE-LISP-AND-DIE))
It's not your function which causes this.
As you can see the error happens in printing the result. You see in the backtrace that the function PRIN1 is used to print a node structure. Your function already returned a result, which now needs to be printed in the REPL.
Your function returns a circular data structure and Lisp tries to print it. Then it goes into an infinite loop.
You need to tell Lisp, that it should deal with circular data structures in the printer.
Use
(setf *print-circle* t)
and try again.
A bit style guide:
generally use CLOS classes instead of structures
provide a custom printer for each structure, especially those with circularities
return meaningful results from functions

Related

Accessing an encapsulated class slots within the encapsulating class method in common lisp

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.

Why is lisp saying this parameter is not a list?

I am working through the MP3 database example in Peter Seibel's Practical Common Lisp. Seibel demonstrates how macros can be used to shorten the code for the where function; so now, I am trying to use a macro to shorten the code for the update function. (The original version of the update function is included for reference.) When I run my code, the following error originates from the second-to-last line --
*** - CAR: TERMS is not a list
What am I doing wrong? Here is my code.
(defvar *db* nil)
(defun add-record (cd)
(push cd *db*))
(defun dump-db ()
(dolist (cd *db*)
(format t "~{~a:~10t~a~%~}~%" cd)))
(defun make-cd (title artist rating ripped)
(list :title title :artist artist :rating rating :ripped ripped))
(defun prompt-read (prompt)
(format *query-io* "~a: " prompt)
(force-output *query-io*)
(read-line *query-io*))
(defun prompt-for-cd ()
(make-cd
(prompt-read "Title")
(prompt-read "Artist")
(or (parse-integer (prompt-read "Rating") :junk-allowed t) 0)
(y-or-n-p "Ripped [y/n]: ")))
(defun add-cds ()
(loop (add-record (prompt-for-cd) )
(if (not (y-or-n-p "Another? [y/n]: ")) (return) )))
(defun save-db (filename)
(with-open-file (out filename
:direction :output
:if-exists :supersede)
(with-standard-io-syntax
(print *db* out))))
(defun load-db (filename)
(with-open-file (in filename)
(with-standard-io-syntax
(setf *db* (read in) ))))
(defun select (selector-fn)
(remove-if-not selector-fn *db*))
(defun make-comparison-expr (field value)
`(equal (getf cd ,field) ,value))
(defun make-comparison-list (func fields)
(loop while fields
collecting (funcall func (pop fields) (pop fields))))
(defmacro where (&rest clauses)
`#'(lambda (cd) (and ,#(make-comparison-list 'make-comparison-expr clauses))))
(defun make-update-expr (field value)
`(setf (getf row ,field) ,value))
(defmacro make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defun update (selector-fn &rest terms)
(print (type-of terms))
(setf *db*
(mapcar
#'(lambda (row)
(when (funcall selector-fn row)
(make-update-list terms))
row)
*db*)))
;(defun update (selector-fn &key title artist rating (ripped nil ripped-p))
; (setf *db*
; (mapcar
; #'(lambda (row)
; (when (funcall selector-fn row)
; (if title (setf (getf row :title) title) )
; (if artist (setf (getf row :artist) artist) )
; (if rating (setf (getf row :rating) rating) )
; (if ripped-p (setf (getf row :ripped) ripped) ))
; row)
; *db*)))
(defun delete-rows (selector-fn)
(setf *db* (remove-if selector-fn *db*)))
;(loop (print (eval (read))))
(add-record (make-cd "Be" "Common" 9 nil))
(add-record (make-cd "Like Water for Chocolate" "Common" 9 nil))
(add-record (make-cd "Be" "Beatles" 9 nil))
(dump-db)
(update (where :artist "Common" :title "Be") :rating 8)
(dump-db)
-----Edit-----
I figured it out. The solution was to make update a macro and to make make-update-list a function. This way, make-update-list could evaluate fields at run-time and update can still abstract away some tedious if statements. Here is the updated update and make-update-list below:
(defun make-update-list (fields)
(make-comparison-list 'make-update-expr fields))
(defmacro update (selector-fn &rest terms)
`(setf *db*
(mapcar
#'(lambda (row)
(when (funcall ,selector-fn row)
,#(make-update-list terms))
row)
*db*)))
Macroexpansion of that make-update-list is done in a separate phase (called "macroexpansion phase") - which occurs around the time a piece of code is compiled or loaded; in this case we're talking about compilation / loading of update. The macro gets expanded with fields bound to the symbol terms, which (the symbol itself) is used as a value in make-comparison-list; I suppose that was not what you expected.
Note, if you go and compile the file line-by-line (C-c C-c in Emacs + SLIME), it'll tell you right during compilation of update that the macro expansion fails because "the value TERMS is not of type LIST".
Generally, think of macros as functions that take in their arguments unevaluated - i.e. a form (make-update-list foo) will get expanded with the macro parameter's fields value bound to foo. What you're trying to achieve here - code generation based on run-time values - is a bit more difficult to do.
You are trying to take the car of a symbol!
> (car 'terms)
*** - CAR: TERMS is not a list
Think of macros as a function that, when used, replaces the code with the result of the macro function everywhere it's used. At this time variables are just symbols and have no meaning besides that.
When you do (make-update-list terms) it will call the macro function with the argument fields being the symbol you passed, which is terms. Since it's a symbol it cannot be iterated like you are trying. You may iterate it at runtime when it surely is a list, but as a macro it isn't a list until you are passing it a list like (make-update-list (title artist rating ripped)).
If it is dynamic in runtime then your macro needs to expand to code that does most of its magic at runtime. Thus a macro is just a source rewriting service and should not have anything to do with what variable might be at runtime since then it has already done its thing.

Override function value with asynchronous call

How can I use cl-letf or similar to override a symbol's function value during an async call? I want to stop a buffer being displayed after calls to start-process or start-process-shell-command, and instead get back a string instead.
Here is a simplified example where binding display-buffer works for the synchronous version but not the async version. Also, I have set lexical-binding to true.
(defun tst-fun-sync (url)
(call-process "wget" nil "*wget*" nil url "-O" "-")
(with-current-buffer "*wget*"
(display-buffer (current-buffer))))
(defun tst-fun-async (url)
(set-process-sentinel
(start-process "wget" "*wget*" "wget" url "-O" "-")
#'(lambda (p _m)
(when (zerop (process-exit-status p))
(with-current-buffer (process-buffer p)
(display-buffer (current-buffer)))))))
(defun tst-fun-no-display (fun &rest args)
(cl-letf (((symbol-function 'display-buffer)
#'(lambda (&rest _ignored)
(message "%s" (buffer-string)))))
(apply fun args)))
;; The first has desired result, but not the second
;; (tst-fun-no-display 'tst-fun-sync "http://www.stackoverflow.com")
;; (tst-fun-no-display 'tst-fun-async "http://www.stackoverflow.com")
Let's define a macro which temporarily rebinds set-process-sentinel so that the sentinel function can be decorated with a wrapper function.
(defmacro with-sentinel-wrapper (wrapper-fn &rest body)
(let ((sps (gensym))
(proc (gensym))
(fn (gensym)))
`(let ((,sps (symbol-function 'set-process-sentinel)))
(cl-letf (((symbol-function 'set-process-sentinel)
(lambda (,proc ,fn)
(funcall ,sps ,proc (funcall ,wrapper-fn ,fn)))))
,#body))))
The wrapper can change the dynamic context in which the sentinel is called, by establishing any useful dynamic bindings. Here, I reuse your cl-letf to change what display does:
(with-sentinel-wrapper (lambda (fn)
(lexical-let ((fun fn))
(lambda (p m)
(cl-letf (((symbol-function 'display-buffer)
#'(lambda (&rest _ignored)
(message "%s" (buffer-string)))))
(funcall fun p m)))))
(tst-fun-async "http://www.stackoverflow.com"))
Now, if you aren't sure that the asynchronous process actually calls set-process-sentinel, you may have to hack other functions.

Echo server in common lisp with cl-usocket

I am trying a simple echo server in common lisp (I use clisp). I've tried the example in http://rosettacode.org/wiki/Echo_server#Common_Lisp
The CLISP version (without usocket) works fine.
When I try the usocket version (with clisp) I get the following error:
* - The condition
CDR: :INPUT is not a list
occurred.
Thank you in advance for your replies,
Dimitris
I'm not sure of the answer, but I think this can be tracked down to wait-for-input and wait-for-input-internal. The function wait-for-input has the following definition (abbreviated):
(defun wait-for-input (socket-or-sockets &key timeout ready-only)
"Waits for one or more streams to become ready for reading from
the socket. When `timeout' (a non-negative real number) is
specified, wait `timeout' seconds, or wait indefinitely when
it isn't specified. A `timeout' value of 0 (zero) means polling. …"
(unless (wait-list-p socket-or-sockets)
(let ((wl (make-wait-list (if (listp socket-or-sockets)
socket-or-sockets (list socket-or-sockets)))))
(multiple-value-bind
(socks to)
(wait-for-input wl :timeout timeout :ready-only ready-only)
(return-from wait-for-input
(values (if ready-only socks socket-or-sockets) to)))))
(let* ((start (get-internal-real-time))
(sockets-ready 0))
(dolist (x (wait-list-waiters socket-or-sockets))
(when (setf (state x)
#+(and win32 (or sbcl ecl)) nil ; they cannot rely on LISTEN
#-(and win32 (or sbcl ecl))
(if (and (stream-usocket-p x)
(listen (socket-stream x)))
:read
nil))
(incf sockets-ready)))
;; the internal routine is responsibe for
;; making sure the wait doesn't block on socket-streams of
;; which theready- socket isn't ready, but there's space left in the
;; buffer
(wait-for-input-internal socket-or-sockets
:timeout (if (zerop sockets-ready) timeout 0))
(let ((to-result (when timeout
(let ((elapsed (/ (- (get-internal-real-time) start)
internal-time-units-per-second)))
(when (< elapsed timeout)
(- timeout elapsed))))))
(values (if ready-only
(remove-if #'null (wait-list-waiters socket-or-sockets) :key #'state)
socket-or-sockets)
to-result))))
Note that the last section calls wait-for-input-internal with
(wait-for-input-internal socket-or-sockets
:timeout (if (zerop sockets-ready) timeout 0))
Now, the name socket-or-sockets implies that its value may be a single socket or a list of sockets. However, let's take a look at the definition of wait-for-input-internal for CLISP (it's defined in the backend/<implementation>.lisp):
(defmethod wait-for-input-internal (wait-list &key timeout)
(with-mapped-conditions ()
(multiple-value-bind
(secs musecs)
(split-timeout (or timeout 1))
(dolist (x (wait-list-%wait wait-list))
(setf (cdr x) :INPUT))
(let* ((request-list (wait-list-%wait wait-list))
(status-list (if timeout
(socket:socket-status request-list secs musecs)
(socket:socket-status request-list)))
(sockets (wait-list-waiters wait-list)))
(do* ((x (pop sockets) (pop sockets))
(y (cdr (pop status-list)) (cdr (pop status-list))))
((null x))
(when (member y '(T :INPUT))
(setf (state x) :READ)))
wait-list))))
There are two uses of :INPUT there. It appears that each element of the wait-list is supposed to be a cons whose cdr contains some sort of state. Perhaps wait-for-input is getting called with a single socket (after all, the argument name is socket-or-sockets, and when wait-for-input-internal is called, it's expecting a list. That could lead to the latter getting (<something> . :INPUT) when expecting ((<something . :INPUT)). I'm not sure, though. In any case, though, the error is coming from somewhere around here.

defining setf-expanders in Common Lisp

Here's the thing: I don't "get" setf-expanders and would like to learn how they work.
I need to learn how they work because I've got a problem which seems like a typical example for why you should learn setf-expanders, the problem is as follows:
(defparameter some-array (make-array 10))
(defun arr-index (index-string)
(aref some-array (parse-integer index-string))
(setf (arr-index "2") 7) ;; Error: undefined function (setf arr-index)
How do I write a proper setf-expander for ARR-INDEX?
(defun (setf arr-index) (new-value index-string)
(setf (aref some-array (parse-integer index-string))
new-value))
In Common Lisp a function name can not only be a symbol, but also a list of two symbols with SETF as the first symbol. See above. DEFUN thus can define SETF functions. The name of the function is (setf arr-index).
A setf function can be used in a place form: CLHS: Other compound forms as places.
The new value is the first argument then.
CL-USER 15 > some-array
#(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)
CL-USER 16 > (setf (arr-index "2") 7)
7
CL-USER 17 > some-array
#(NIL NIL 7 NIL NIL NIL NIL NIL NIL NIL)
Rainer's answer is spot on. Before ANSI Common Lisp, it was necessary to use defsetf to define an expander for simple places that could be set with a simple function call. setf functions like (setf arr-index) came into the language with CLOS and simplify a lot of things. In particular, setf functions can be generic.

Resources