I wrote down this iterative code in LISP using the loop function:
(defun loadfile (filename)
(with-open-file (stream filename)
(loop for line = (read-line stream nil 'eof)
until (eq line 'eof)
collect line)))
)
)
Is there a way to rewrite it without loop, in a recursive way?
Surprise them with a GOTO instead:
(defun loadfile (filename)
(with-open-file (stream filename)
(prog (line lines)
repeat
(setf line (read-line stream nil))
(when line
(push line lines)
(go repeat))
(return (reverse lines)))))
Of course any loop can be transformed in recursion, but reading an entire file a line at time, is, however, a typical iterative process, so I find this question difficult to motivate.
Here is a possible recursive version, where the recursion is managed by an internal function:
(defun load-file (filename)
(with-open-file (stream filename)
(labels ((read-recursively ()
(let ((line (read-line stream nil 'eof)))
(if (eq line 'eof)
nil
(cons line (read-recursively))))))
(read-recursively))))
This solution is prone to a stack-overflow error if the number of rows of the file is big.
If one has a compiler which can perform tail optimization, the following alternative recursive solution could be compiled in iterative fashion and could avoid the stack-overflow:
(defun load-file (filename)
(with-open-file (stream filename)
(labels ((read-recursively (read-so-far)
(let ((line (read-line stream nil 'eof)))
(if (eq line 'eof)
(reverse read-so-far)
(read-recursively (cons line read-so-far))))))
(read-recursively ()))))
Related
So I'm attempting to implement a Caesar cipher in LISP recursively, and I've got the basic functionality working. The problem is it returns a list of characters, and calling concatenate 'string on the return statement just returns the same list of characters plus a "". What am I doing wrong here?
(defun caesar (s n)
(if (null (concatenate 'list s))
'()
(cons
(code-char (+ n (char-code (car (concatenate 'list s)))))
(caesar (coerce (cdr (concatenate 'list s)) 'string) n)
)
)
)
The right approach to something like this is to do the conversion between string & list in a wrapper of some kind & then have the main function work on the list.
Here is an approach to doing that which uses some of the power and elegance of CL. This:
uses CLOS methods to do wrapping -- this will presumably make it ineligible for submission as homework, in case that is what it is, but is a good demonstration of how pretty CLOS can be I think, and is also how I would actually write something like this;
uses coerce in the wrapper method rather than concatenate to change types, since that's what it's for;
intentionally does not deal with some of the other problems of the original code around recursion & char-codes.
First of all here is a version which uses two methods: a wrapper method (defined in the generic function definition for convenience) and then the recursive method which does the work:
(defgeneric caesar (text n)
(:method ((text string) n)
;; if we're given a string just turn it into a list, then recurse
;; on the list & turn it back to a string (of the same type, hence
;; TYPE-OF).
(coerce (caesar (coerce text 'list) n) (type-of text))))
(defmethod caesar ((text list) n)
;; The recursive level (note this has various issues which are in
;; the original code & not addressed here
(if (null text)
'()
(cons (code-char (+ n (char-code (first text))))
(caesar (rest text) n))))
Secondly here is a slightly too-clever approach, using a special termination-on-null method. I would not recommend this, but it's a neat demonstration of the kind of thing CLOS can do.
(defgeneric caesar (text n)
(:method ((text string) n)
;; if we're given a string just turn it into a list, then recurse
;; on the list & turn it back to a string (of the same type, hence
;; TYPE-OF).
(coerce (caesar (coerce text 'list) n) (type-of text))))
(defmethod caesar ((text null) n)
;; termination
'())
(defmethod caesar ((text list) n)
;; The recursive level (note this has various issues which are in
;; the original code & not addressed here
(cons (code-char (+ n (char-code (first text))))
(caesar (rest text) n)))
I would be tempted to combine with-output-to-string and labels (for the recursive bit):
(defun caesar (s n)
(with-output-to-string (cipher)
(labels ((beef (s)
(when s
(princ <whatever> cipher)
(beef (rest s)))))
(beef (coerce s 'list)))))
Caveat: the above is thoroughly untested and simply typed into this message, so likely will not even compile. It just makes the suggestions more cncrete.
When working in a top level REPL, I sometimes forget what definitions I've entered into the running lisp system.
I use Clozure CL and it provides the option of saving the application as an image, which I do and can continue where I left off, but at this point it becomes impossible to review all the code, unless I had separately typed and saved the code to xyz file already.
Is there a way to get/extract/view the definitions that I entered, so I can save them as a source file?
The following will extract all the function definitions entered in a package:
(defun get-all-symbols (&optional package)
(let ((lst nil)
(package (find-package package)) )
(do-all-symbols (s lst)
(when (fboundp s)
(unless (and package (not (eql (symbol-package s) package)))
(push (cons s (function-lambda-expression s)) lst) )))))
Try something like:
(get-all-symbols *package*)
Common Lisp (in general) does not provide any standard way to “recover” the source code of a definition once it has been compiled. Normally, it's found in whatever file or buffer you're working-from.
(As Leo's answer points out, there is Function-Lambda-Expression, which can give you some function definitions. It won't help with, say, constants or classes, and it won't always work — as CLHS says, “Any implementation may legitimately return nil as the lambda-expression of any function.” http://clhs.lisp.se/Body/f_fn_lam.htm — his solution is certainly useful in the most common case(s), but it is not “as general” as this one.)
You could use a set of “wrapper” macros which store the forms you pass to them in a global hash-table, and then recover the source from that. Writing that sounded like an interesting little challenge, so the below is my attempt to do something like that.
My Silly Wrappers Solution
Note that the “source” forms stashed in this way won't preserve reader macros, comments, or the like, and will probably choke on some things like defmethod in subtly horrible ways. That's because I blindly store the definitions keyed off the defining form — eg, defun — and the second word, only. It's not smart enough to notice if you rebound a function as a macro or generic function (all three conflicting definitions would be saved), it doesn't read method combinations or lambda lists to save various methods, or any of that. There are lots of other things you might do — eg, (SetF (FDefinition 'FOO) …) — that could bypass these and go unnoticed, so it's far from “foolproof.” Caveat Lector.
The macros here try to inherit the documentation and lambda lists from the underlying forms, so they should work pretty nicely with most IDE's. They do well enough, in Slime.
One way to work with these would be to directly call them; eg, in your REPL you could directly
My-Package> (use-package :wrap-defining-form)
My-Package> (defun$ my-fn (x) (+ x (sqrt x)))
A more dangerous/interesting way is provided in the package Wrap-Defining-Form.Shadowing, in which the macros shadow the real Common-Lisp package definitions …
CL-User> (in-package :CL-USER$)
CL-User$> (defun blah (n) (loop repeat n do (format t "~&Blah …")))
When you're ready to “save” things, run (dump-definitions).
I wrote and tested this in SBCL, but tried to take care that it should work on many/most other implementations. In particular, I used one non-ANSI function: SB-Introspect:Function-Lambda-List. The function here Wrap-Defining-Form::Find-Function-Lambda-List will search all packages for your implementation's version of that function. If it can't find one, all is not lost; but you won't get hints from your IDE about the lambda-list of the wrapped function. (Clozure's seems to work — kinda — for functions, but not macros. That can probably be improved.)
CL-USER> (describe 'defun$)
WRAP-DEFINING-FORM:DEFUN$
[symbol]
DEFUN$ names a macro:
Lambda-list: (NAME LAMBDA-LIST &BODY BODY)
Documentation:
Wrap `DEFUN' and save the original form.
DEFUN: Define a function at top level.
Source file: /home/brpocock/Private/wrap-defining-form.lisp
; No value
Without Function-Lambda-List, the wrapper looks like
Lambda-list: (&REST UNKNOWN-LAMBDA-LIST)
… which is not very helpful.
wrap-defining-form.lisp
EDIT: Debugged in Clozure. Posted to https://github.com/brpocock/wrap-defining-forms also.
;;;; Wrap--Defining-Forms
;;; -*- Lisp -*-
(defpackage wrap-defining-forms
(:use :common-lisp)
(:documentation "Wrap defining forms so that they (try to) save the
source code of the definition being passed.")
(:export #:wrap-defining-form #:dump-definitions
#:defclass$
#:defconstant$
#:defgeneric$
#:define-compiler-macro$
#:define-condition$
#:define-method-combination$
#:define-modify-macro$
#:define-setf-expander$
#:define-symbol-macro$
#:defmacro$
#:defmethod$
#:defpackage$
#:defparameter$
#:defsetf$
#:defstruct$
#:deftype$
#:defun$
#:defvar$))
(defpackage wrap-defining-forms.shadowing
(:documentation "Wrapped forms like DEFUN$ are exported here with the
names of the forms that they wrap, like DEFUN, for
shadowing imports.")
(:export #:defclass
#:defconstant
#:defgeneric
#:define-compiler-macro
#:define-condition
#:define-method-combination
#:define-modify-macro
#:define-setf-expander
#:define-symbol-macro
#:defmacro
#:defmethod
#:defpackage
#:defparameter
#:defsetf
#:defstruct
#:deftype
#:defun
#:defvar)
(:use))
;; Clozure appears to be “smart” and adds Common-Lisp even though we
;; didn't ask for it (and explicily don't want it)
#+ccl (unuse-package '(:ccl :common-lisp)
:wrap-defining-forms.shadowing)
(defpackage :common-lisp-user/save-defs
(:nicknames :cl-user$)
(:use :common-lisp :common-lisp-user)
(:import-from :wrap-defining-forms #:dump-definitions)
(:shadowing-import-from :wrap-defining-forms.shadowing
#:defclass
#:defconstant
#:defgeneric
#:define-compiler-macro
#:define-condition
#:define-method-combination
#:define-modify-macro
#:define-setf-expander
#:define-symbol-macro
#:defmacro
#:defmethod
#:defpackage
#:defparameter
#:defsetf
#:defstruct
#:deftype
#:defun
#:defvar))
;; Clone any other functions you may have packed into CL-User.
(with-package-iterator (next-symbol :common-lisp-user :internal)
(loop for symbol = (next-symbol)
while symbol
for sibling = (intern (symbol-name symbol) (find-package :cl-user$))
when (and (fboundp symbol)
(not (fboundp sibling)))
do (setf (fdefinition sibling) (fdefinition symbol))))
(in-package "WRAP-DEFINING-FORMS")
(defvar *definitions* (make-hash-table)
"Copies of forms defined by the wrappers created by
`WRAP-DEFINING-FORM' which can be stashed with `DUMP-DEFINITIONS'")
#+ccl
(defun ccl-mock-lambda-list (function)
(if (macro-function function)
(list '&rest 'macro-lambda-list)
(multiple-value-bind (required optional restp
keywords)
(ccl:function-args (fdefinition function))
(concatenate ' list
(loop repeat required
collect (gensym "ARG-"))
(when (and optional (plusp optional))
(cons '&optional
(loop repeat optional
collect (gensym "OPT-"))))
(when restp
(list '&rest 'rest))
(when (and keywords (plusp keywords))
(list '&key '&allow-other-keys))))))
(defun find-function-lambda-list ()
"Find the implementation's version of `FUNCTION-LAMBDA-LIST' if there
is one. That way, Slime and friends can still give the proper
lambda-list for the wrapped form. If it can't be found, this will
return a stub with just a &rest-var."
(or
#+sbcl #'sb-introspect:function-lambda-list
#+ccl #'ccl-mock-lambda-list
#-(or ccl sbcl)
(dolist (package (list-all-packages))
(let ((sym (find-symbol "FUNCTION-LAMBDA-LIST" package)))
(when (fboundp sym)
(return-from find-function-lambda-list sym))))
(lambda (function)
(declare (ignore function))
(list '&rest 'unknown-lambda-list))))
(defmacro wrap-defining-form (cl-form)
"Assuming that CL-FORM is a symbol for a macro or function which
defines something interesting (eg, “Defun”), this will create a macro
with the same name with a trailing “$” that will save the source tree
before passing on the form to CL-FORM.
EG: (wrap-defining-form defun) provides a “defun$” which has the
additional side effect of storing the source form in *DEFINITIONS*.
Definitions saved can be recovered by `DUMP-DEFINITIONS'.
This is not industrial-strength; in particular, I expect it to cope
poorly with DEFMETHOD."
(check-type cl-form symbol)
(let ((wrapper (intern (concatenate 'string (symbol-name cl-form) "$")))
(wrapper.shadow (intern (symbol-name cl-form) :wrap-defining-forms.shadowing))
(wrapped-lambda-list (funcall (find-function-lambda-list) 'defun)))
(setf (gethash cl-form *definitions*) (make-hash-table))
`(prog1
(defmacro ,wrapper (&whole whole ,#wrapped-lambda-list)
(declare (ignore ,#(remove-if (lambda (form) (member form lambda-list-keywords))
wrapped-lambda-list)))
,(concatenate 'string "Wrap `" (symbol-name cl-form) "' and save the original form." #(#\newline #\newline)
(symbol-name cl-form) ": " (or (documentation cl-form 'function)
"(see CLHS; no documentation here)"))
(let ((defined (cons ',cl-form (cdr whole))))
(setf (gethash (second whole) (gethash ',cl-form *definitions*))
defined)
defined))
(defmacro ,wrapper.shadow (&whole whole ,#wrapped-lambda-list)
(declare (ignore ,#(remove-if (lambda (form) (member form lambda-list-keywords))
wrapped-lambda-list)))
,(concatenate 'string "Wrap `COMMON-LISP:" (symbol-name cl-form) "' and save the original form."
#(#\newline #\newline)
(symbol-name cl-form) ": " (or (documentation cl-form 'function)
"(see CLHS; no documentation here)"))
(let ((defined (cons ',cl-form (cdr whole))))
(setf (gethash (second whole) (gethash ',cl-form *definitions*))
defined)
defined)))))
(wrap-defining-form defclass)
(wrap-defining-form defconstant)
(wrap-defining-form defgeneric)
(wrap-defining-form define-compiler-macro)
(wrap-defining-form define-condition)
(wrap-defining-form define-method-combination)
(wrap-defining-form define-modify-macro)
(wrap-defining-form define-setf-expander)
(wrap-defining-form define-symbol-macro)
(wrap-defining-form defmacro)
(wrap-defining-form defmethod)
(wrap-defining-form defpackage)
(wrap-defining-form defparameter)
(wrap-defining-form defsetf)
(wrap-defining-form defstruct)
(wrap-defining-form deftype)
(wrap-defining-form defun)
(wrap-defining-form defvar)
(defun dump-definitions (&optional pathname)
"Write out the definitions saved by `WRAP-DEFINING-FORM'-built
wrappers to PATHNAME (or *STANDARD-OUTPUT*)."
(let (output
(*print-case* :capitalize)
;; If writing to file, set margin at 79, but try to keep things under 72.
(*print-right-margin* (if pathname 79 *print-right-margin*))
(*print-miser-width* (if pathname 72 *print-miser-width*)))
(unwind-protect
(progn (setq output (if pathname
(open pathname :direction :output
:if-exists :rename
:if-does-not-exist :create)
*standard-output*))
(multiple-value-bind (sec min hr d m y) (decode-universal-time (get-universal-time))
(declare (ignore sec))
(format output
"~&~|~%;;; definitions as of ~d-~d-~d # ~d:~2,'0d:
\(In-Package #:~a)
~{~{~2%~:<~W ~#_~:I~W ~:_~W~1I ~_~W~:>~}~^~|~}~%~|~%" ; from CLHS 22.2.2 SIMPLE-PPRINT-DEFUN
y m d hr min
(package-name *package*)
(remove-if #'null
(loop for form being the hash-keys of *definitions*
for defs = (gethash form *definitions*)
collect (loop for definition being the hash-values of defs
collect definition))))))
(when output (ignore-errors (close output))))))
Sample Usage
CL-USER> (load "wrap-defining-form.lisp")
T
CL-USER> (use-package :wrap-defining-form)
T
CL-USER> (defun$ trash-word (word)
(let ((s (string word)))
(sort (remove-if-not #'alpha-char-p s) #'char<)))
WARNING: redefining COMMON-LISP-USER::TRASH-WORD in DEFUN
TRASH-WORD
CL-USER> (trash-word 'Blatherscythe)
"ABCEEHHLRSTTY"
CL-USER> (describe 'trash-word)
COMMON-LISP-USER::TRASH-WORD
[symbol]
TRASH-WORD names a compiled function:
Lambda-list: (WORD)
Derived type: (FUNCTION (T) (VALUES SEQUENCE &OPTIONAL))
Source form:
(SB-INT:NAMED-LAMBDA TRASH-WORD
(WORD)
(BLOCK TRASH-WORD
(LET ((S (STRING WORD)))
(SORT (REMOVE-IF-NOT #'ALPHA-CHAR-P S) #'CHAR<))))
; No value
CL-USER> (macroexpand-1 '(defun$ trash-word (word)
(let ((s (string word)))
(sort (remove-if-not #'alpha-char-p s) #'char<))))
(DEFUN TRASH-WORD (WORD)
(LET ((S (STRING WORD)))
(SORT (REMOVE-IF-NOT #'ALPHA-CHAR-P S) #'CHAR<)))
T
CL-USER> (dump-definitions)
;;; definitions as of 2016-12-1 # 15:23:
(In-Package #:COMMON-LISP-USER)
(Defun Trash-Word (Word)
(Let ((S (String Word)))
(Sort (Remove-If-Not #'Alpha-Char-P S) #'Char<)))
NIL
CL-USER> (in-package :Common-Lisp-User/Save-Defs)
#<PACKAGE "COMMON-LISP-USER/SAVE-DEFS">
CL-USER$> (defun 2+ (n) (+ 2 n))
2+
CL-USER$> (describe '2+)
COMMON-LISP-USER/SAVE-DEFS::2+
[symbol]
2+ names a compiled function:
Lambda-list: (N)
Derived type: (FUNCTION (T) (VALUES NUMBER &OPTIONAL))
Source form:
(SB-INT:NAMED-LAMBDA 2+
(N)
(BLOCK 2+ (+ 2 N)))
; No value
CL-USER$> (macroexpand-1 '(defun 2+ (n) (+ 2 n)))
(COMMON-LISP:DEFUN 2+ (N) (+ 2 N))
T
CL-USER$> (documentation 'defun 'function)
"Wrap `COMMON-LISP:DEFUN' and save the original form.
DEFUN: Define a function at top level."
CL-USER$> (dump-definitions)
;;; definitions as of 2016-12-1 # 15:32:
(In-Package #:COMMON-LISP-USER/SAVE-DEFS)
(Common-Lisp:Defun 2+ (N) (+ 2 N))
(Common-Lisp:Defun Trash-Word (Word)
(Let ((S (String Word)))
(Sort (Remove-If-Not #'Alpha-Char-P S) #'Char<)))
NIL
File Backup
Dump-Definitions also will write to a file. (It sets :If-Exists :Rename, so you could have one-level-UNDO protection as well.)
CL-USER$> (dump-definitions "saved.lisp")
NIL
Here is an interactive session with CCL:
? (declaim (optimize (debug 3)))
NIL
The above is not strictly required here, but it doesn't hurt to develop with high debugging levels.
? (defun foo (x) (+ 3 x))
FOO
? (inspect 'foo)
[0] FOO
[1] Type: SYMBOL
[2] Class: #<BUILT-IN-CLASS SYMBOL>
Function
[3] INTERNAL in package: #<Package "COMMON-LISP-USER">
[4] Print name: "FOO"
[5] Value: #<Unbound>
[6] Function: #<Compiled-function FOO #x3020004B3F7F>
[7] Arglist: (X)
[8] Plist: NIL
Inspect> 6
[0] #<Compiled-function FOO #x3020004B3F7F>
[1] Name: FOO
[2] Arglist (analysis): (X)
[3] Bits: 8388864
[4] Plist: (CCL::PC-SOURCE-MAP #(17 70 15 22) CCL::FUNCTION-SYMBOL-MAP
(#(X) . #(63 17 70)) CCL::%FUNCTION-SOURCE-NOTE ...)
[5] Source Location: #<SOURCE-NOTE Interactive "(defun foo (x) (+ 3 x))">
Inspect 1> 5
[0] #<SOURCE-NOTE Interactive "(defun foo (x) (+ 3 x))">
[1] Type: SOURCE-NOTE
[2] Class: #<STRUCTURE-CLASS SOURCE-NOTE>
[3] SOURCE: #(40 100 101 102 117 ...)
[4] FILENAME: NIL
[5] FILE-RANGE: 23
You can see that even from within the REPL, and without running Slime which might also store information about the Emacs environment, you can have access to the source code of FOO. This can be used if you know which function you want to recover. For a recording of your interactive session, follow jkiiski's advice about DRIBBLE.
Perhaps you can easily implement something like this yourself:
(defun my-repl (&optional (file-path "cl-history.lisp"))
"Saves commands to a file"
(loop
(with-open-file (stream file-path
:direction :output
:if-does-not-exist :create
:if-exists :append)
(print '>)
(let ((input (read)))
(format stream "~A~%" input)
(print (eval input))))))
To exit the inner loop you should type (quit).
Alternatively you can use com.informatimago.common-lisp.interactive.interactive:repl
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.
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
I have a file (furniture.lisp) that looks basically like this (with many more entries):
(addgv :furniture 'stove
(make-instance 'stove
:pose (tf:make-pose-stamped
"map" ; frame-id
0.0
(tf:make-3d-vector -3.1 -0.9 0) ; translation/origin
(tf:euler->quaternion :az 0))))
(addgv :furniture 'drawers-cupboard
(make-instance 'cupboard
:pose (tf:make-pose-stamped
"map"
0.0
(tf:make-3d-vector -3.1 0.1 0)
(tf:euler->quaternion :az 0))))
Now, I'd like to have a function (get-locations "furniture.lisp" "locations.txt") that extracts the objects coordinates in the 3d-vector and writes its output to a file:
(location stove -3.1 -0.9 9)
(location drawers-cupboard -3.1 0.1 0)
...
I started by writing an expression that reads in the file (so far without parametrization) line by line:
(ql:quickload "split-sequence")
(with-open-file (stream "furniture.lisp")
(do ((line (read-line stream nil)
(read-line stream nil)))
((null line))
(princ (split-sequence::split-sequence #\Space line)) ; Just for demonstration
))
But I realized that I have no chance/idea to "connect" the name of the object (e.g. stove) and its coordinates. I'd need the second symbol after "(addgv " for the name and variable "distance of words" for the coordinates. So I tried to read the file into one big list:
(defun make-list-from-text (fn)
(with-open-file (stream fn)
(loop for line = (read-line stream nil nil)
while line
collect
(split-sequence::split-sequence #\Space line))))
Whereby every line is a sublist (I don't know if this substructure is a advantage, perhaps I should 'flatten' the result). Now I'm stuck. Furthermore, I have the feeling, that my approach is somehow inelegant.
EDIT:
I followed Svante's approach and finally got the desired output! Besides creating a dummy package, I also had to create dummy exports for the package (e.g. :export :make-3d-vector). Additionally,:key #'car did not work, as my list was a 'mixed' list, consisting of sublists (e.g. (make-instance ...)) and symbols (e.g. addgv). So I created a helper function:
(defun find-helper (list-or-symbol)
(if (listp list-or-symbol)
(car list-or-symbol)
list-or-symbol))
And replaced #'car by #'find-helper.
My idea would be to create a dummy tf package, then read the forms and parse whatever you need from them. Something like this (untested):
(eval-when (:compile-toplevel :load-toplevel :execute)
(unless (find-package #:tf)
(defpackage #:tf)))
(defun extract-location-file ()
(let ((*read-eval* nil))
(with-open-file (in "furniture.lisp")
(with-open-file (out "locations.txt"
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(loop :for form := (read in nil)
:while form
:do (print (extract-location form) out)
(terpri)))))
(defun extract-location (form)
`(location ,(third form)
,#(rest (find 'tf::make-3d-vector
(find 'tf::make-pose-stamped
(find 'make-instance
form
:key #'car)
:key #'car)
:key #'car))))
Be sure not to omit to bind *read-eval* to nil.
The general way would be:
read the whole file as string (see here)
(cl-ppcre:regex-replace-all "tf::?" content ""), i.e. replace all references to package tf to avoid package-related errors
put '() around the contents
read it and assign to a variable
now you have structured data that you can process using various list-manipulating functions
Unfortunately this would be a non-portable solution:
handle the reader error
do what is necessary to fix the problem
continue
For example in LispWorks I could do something like this (just a sketch):
CL-USER 60 > (defun test ()
(handler-bind ((conditions:package-not-found-reader
(lambda (c)
(continue c)))
(conditions:simple-reader-error
(lambda (c)
(continue c))))
(read-from-string "'(foo27:bar19 bar18:foo44)")))
TEST
CL-USER 61 > (test)
(QUOTE (FOO27::BAR19 BAR18::FOO44))
It calls the continue restarts for the missing package error and then for the error that the symbol is not exported. The restarts create the package and the other one is returning a non-exported symbol...