This m4 script is intended to generate part of the argument parsing code for a shell script. Unfortunately, it does not produce the correct output:
#!/bin/m4
define(`HANDLE_CASE', ``-'substr($1,0,1)`|--'$1`) option='$1`; skip=1 ;;'')
define(`HANDLE_CASES', `ifelse(`$#'
,`0',``
-v|--version) showVersion; exit $? ;;
-h|--help) dispUsage 2>&1; exit $? ;;
--) break ;;
*) dispUsage; exit 1'',
`HANDLE_CASE($1)
HANDLE_CASES(shift($#))')')
HANDLE_CASES(timeout,delay,file)
Intended output:
-t|--timeout) option=timeout; skip=1 ;;
-d|--delay) option=delay; skip=1 ;;
-f|--file) option=file; skip=1 ;;
-h|--help) dispUsage 2>&1 ; exit $? ;;
-v|--version) showVersion; exit $? ;;
--) break ;;
*) dispUsage; exit 1
Actual output:
#!/bin/m4
-t|--timeout) option=timeout; skip=1 ;;
-d|--delay) option=delay; skip=1 ;;
-f|--file) option=file; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
-|--) option=; skip=1 ;;
or, in other words, infinite recursion ( The above program was piped to head -n 20 ).
How do I terminate the recursion?
Indentation is only for clarity...
#!/bin/m4
define(`HANDLE_CASE', `-substr($1,0,1)|--$1) option=$1; skip=1 ;;')
define(`HANDLE_CASES',
`ifelse(eval(`$# > 1'), `1', `
HANDLE_CASE($1)`'HANDLE_CASES(shift($#))', `
-v|--version) showVersion; exit $? ;;
-h|--help) dispUsage 2>&1; exit $? ;;
--) break ;;
*) dispUsage; exit 1')')
HANDLE_CASES(timeout,delay,file)
Related
I'm reading section 2.8 (Tail Recursion) in On Lisp. It has an example of a tail recursive function:
(defun our-length-tr (lst)
"tail recursive version with accumulator"
(labels ((rec (lst acc)
(if (null lst)
acc
(rec (cdr lst) (1+ acc)))))
(rec lst 0)))
It says that many Common Lisp compilers do TCO, but you may need (proclaim '(optimize speed)) at the top of your file.
How can I tell for certain that my compiler supports TCO, and that it will compile my function to a loop version rather than a recursive version?
There are a couple of simple ways of checking if a function is compiled with tail recursion or not.
If you can read assembly language then the primitive function disassemble (see the documentation) can be used, for instance:
* (disassemble 'our-length-tr)
; disassembly for OUR-LENGTH-TR
; Size: 89 bytes. Origin: #x10034F8434
; 34: 498B4C2460 MOV RCX, [R12+96] ; no-arg-parsing entry point
; thread.binding-stack-pointer
; 39: 48894DF8 MOV [RBP-8], RCX
; 3D: 488B4DF0 MOV RCX, [RBP-16]
; 41: 31D2 XOR EDX, EDX
; 43: EB3E JMP L2
; 45: 660F1F840000000000 NOP
; 4E: 6690 NOP
; 50: L0: 4881F917001020 CMP RCX, #x20100017 ; NIL
; 57: 7506 JNE L1
; 59: 488BE5 MOV RSP, RBP
; 5C: F8 CLC
; 5D: 5D POP RBP
; 5E: C3 RET
; 5F: L1: 8D41F9 LEA EAX, [RCX-7]
; 62: A80F TEST AL, 15
; 64: 751F JNE L3
; 66: 488B5901 MOV RBX, [RCX+1]
; 6A: 48895DE8 MOV [RBP-24], RBX
; 6E: BF02000000 MOV EDI, 2
; 73: 41BBF004B021 MOV R11D, #x21B004F0 ; GENERIC-+
; 79: 41FFD3 CALL R11
; 7C: 488B5DE8 MOV RBX, [RBP-24]
; 80: 488BCB MOV RCX, RBX
; 83: L2: EBCB JMP L0
; 85: L3: 0F0B0A BREAK 10 ; error trap
; 88: 2F BYTE #X2F ; OBJECT-NOT-LIST-ERROR
; 89: 08 BYTE #X08 ; RCX
; 8A: 0F0B10 BREAK 16 ; Invalid argument count trap
NIL
(SBCL 1.4.1 on Mac OS X 10.13.3)
Otherwise you can call the function with a very long list and see if the result is a Stack Overflow error (recursion compiled as recursion), or the length of the list (recursion compiled with iteration, tail recursion).
Even better, you can provide an infinite length list, like in:
(our-length-tr '#1=(1 2 3 . #1#)))
and see if a Stack Overflow error is produced (usually almost immediately), or no output at all is produced because of the infinite loop of the iteration.
I want to build an application into a bundle with Ceramic. I can run the app with it. The error arises with:
(ceramic:bundle :WEBLOCKS-TODOMVC :bundle-pathname #p"build/todomvc.tar")
it runs…
Ceramic: Compiling app...
Launch:
"/usr/local/bin/sbcl" --noinform --no-userinit --no-sysinit
--load "/home/vince/quicklisp/setup.lisp"
--eval "(setf *debugger-hook*
#'(lambda (c h)
(declare (ignore h))
(uiop:print-condition-backtrace c)
(uiop:quit -1)))"
--eval "(asdf:load-system :WEBLOCKS-TODOMVC)"
--eval "(setf uiop:*image-entry-point*
#'(lambda ()
(ceramic-entry::weblocks-todomvc)))"
--eval "(uiop:dump-image #P\"/home/vince/.ceramic/working/weblocks-todomvc\"
:executable t
#+sb-core-compression :compression
#+sb-core-compression t)"
and crashes:
Subprocess with command "\"/usr/local/bin/sbcl\" --noinform --no-userinit --no-sysinit --load \"/home/vince/quicklisp/setup.lisp\" --eval \"(setf *debugger-hook* #'(lambda (c h) (declare (ignore h)) (uiop:print-condition-backtrace c) (uiop:quit -1)))\" --eval \"(asdf:load-system :WEBLOCKS-TODOMVC)\" --eval \"(setf uiop:*image-entry-point* #'(lambda () (ceramic-entry::weblocks-todomvc)))\" --eval \"(uiop:dump-image #P\\\"/home/vince/.ceramic/working/weblocks-todomvc\\\" :executable t
#+sb-core-compression :compression #+sb-core-compression t)\""
exited with error code 255
[Condition of type UIOP/RUN-PROGRAM:SUBPROCESS-ERROR]
However, the log error, the backtrace don't contain much information at all. Is there a way to ask for more ?
I did a mkdir build/ to be sure.
[![image][1]][1]
(source: toile-libre.org)
Given coredump's answer:
I went up in the source (with M-.) from ceramic:bundle to find the call to uiop:run-process, which I added the two parameters and wrapped around a multiple-value-bind:
(multiple-value-bind (zero one two)
(uiop:run-program command
:output *standard-output*
:error :output
:error-output :lines
:ignore-error-status t)
(format t "------------ printing error messages:")
(log:info zero)
(log:info one)
(log:info two))))
and running the build command again:
------------ printing error messages:
<INFO> [19:09:32] trivial-build slimeCUlUAR (boot-and-build) -
TRIVIAL-BUILD::ZERO: NIL
<INFO> [19:09:32] trivial-build slimeCUlUAR (boot-and-build) -
TRIVIAL-BUILD::ONE: ("WARNING: Setting locale failed."
" Check the following variables for correct values:"
" LC_CTYPE=en_US.UTF-8" " LANG=fr_FR.UTF-8"
"Backtrace for: #<SB-THREAD:THREAD \"main thread\" RUNNING {10019BB4E3}>"
"0: ((LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE))"
"1: ((FLET \"THUNK\" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX))"
"2: (SB-IMPL::%WITH-STANDARD-IO-SYNTAX #<CLOSURE (FLET \"THUNK\" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX) {7FFFF70BF27B}>)"
"3: (UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX #<CLOSURE (LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE) {10035ABAAB}> :PACKAGE :CL)"
"4: (UIOP/IMAGE:PRINT-CONDITION-BACKTRACE Component :WEBLOCKS-TODOMVC not found :STREAM NIL :COUNT NIL)"
"5: ((LAMBDA (COMMON-LISP-USER::C COMMON-LISP-USER::H))
Component :WEBLOCKS-TODOMVC not found #<unused argument>)"
"6: (SB-DEBUG::RUN-HOOK *DEBUGGER-HOOK*
Component :WEBLOCKS-TODOMVC not found)"
"7: (INVOKE-DEBUGGER
Component :WEBLOCKS-TODOMVC not found)"
"8: (ERROR ASDF/FIND-SYSTEM:MISSING-COMPONENT :REQUIRES :WEBLOCKS-TODOMVC)"
"9: ((:METHOD ASDF/OPERATE:OPERATE (SYMBOL T)) ASDF/LISP-ACTION:LOAD-OP :WEBLOCKS-TODOMVC) [fast-method]"
"10: ((SB-PCL::EMF ASDF/OPERATE:OPERATE) #<unused argument> #<unused argument> ASDF/LISP-ACTION:LOAD-OP :WEBLOCKS-TODOMVC)"
"11: ((LAMBDA NIL :IN ASDF/OPERATE:OPERATE))"
"12: ((:METHOD ASDF/OPERATE:OPERATE :AROUND (T T)) ASDF/LISP-ACTION:LOAD-OP :WEBLOCKS-TODOMVC) [fast-method]"
"13: ((LAMBDA NIL :IN ASDF/OPERATE:OPERATE))"
"14: (ASDF/CACHE:CALL-WITH-ASDF-CACHE #<CLOSURE (LAMBDA NIL :IN ASDF/OPERATE:OPERATE) {1001ED497B}> :OVERRIDE NIL :KEY NIL)"
"15: ((:METHOD ASDF/OPERATE:OPERATE :AROUND (T T)) ASDF/LISP-ACTION:LOAD-OP :WEBLOCKS-TODOMVC) [fast-method]"
"16: (ASDF/OPERATE:LOAD-SYSTEM :WEBLOCKS-TODOMVC)"
"17: (SB-INT:SIMPLE-EVAL-IN-LEXENV (ASDF/OPERATE:LOAD-SYSTEM :WEBLOCKS-TODOMVC) #<NULL-LEXENV>)"
"18: (EVAL (ASDF/OPERATE:LOAD-SYSTEM :WEBLOCKS-TODOMVC))"
"19: (SB-IMPL::PROCESS-EVAL/LOAD-OPTIONS ((:LOAD . \"/home/vince/quicklisp/setup.lisp\") (:EVAL . \"(setf *debugger-hook* #'(lambda (c h) (declare (ignore h)) (uiop:print-condition-backtrace c) (uiop:quit -1)))\") (:EVAL . \"(asdf:load-system :WEBLOCKS-TODOMVC)\") (:EVAL . \"(setf uiop:*image-entry-point* #'(lambda () (ceramic-entry::weblocks-todomvc)))\") (:EVAL . \"(uiop:dump-image #P\\\"/home/vince/.ceramic/working/weblocks-todomvc\\\" :executable t"
" #+sb-core-compression :compression #+sb-core-compression t)\")))"
"20: (SB-IMPL::TOPLEVEL-INIT)"
"21: ((FLET \"WITHOUT-INTERRUPTS-BODY-6\" :IN SB-EXT:SAVE-LISP-AND-DIE))"
"22: ((LABELS SB-IMPL::RESTART-LISP :IN SB-EXT:SAVE-LISP-AND-DIE))"
"Above backtrace due to this condition:"
"Component :WEBLOCKS-TODOMVC not found")
<INFO> [19:09:32] trivial-build slimeCUlUAR (boot-and-build) -
TRIVIAL-BUILD::TWO: 255
Ceramic: Compressing...
so it seems that the build can not find my component "weblocks-todomvc". Which I find surprising because my .asdf file compiles correctly, I can run a Ceramic window,…
Given the comments under this question, I make trivial-build load my package by adding (format nil "(load #p\"/home/vince/projets/weblocks-todomvc/weblocks-todomvc.asd/\"") in trivial-build:load-and-build-code and I get a different stacktrace:
------------ printing error messages:
<INFO> [21:49:12] trivial-build trivial-build.lisp (boot-and-build) -
TRIVIAL-BUILD::ZERO: NIL
<INFO> [21:49:12] trivial-build trivial-build.lisp (boot-and-build) -
TRIVIAL-BUILD::ONE: ("WARNING: Setting locale failed."
" Check the following variables for correct values:"
" LC_CTYPE=en_US.UTF-8" " LANG=fr_FR.UTF-8"
"Backtrace for: #<SB-THREAD:THREAD \"main thread\" RUNNING {10019BB783}>"
"0: ((LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE))"
"1: ((FLET \"THUNK\" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX))"
"2: (SB-IMPL::%WITH-STANDARD-IO-SYNTAX #<CLOSURE (FLET \"THUNK\" :IN UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX) {7FFFF70BF66B}>)"
"3: (UIOP/STREAM:CALL-WITH-SAFE-IO-SYNTAX #<CLOSURE (LAMBDA NIL :IN UIOP/IMAGE:PRINT-BACKTRACE) {1001EB3A2B}> :PACKAGE :CL)"
"4: (UIOP/IMAGE:PRINT-CONDITION-BACKTRACE
#<END-OF-FILE {1001EB3473}> :STREAM NIL :COUNT NIL)"
"5: ((LAMBDA (COMMON-LISP-USER::C COMMON-LISP-USER::H))
#<END-OF-FILE {1001EB3473}> #<unused argument>)"
"6: (SB-DEBUG::RUN-HOOK *DEBUGGER-HOOK*
#<END-OF-FILE {1001EB3473}>)"
"7: (INVOKE-DEBUGGER #<END-OF-FILE {1001EB3473}>)"
"8: (ERROR END-OF-FILE :STREAM #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}>)"
"9: (SB-IMPL::STRING-INCH #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> T NIL)"
"10: (SB-IMPL::FLUSH-WHITESPACE #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}>)"
"11: (SB-IMPL::READ-LIST #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> #<unused argument>)"
"12: (SB-IMPL::READ-MAYBE-NOTHING #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> #\\()"
"13: (SB-IMPL::%READ-PRESERVING-WHITESPACE #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> T (NIL) T)"
"14: (SB-IMPL::%READ-PRESERVING-WHITESPACE #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> T (NIL) NIL)"
"15: (READ #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}> T NIL NIL)"
"16: (SB-IMPL::%READ-FROM-STRING \"(load #p\\\"/home/vince/projets/weblocks-todomvc/weblocks-todomvc.asd/\\\"\" T NIL 0 NIL NIL)"
"17: (SB-IMPL::PROCESS-EVAL/LOAD-OPTIONS ((:LOAD . \"/home/vince/quicklisp/setup.lisp\") (:EVAL . \"(setf *debugger-hook* #'(lambda (c h) (declare (ignore h)) (uiop:print-condition-backtrace c) (uiop:quit -1)))\") (:EVAL . \"NIL\") (:EVAL . \"(load #p\\\"/home/vince/projets/weblocks-todomvc/weblocks-todomvc.asd/\\\"\") (:EVAL . \"(ql:quickload :WEBLOCKS-TODOMVC)\") (:EVAL . \"(setf uiop:*image-entry-point* #'(lambda () (ceramic-entry::weblocks-todomvc)))\") (:EVAL . \"(uiop:dump-image #P\\\"/home/vince/.ceramic/working/weblocks-todomvc\\\" :executable t"
" #+sb-core-compression :compression #+sb-core-compression t)\")))"
"18: (SB-IMPL::TOPLEVEL-INIT)"
"19: ((FLET \"WITHOUT-INTERRUPTS-BODY-6\" :IN SB-EXT:SAVE-LISP-AND-DIE))"
"20: ((LABELS SB-IMPL::RESTART-LISP :IN SB-EXT:SAVE-LISP-AND-DIE))"
"Above backtrace due to this condition:"
"end of file on #<SB-IMPL::STRING-INPUT-STREAM {1001EB2F53}>")
<INFO> [21:49:12] trivial-build trivial-build.lisp (boot-and-build) -
TRIVIAL-BUILD::TWO: 255
[1]: https://i.stack.imgur.com/OxVHf.png
You need to:
pass :ignore-error-status t
define how you want to retrieve the error messages with :error-output (e.g. :lines)
Then, run-program won't signal an error but you have to check the error status (third value), and print/inspect the error message (second value).
RUN-PROGRAM returns 3 values:
0- the result of the OUTPUT slurping if any, or NIL
1- the result of the ERROR-OUTPUT slurping if any, or NIL
2- either 0 if the subprocess exited with success status,
or an indication of failure via the EXIT-CODE of the process
For instance, if a loop is running that calls 'FOO at every iteration, and I recompile 'FOO before the loop exits, what happens?
What are the specific mechanism SBCL uses to handle such situations?
SBCL is a compile-only implementation, so the answer to your question is easy to discover:
* (defun foo (x) (print x))
FOO
* (describe 'foo)
COMMON-LISP-USER::FOO
[symbol]
FOO names a compiled function:
Lambda-list: (X)
Derived type: (FUNCTION (T) (VALUES T &OPTIONAL))
Source form:
(SB-INT:NAMED-LAMBDA FOO
(X)
(BLOCK FOO (PRINT X)))
* (disassemble (lambda ()(loop repeat 10 do (foo 1))))
; disassembly for (LAMBDA ())
; Size: 91 bytes. Origin: #x1002F7F564
; 64: BE14000000 MOV ESI, 20 ; no-arg-parsing entry point
; 69: EB3E JMP L1
; 6B: 0F1F440000 NOP
; 70: L0: 488BCE MOV RCX, RSI
; 73: 4883E902 SUB RCX, 2
; 77: 488BF1 MOV RSI, RCX
; 7A: 488D5C24F0 LEA RBX, [RSP-16]
; 7F: 4883EC18 SUB RSP, 24
; 83: BA02000000 MOV EDX, 2
; 88: 488975F8 MOV [RBP-8], RSI
; 8C: 488B057DFFFFFF MOV RAX, [RIP-131] ; #<FDEFINITION object for FOO>
; 93: B902000000 MOV ECX, 2
; 98: 48892B MOV [RBX], RBP
; 9B: 488BEB MOV RBP, RBX
; 9E: FF5009 CALL QWORD PTR [RAX+9]
; A1: 480F42E3 CMOVB RSP, RBX
; A5: 488B75F8 MOV RSI, [RBP-8]
; A9: L1: 4885F6 TEST RSI, RSI
; AC: 7FC2 JNLE L0
; AE: BA17001020 MOV EDX, 537919511
; B3: 488BE5 MOV RSP, RBP
; B6: F8 CLC
; B7: 5D POP RBP
; B8: C3 RET
; B9: 0F0B0A BREAK 10 ; error trap
; BC: 02 BYTE #X02
; BD: 19 BYTE #X19 ; INVALID-ARG-COUNT-ERROR
; BE: 9A BYTE #X9A ; RCX
NIL
As you can see, the disassembly mentions #<FDEFINITION object for FOO> (as opposed to a the object #<FUNCTION FOO> returned by (fdefinition 'foo)), so, apparently, fdefinition is called on each iteration.
This can be confirmed by comparing these two disassmeblies:
* (disassemble (lambda () (fdefinition 'foo)))
; disassembly for (LAMBDA ())
; Size: 31 bytes. Origin: #x1002FF99F4
; 9F4: 488B15A5FFFFFF MOV RDX, [RIP-91] ; 'FOO
; no-arg-parsing entry point
; 9FB: 488B05A6FFFFFF MOV RAX, [RIP-90] ; #<FDEFINITION object for FDEFINITION>
; A02: B902000000 MOV ECX, 2
; A07: FF7508 PUSH QWORD PTR [RBP+8]
; A0A: FF6009 JMP QWORD PTR [RAX+9]
; A0D: 0F0B0A BREAK 10 ; error trap
; A10: 02 BYTE #X02
; A11: 19 BYTE #X19 ; INVALID-ARG-COUNT-ERROR
; A12: 9A BYTE #X9A ; RCX
NIL
* (disassemble (lambda () #.(fdefinition 'foo)))
; disassembly for (LAMBDA ())
; Size: 19 bytes. Origin: #x1003020214
; 14: 488B15A5FFFFFF MOV RDX, [RIP-91] ; #<FUNCTION FOO>
; no-arg-parsing entry point
; 1B: 488BE5 MOV RSP, RBP
; 1E: F8 CLC
; 1F: 5D POP RBP
; 20: C3 RET
; 21: 0F0B0A BREAK 10 ; error trap
; 24: 02 BYTE #X02
; 25: 19 BYTE #X19 ; INVALID-ARG-COUNT-ERROR
; 26: 9A BYTE #X9A ; RCX
NIL
the first definitely calls fdefinition and the second definitely does not, and the first is closer to the disassembly of the loop.
Finally, one can use the explicit test by Paulo Madeira:
(progn (sb-thread:make-thread (lambda () (sleep 5.1) (defun foo (x) (print (1+ x)))))
(dotimes (i 10) (sleep 1) (foo 1)))
starts showing 2.
I've been trying to build a lispy interface to the CFFI bindings (https://gitorious.org/dh-misc/hdf5/source/cb616fd619a387e3cdc927994b9ad12b6b514236:) but I ran into a situation where code runs correctly in SLIME which has an SBCL instance as the backend, but won't run whenever I run the code just in SBCL.
So, I created a test case file which demonstrates the error:
(asdf:load-system :cffi)
;;(asdf:operate 'asdf:load-op :cffi)
(defpackage :hdf5test
(:use :cl :cffi)
(:export :test))
(in-package :hdf5test)
(define-foreign-library hdf5
(t (:default "libhdf5")))
(use-foreign-library hdf5)
;; hdf types:
(defctype size-t :uint)
(defctype hid-t :int)
(defctype herr-t :int)
(defctype hsize-t :uint64)
;; hdf constants:
;; H5S_UNLIMITED: 2^64-1
(defconstant +H5S-UNLIMITED+ 18446744073709551615)
;; H5F_ACC_TRUNC
(defconstant +H5F-ACC-TRUNC+ 2) ;; we'll see if it works
;; H5P_DEFAULT
(defconstant +H5P-DEFAULT+ 0)
;; H5T types:
(defconstant +H5P-DATASET-CREATE+ 150994953)
(defconstant +H5T-NATIVE-INT+ 50331660)
;; hdf functions:
;; H5Screate_simple
(defcfun "H5Screate_simple" hid-t
(rank :int)
(current-dims :pointer) ; const hsize_t*
(maximum-dims :pointer)) ; cons hsize_t*
;; H5Fcreate
(defcfun "H5Fcreate" hid-t
(filename :string)
(flags :uint)
(fcpl-id hid-t)
(fapl-id hid-t))
;; H5Pcreate
(defcfun "H5Pcreate" hid-t
(cls-id hid-t))
;; H5Pset_chunk
(defcfun "H5Pset_chunk" herr-t
(plist hid-t)
(ndims :int)
(dim :pointer)) ;; const hsize_t*
;; H5Pset_deflate
(defcfun "H5Pset_deflate" herr-t
(plist-id hid-t)
(level :uint))
;; H5Dcreate1
(defcfun "H5Dcreate1" hid-t
(loc-id hid-t)
(name :string)
(type-id hid-t)
(space-id hid-t)
(dcpl-id hid-t))
;; H5Dclose
(defcfun "H5Dclose" herr-t
(dataset-id hid-t))
;; H5Dwrite
(defcfun "H5Dwrite" herr-t
(datset-id hid-t)
(mem-type-id hid-t)
(mem-space-id hid-t)
(file-space-id hid-t)
(xfer-plist-id hid-t)
(buf :pointer))
;; H5Fclose
(defcfun "H5Fclose" herr-t
(file-id hid-t))
;; H5Sclose
(defcfun "H5Sclose" herr-t
(space-id hid-t))
(defparameter *rank* 1)
(defun test (filename)
(with-foreign-string (dataset-name "dataset")
(with-foreign-objects ((dim :int 1)
(dataspace-maxdim :uint64 1)
(memspace-maxdim :uint64 1)
(chunkdim :int 1)
(dataspace 'hid-t)
(dataset 'hid-t)
(memspace 'hid-t)
(cparms 'hid-t))
(setf (mem-aref dim :int 0) 5)
(format t "dim: ~a~%" (mem-aref dim :int 0))
;;(setf (mem-aref maxdim :int 0) -1)
(setf (mem-aref dataspace-maxdim :uint64 0) +H5S-UNLIMITED+)
(setf (mem-aref memspace-maxdim :uint64 0) 5)
(setf (mem-aref chunkdim :int 0) 1)
(format t "dataspace-maxdim: ~a~%" (mem-aref dataspace-maxdim :uint64 0))
(format t "memspace-maxdim: ~a~%" (mem-aref memspace-maxdim :uint64 0))
;;(with-open-hdf-file (file filename :direction :output :if-exists :supersede)
(let ((file (h5fcreate filename +H5F-ACC-TRUNC+ +H5P-DEFAULT+ +H5P-DEFAULT+)))
(setf cparms (h5pcreate +H5P-DATASET-CREATE+))
(h5pset-chunk cparms *rank* chunkdim)
(setf dataspace (h5screate-simple *rank* dim dataspace-maxdim))
(setf dataset (h5dcreate1
file
dataset-name
+H5T-NATIVE-INT+
dataspace
cparms))
(format t "dataspace: ~a~%" dataspace)
(format t "dataset: ~a~%" dataset)
(setf memspace (h5screate-simple *rank* dim memspace-maxdim))
(with-foreign-object (data :int 5)
(loop for i from 0 to 4 do (setf (mem-aref data :int i) (* i i)))
(h5dwrite dataset +H5T-NATIVE-INT+ memspace dataspace +H5P-DEFAULT+ data))
(h5dclose dataset)
(h5sclose memspace)
(h5sclose dataspace)
(h5fclose file)))))
The output I get from running (hdf5test:test "test.h5") in SLIME+SBCL is
dim: 5
dataspace-maxdim: 18446744073709551615
memspace-maxdim: 5
dataspace: 67108866
dataset: 83886080
0
The output I get from running (hdf5test:test "test.h5") in just SBCL is
dim: 5
dataspace-maxdim: 18446744073709551615
memspace-maxdim: 5
dataspace: 67108866
dataset: 83886080
HDF5-DIAG: Error detected in HDF5 (1.8.10-patch1) thread 0:
#000: H5S.c line 1388 in H5Screate_simple(): maxdims is smaller than dims
major: Invalid arguments to routine
minor: Bad value
HDF5-DIAG: Error detected in HDF5 (1.8.10-patch1) thread 0:
#000: H5Dio.c line 233 in H5Dwrite(): not a data space
major: Invalid arguments to routine
minor: Inappropriate type
HDF5-DIAG: Error detected in HDF5 (1.8.10-patch1) thread 0:
#000: H5S.c line 405 in H5Sclose(): not a dataspace
major: Invalid arguments to routine
minor: Inappropriate type
0
So you can see it's something to do with how the array is being passed to the hdf functions, but I have no clue why SLIME+SBCL would handle this but not SBCL.
I've also tried the exact same code with CLISP and it works fine, no issues, so it seems to be an SBCL issue.
Any thoughts on this?
EDIT: I thought I should add to the main post that the resulting files truly are different in each case. In SLIME+SBCL or CLISP the file contains a finite dataset with squared integers inside (no reason really, just a test). But, with plain SBCL the data file is left incomplete; if you try to view the contents with h5dump it is an unending trial of zeros (that's how it handles incomplete datasets).
Like #nixeagle said, slime seems to hide the error messages originating in the hdf5 library. Along these lines I'd wager that passing the results from SBCL to emacs in slime is what allows the file to be written.
Now the following needs to be taken with a few grains of salt, as I don't really know anything about hdf5 or cffi and am now just getting back into common lisp, but things started working consistently in both slime and sbcl on my x86_64 linux box, once I replaced all those :int types with :uint64, which seems to make sense, as the declarations resolve to that type anyways.
your code in sbcl:
* (load "temp.lisp")
T
* (hdf5test:test "test2.h5")
dim: 5
dataspace-maxdim: 18446744073709551615
memspace-maxdim: 5
dataspace: 67108866
dataset: 83886080
HDF5-DIAG: Error detected in HDF5 (1.8.12) thread 0:
#000: H5S.c line 1388 in H5Screate_simple(): maxdims is smaller than dims
major: Invalid arguments to routine
minor: Bad value
HDF5-DIAG: Error detected in HDF5 (1.8.12) thread 0:
#000: H5Dio.c line 231 in H5Dwrite(): can't prepare for writing data
major: Dataset
minor: Write failed
#001: H5Dio.c line 332 in H5D__pre_write(): not a data space
major: Invalid arguments to routine
minor: Inappropriate type
HDF5-DIAG: Error detected in HDF5 (1.8.12) thread 0:
#000: H5S.c line 405 in H5Sclose(): not a dataspace
major: Invalid arguments to routine
minor: Inappropriate type
0
part with changes:
(with-foreign-objects ((dim :uint64 1)
(dataspace-maxdim :uint64 1)
(memspace-maxdim :uint64 1)
(chunkdim :uint64 1)
(dataspace 'hid-t)
(dataset 'hid-t)
(memspace 'hid-t)
(cparms 'hid-t))
(setf (mem-aref dim :uint64 0) 5)
(format t "dim: ~a~%" (mem-aref dim :uint64 0))
;;(setf (mem-aref maxdim :int 0) -1)
(setf (mem-aref dataspace-maxdim :uint64 0) +H5S-UNLIMITED+)
(setf (mem-aref memspace-maxdim :uint64 0) 5)
(setf (mem-aref chunkdim :uint64 0) 1)
(format t "dataspace-maxdim: ~a~%" (mem-aref dataspace-maxdim :uint64 0))
(format t "memspace-maxdim: ~a~%" (mem-aref memspace-maxdim :uint64 0))
changed code in sbcl:
* (load "temp.lisp")
T
* (hdf5test:test "test2.h5")
dim: 5
dataspace-maxdim: 18446744073709551615
memspace-maxdim: 5
dataspace: 67108866
dataset: 83886080
0
result files:
% h5dump test.h5
HDF5 "test.h5" {
GROUP "/" {
DATASET "dataset" {
DATATYPE H5T_STD_I32LE
DATASPACE SIMPLE { ( 5 ) / ( H5S_UNLIMITED ) }
DATA {
(0): 0, 1, 4, 9, 16
}
}
}
}
% h5dump test2.h5
HDF5 "test2.h5" {
GROUP "/" {
DATASET "dataset" {
DATATYPE H5T_STD_I32LE
DATASPACE SIMPLE { ( 5 ) / ( H5S_UNLIMITED ) }
DATA {
(0): 0, 1, 4, 9, 16
}
}
}
}
Is there a library for serial port communication in Common Lisp on Windows?
Here are a few functions that implement serial communication using SBCL foreign function POSIX calls. Its not as nice as a full library but I solved my problem of talking to the device according to this protocol
https://valelab.ucsf.edu/svn/micromanager2/branches/micromanager1.3/DeviceAdapters/ZeissCAN/ZeissCAN.cpp
package.lisp:
(defpackage :serial
(:shadowing-import-from :cl close open ftruncate truncate time
read write)
(:use :cl :sb-posix)
(:export #:open-serial
#:close-serial
#:fd-type
#:serial-recv-length
#:read-response
#:write-zeiss
#:talk-zeiss))
(defpackage :focus
(:use :cl :serial)
(:export #:get-position
#:set-position
#:connect
#:disconnect))
serial.lisp:
(in-package :serial)
(defconstant FIONREAD #x541B)
(defconstant IXANY #o4000)
(defconstant CRTSCTS #o20000000000)
(deftype fd-type ()
`(unsigned-byte 31))
(defun open-serial (tty)
(declare (string tty)
(values stream fd-type &optional))
(let* ((fd (sb-posix:open
tty (logior O-RDWR
O-NOCTTY #+nil (this terminal can't control this program)
O-NDELAY #+nil (we don't wait until dcd is space)
)))
(term (tcgetattr fd))
(baud-rate B9600))
(fcntl fd F-SETFL (logior O-RDWR O-NOCTTY)) #+nil (reset file status flags, clearing e.g. O-NDELAY)
(cfsetispeed baud-rate term)
(cfsetospeed baud-rate term)
(macrolet ((set-flag (flag &key (on ()) (off ()))
`(setf ,flag (logior ,#on (logand ,flag ,#off)))))
(setf
(aref (termios-cc term) VMIN) 1 #+nil (wake up after 32 chars are read)
(aref (termios-cc term) VTIME) 5 #+nil (wake up when no char arrived for .1 s))
;; check and strip parity, handshake off
(set-flag (termios-iflag term)
:on ()
:off (IXON IXOFF IXANY
IGNBRK BRKINT PARMRK ISTRIP
INLCR IGNCR ICRNL
))
;; process output
(set-flag (termios-oflag term)
:off (OPOST))
;; canonical input but no echo
(set-flag (termios-lflag term)
:on ()
:off (ICANON ECHO ECHONL IEXTEN ISIG))
;; enable receiver, local mode, 8N1 (no parity)
(set-flag (termios-cflag term)
:on (CLOCAL CREAD
CS8 CRTSCTS)
:off (CSTOPB CSIZE PARENB)))
(tcflush fd TCIFLUSH) #+nil (throw away any input data)
(tcsetattr fd TCSANOW term) #+nil (set terminal port attributes)
(values
(sb-sys:make-fd-stream fd :input t :output t
:buffering :full)
fd)))
(defun close-serial (fd)
(declare (fd-type fd)
(values null &optional))
(fcntl fd F-SETFL 0) #+nil (reset file status flags, clearing e.g. O-NONBLOCK)
(sb-posix:close fd) #+nil (this will set DTR low)
nil)
(defun serial-recv-length (fd)
(declare (fd-type fd)
(values (signed-byte 32) &optional))
(sb-alien:with-alien ((bytes sb-alien:int))
(ioctl fd FIONREAD (sb-alien:addr bytes))
bytes))
(defun read-response (tty-fd tty-stream)
(declare (fd-type tty-fd)
(stream tty-stream)
(values string &optional))
(declare (fd-type tty-fd)
(stream tty-stream)
(values string &optional))
(let ((n (serial-recv-length tty-fd)))
(if (eq 0 n)
""
(let ((ret (make-string n)))
(dotimes (i n)
(setf (char ret i) (read-char tty-stream)))
ret))))
(defun write-zeiss (tty-stream command)
(declare (stream tty-stream)
(string command))
(format tty-stream "~a~a" command #\Return)
(finish-output tty-stream))
(defun talk-zeiss (tty-fd tty-stream command)
(declare (fd-type tty-fd)
(stream tty-stream)
(string command)
(values string &optional))
(write-zeiss tty-stream command)
;; I measured that the position is fully transmitted after 30 ms.
(let ((n (do ((i 0 (1+ i))
(n 0 (serial-recv-length tty-fd)))
((or (< 0 n) (<= 30 i)) n)
(sleep .03d0))))
(if (eq 0 n)
""
(read-response tty-fd tty-stream))))
focus.lisp:
(in-package :focus)
(defvar *stream* nil)
(defvar *fd* nil)
(defun run-shell (command)
(with-output-to-string (stream)
(sb-ext:run-program "/bin/bash" (list "-c" command)
:input nil
:output stream)))
(defun find-zeiss-usb-adapter ()
(let ((port (run-shell "dmesg|grep pl2303|grep ttyUSB|tail -n1|sed s+.*ttyUSB+/dev/ttyUSB+g|tr -d '\\n'")))
(if (string-equal "" port)
(error "dmesg output doesn't contain ttyUSB assignment. This can happen when the system ran a long time. You could reattach the USB adapter that is connected to the microscope.")
port)))
#+nil
(find-zeiss-usb-adapter)
(defun connect (&optional (devicename (find-zeiss-usb-adapter)))
(multiple-value-bind (s fd)
(open-serial devicename)
(defparameter *stream* s)
(defparameter *fd* fd)))
#+nil
(connect)
(defun disconnect ()
(close-serial *fd*)
(setf *stream* nil))
#+nil
(disconnect)
#+nil
(serial-recv-length *fd*)
#+nil ;; do cat /dev/ttyUSB1 in some terminal, or use read-response below
(progn
(format *stream* "HPTv0~a" #\Return)
(finish-output *stream*))
#+nil
(progn
(format *stream* "FPZp~a" #\Return)
(finish-output *stream*))
#+nil
(read-response *fd* *stream*)
#+nil
(response->pos-um (read-response *fd* *stream*))
#+nil
(close-serial *fd2*)
#+nil
(time
(response->pos-um (talk-zeiss *fd2* *s2* "FPZp")))
#+nil ;; measure the time it takes until the full response has arrived
(progn
(format *s2* "FPZp~a" #\Return)
(finish-output *s2*)
(dotimes (i 10)
(sleep .01d0)
(format t "~a~%" (list i (serial-recv-length *fd2*))))
(read-response *fd2* *s2*))
(defconstant +step-size+ .025s0 "Distance of one z step in micrometer.")
(defun response->pos-um (answer)
(declare (string answer)
(values single-float &optional))
(if (equal "PF" (subseq answer 0 2))
(let* ((uval (the fixnum (read-from-string
(format nil "#x~a" (subseq answer 2)))))
(val (if (eq 0 (logand uval #x800000))
uval ;; positive
(- uval #xffffff 1))))
(* +step-size+ val))
(error "unexpected answer on serial port.")))
;; some tricks with two's complement here! be sure to generate a
;; 24bit signed number consecutive application of pos-um->request and
;; response->pos-um should be the identity (if you don't consider the
;; prefix "PF" that response->pos-um expects)
(defun pos-um->request (pos-um)
(declare (single-float pos-um)
(values string &optional))
(format nil "~6,'0X"
(let ((val (round pos-um +step-size+)))
(if (< val 0)
(+ #xffffff val 1)
val))))
(defun get-position ()
(declare (values single-float &optional))
(response->pos-um (talk-zeiss *fd* *stream* "FPZp")))
(defun set-position (position-um)
"Decreasing the position moves away from sample."
(declare (single-float position-um))
(write-zeiss *stream*
(format nil "FPZT~a" (pos-um->request position-um))))
#+nil
(format nil "FPZT~a" (pos-um->request -8.0d0))
#+nil
(defparameter current-pos (get-position *fd* *stream*))
#+nil
(format t "pos: ~a~%" (get-position *fd2* *s2*))
# +nil
(time (format t "response ~a~%"
(set-position *s2* (+ current-pos 0.7d0))))
#+nil
(progn
(set-position *s2* (+ current-pos 135d0))
(dotimes (i 20)
(format t "pos ~a~%" (list i (get-position *fd2* *s2*)))))
#+nil
(loop for i below 100 do
(sleep .1)
(format t "~a~%" (response->pos-um (talk-zeiss "FPZp"))))
I don't know if there's a free one available, but LispWorks has one - SERIAL-PORT.
Failing that, you might have to write your own. You could try simply writing the FFI wrappers for the Windows calls (GetCommState, WaitCommEvent, etc.) as a start. It's most certainly doable.
This isn't really a lisp question, but I'll attempt to answer it anyway. Short answer: no. Long answer: possibly. It depends on how the FFI works and what environment you're using(raw windows, cygwin, mingw) If you are using raw windows, the chances is very slim. Actually, either way I'd bet the chances are slim. Lisp is a fairly high-level language, and isn't designed for stuff such as this.