Code runs in SLIME+SBCL but not plain SBCL - common-lisp

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
}
}
}
}

Related

Why does the Lisp reader return `(list 1 2 3)` instead of `(1 2 3)` when using reader macros?

Recently, I tried to understand reader macros better. I have read an article about using reader macros to read in objects in JSON format.
With slightly adapted code from above article (it only reads (or is supposed to read) arrays [1,2,3] into lists (1 2 3))
(defun read-next-object (separator delimiter &optional (input-stream *standard-input*))
(flet ((peek-next-char ()
(peek-char t input-stream t nil t))
(discard-next-char ()
(read-char input-stream t nil t)))
(if (and delimiter (char= (peek-next-char) delimiter))
(progn
(discard-next-char)
nil)
(let* ((object (read input-stream t nil t))
(next-char (peek-next-char)))
(cond
((char= next-char separator) (discard-next-char))
((and delimiter (char= next-char delimiter)) nil)
(t (error "Unexpected next char: ~S" next-char)))
object))))
(defun read-separator (stream char)
(declare (ignore stream))
(error "Separator ~S shouldn't be read alone" char))
(defun read-delimiter (stream char)
(declare (ignore stream))
(error "Delimiter ~S shouldn't be read alone" char))
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character #\, 'read-separator)
(loop
for object = (read-next-object #\, #\] stream)
while object
collect object into objects
finally (return `(list ,#objects)))))
the intent is to call read on strings and have it produce Lisp lists.
With following test code I get:
(with-input-from-string (stream "[1,2,3]")
(let ((*readtable* (copy-readtable)))
(set-macro-character #\[ 'read-left-bracket)
(set-macro-character #\] 'read-delimiter)
(read stream)))
;; => (LIST 1 2 3)
I expected to get (1 2 3) instead.
Now, when I change the current readtable "permanently", i.e. call set-macro-character in the top-level, and type [1,2,3] at the prompt, I get indeed (1 2 3).
Why, then, does
(with-input-from-string (stream "(1 2 3)")
(read stream)))
;; => (1 2 3)
give the "expected" result? What am I missing? Is there some eval hidden, somewhere? (I'm aware of the quasi-quote above, but some in-between reasoning is missing...)
Thanks!
EDIT:
Using
(defun read-left-bracket (stream char)
(declare (ignore char))
(let ((*readtable* (copy-readtable)))
(set-macro-character #\, 'read-separator)
(loop
for object = (read-next-object #\, #\] stream)
while object
collect object)))
I get what I expect. Entering '[1,2,3] at the REPL behaves like entering "real" lists.
Reading from strings also works as intended.
You have
(return `(list ,#objects))
in your code. Thus [...] is read as (list ...).
Next if you use the REPL and evaluate
> [...]
Then it is as you were evaluating
> (list 1 2 3)
which returns (1 2 3).

How do I play an FM demodulated sample on the sound card in Common Lisp?

I have created a Common Lisp library binding for libbladerf and can receive signals in Common Lisp. I have a function that demodulates an FM signal and is defined as follows:
(defun fm-demodulate-sc16-q11-samples (device frequency)
(configure-channel device (channel-rx 0) frequency 1000 40000000 30)
(init-sync device)
(enable-module device (channel-rx 0) t)
(with-foreign-objects ((rx-samples :uint16 8192)
(metadata :pointer))
(let ((status (bladerf_sync_rx (mem-ref device :pointer) rx-samples 4096 metadata 5000))
(samples-array (make-array 8192 :element-type 'float :initial-element 0.0 :fill-pointer 0)))
(if (< status 0)
(error "Failed to recieve IQ samples error: ~S" status)
(progn
(loop for i below 4096 by 4
do
(let* ((previous-i (mem-aref rx-samples :int16 (1+ i)))
(previous-q (mem-aref rx-samples :int16 i))
(current-i (mem-aref rx-samples :int16 (+ i 3)))
(current-q (mem-aref rx-samples :int16 (+ i 2)))
(previous-complex (complex previous-i previous-q))
(current-complex (complex current-i current-q))
(dif-complex (* (conjugate previous-complex) current-complex)))
(vector-push (atan-complex-number dif-complex) samples-array)))
samples-array)))))
I then pass this to cl-portaudio using the following code:
(defconstant +frames-per-buffer+ 1024)
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +num-channels+ 2)
(defun play-demodulated-fm ()
(with-audio
(with-default-audio-stream (astream +num-channels+ +num-channels+ :sample-format +sample-format+ :sample-rate +sample-rate+ :frames-per-buffer +frames-per-buffer+)
(dotimes (i 20)
(write-stream astream (fm-demodulate-sc16-q11-samples *dev* 863000000)))))
When I play this all I hear is a clipping sound and the following warning:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
ALSA lib pcm.c:8432:(snd_pcm_recover) underrun occurred
What is the correct way of playing an FM demodulated signal with cl-portaudio?
I tried to play a simple tone with cl-portaudio and got the very same error as you reported:
array is copied and/or coerced, lisp type is T, requested CFFI type is FLOAT
After a long night of trying and digging the net I finally cooked the following piece of code making a sound. Probably not 'CleanCode', but should do as a start.
(eval-when (:compile-toplevel)
(ql:quickload "cl-portaudio"))
(defconstant +sample-rate+ 44100d0)
(defconstant +sample-format+ :float)
(defconstant +input-channels+ 0)
(defconstant +output-channels+ 1)
(defconstant +sound-frequency+ 800)
(defconstant +angle-per-tick+ (* 2d0 pi (/ +sound-frequency+ +sample-rate+)))
(defconstant +audio-buffer-size+ 4096
"The number of samples in the audio buffer.")
(defconstant +audio-buffer-time+ (* +audio-buffer-size+ (/ +sample-rate+))
"The total time the information in the audio buffer represents, in seconds.")
(defun make-audio-buffer ()
(make-array +audio-buffer-size+
:element-type 'single-float
:initial-element 0.0))
(defun make-sine-wave (&optional (angle 0d0))
(loop
with buffer = (make-audio-buffer)
for i from 0 below +audio-buffer-size+
for cur-angle = (+ angle (* i +angle-per-tick+))
do
(setf (aref buffer i) (coerce (sin cur-angle) 'single-float))
finally
(return-from make-sine-wave (values buffer (mod cur-angle (* 2 pi))))))
(defun play-note()
(portaudio:with-audio
(portaudio:with-default-audio-stream
(audio-stream +input-channels+ +output-channels+
:sample-format :float
:sample-rate +sample-rate+
:frames-per-buffer +audio-buffer-size+)
(loop
for i from 1 to 8
with angle = 0d0
do
(multiple-value-bind
(buffer new-angle)
(make-sine-wave angle)
(portaudio:write-stream audio-stream buffer)
(setf angle new-angle))))))

How to compile s-expression at runtime and then execute it in Common Lisp

I am working on a program that generates program (Genetic Programming). I build at runtime an s-expression and today I use eval like this:
(defvar *program* '(+ x 1))
(defvar x 10)
(eval *program*) ;; returns 11
Evaluation is done for multiple x and I want to compile the s-expression into a function at runtime and then call it for multiple x to improve performance.
I can't figure out how to do it and I will appreciate some help. Here is what I have:
;;;; This is not working code
(defmacro compile-program (args &body body)
(compile nil `(lambda (,#args)
(declare (ignorable ,#args))
(progn ,#body))))
(funcall (compile-program (x) *program*) 10) ;; returns (+ X 1)
(funcall (compile-program (x) (+ x 1)) 10) ;; returns 11
Edit:
Thx to #RainerJoswig I made the following modifications and it works:
;;;; Working Code
(defvar *program* '(+ x 1))
(defun compile-program (args program)
(compile nil `(lambda ,args
(declare (ignorable ,#args))
,program)))
(funcall (compile-program '(x) *program*) 10) ;; returns 11
Thx to #RainerJoswig and #coredump I made the following modifications and it works:
;;;; Working Code
(defvar *program* '(+ x 1))
(defun compile-program (args program)
(compile nil `(lambda ,args
(declare (ignorable ,#args))
,program)))
(funcall (compile-program '(x) *program*) 10) ;; returns 11

sbcl - how to input new value for check-type and assert

I'm excise example from book: ANSI Common Lisp, charpter 14.6 conditions.
But the check-type and assert example doesn't work in sbcl.
And how can I input new value? it is always failed no matter whatever new value I input.
However, it works in clisp.
example code:
(let ((x '(a b c))) (check-type (car x) integer "an integer") x)
(let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
((car sandwich))
"I wanted a ~a sandwich." 'chicken)
sandwich)
In sbcl:
example 1:
* (let ((x '(a b c))) (check-type (car x) integer "an integer") x)
; in: LET ((X '(A B C)))
; (CHECK-TYPE (CAR X) INTEGER "an integer")
; --> DO BLOCK LET TAGBODY TAGBODY SETF
; ==>
; (SB-KERNEL:%RPLACA X
; (SB-KERNEL:CHECK-TYPE-ERROR '(CAR X) #:G0 'INTEGER
; "an integer"))
;
; caught WARNING:
; Destructive function SB-KERNEL:%RPLACA called on constant data.
; See also:
; The ANSI Standard, Special Operator QUOTE
; The ANSI Standard, Section 3.2.2.3
;
; compilation unit finished
; caught 1 WARNING condition
debugger invoked on a SIMPLE-TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
The value of (CAR X) is A, which is not an integer.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [STORE-VALUE] Supply a new value for (CAR X).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:CHECK-TYPE-ERROR (CAR X) A INTEGER "an integer")
0] 0
Type a form to be evaluated: 0
debugger invoked on a SIMPLE-TYPE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
The value of (CAR X) is A, which is not an integer.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [STORE-VALUE] Supply a new value for (CAR X).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:CHECK-TYPE-ERROR (CAR X) A INTEGER "an integer")
0]
example2:
* (let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
((car sandwich))
"I wanted a ~a sandwich." 'chicken)
sandwich)
; in: LET ((SANDWICH '(HAM ON RYE)))
; (ASSERT (EQL (CAR SANDWICH) 'CHICKEN) ((CAR SANDWICH))
; "I wanted a ~a sandwich." 'CHICKEN)
; --> TAGBODY SETF
; ==>
; (SB-KERNEL:%RPLACA SANDWICH
; (SB-IMPL::ASSERT-PROMPT '(CAR SANDWICH) (CAR SANDWICH)))
;
; caught WARNING:
; Destructive function SB-KERNEL:%RPLACA called on constant data.
; See also:
; The ANSI Standard, Special Operator QUOTE
; The ANSI Standard, Section 3.2.2.3
;
; compilation unit finished
; caught 1 WARNING condition
debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
I wanted a CHICKEN sandwich.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [CONTINUE] Retry assertion with new value for (CAR SANDWICH).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:ASSERT-ERROR (EQL (CAR SANDWICH) (QUOTE CHICKEN)) (((CAR SANDWICH) HAM)) ((CAR SANDWICH)) "I wanted a ~a sandwich." CHICKEN)
0] 0
The old value of (CAR SANDWICH) is HAM.
Do you want to supply a new value? (y or n) y
Type a form to be evaluated:
'chicken
debugger invoked on a SIMPLE-ERROR in thread
#<THREAD "main thread" RUNNING {B3E2341}>:
I wanted a CHICKEN sandwich.
Type HELP for debugger help, or (SB-EXT:EXIT) to exit from SBCL.
restarts (invokable by number or by possibly-abbreviated name):
0: [CONTINUE] Retry assertion with new value for (CAR SANDWICH).
1: [ABORT ] Exit debugger, returning to top level.
(SB-KERNEL:ASSERT-ERROR (EQL (CAR SANDWICH) (QUOTE CHICKEN)) (((CAR SANDWICH) HAM)) ((CAR SANDWICH)) "I wanted a ~a sandwich." CHICKEN)
0]
But in clisp, it works well.
[1]> (let ((x '(a b c))) (check-type (car x) integer "an integer") x)
*** - The value of (CAR X) should be an integer.
The value is: A
The following restarts are available:
STORE-VALUE :R1 Input a new value for (CAR X).
ABORT :R2 Abort main loop
Break 1 [2]> :R1
New (CAR X)> 99
(99 B C)
[3]> (let ((sandwich '(ham on rye)))
(assert (eql (car sandwich) 'chicken)
You are in the top-level Read-Eval-Print loop.
Help (abbreviated :h) = this list
Use the usual editing capabilities.
(quit) or (exit) leaves CLISP.
((car sandwich))
You are in the top-level Read-Eval-Print loop.
Help (abbreviated :h) = this list
Use the usual editing capabilities.
(quit) or (exit) leaves CLISP.
"I wanted a ~a sandwich." 'chicken)
sandwich)
** - Continuable Error
I wanted a CHICKEN sandwich.
If you continue (by typing 'continue'): Input a new value for (CAR SANDWICH).
The following restarts are also available:
ABORT :R1 Abort main loop
Break 1 [4]> continue
New (CAR SANDWICH)> 'chicken
(CHICKEN ON RYE)
[5]>
You are not supposed to modify literal data. The consequences are undefined in the Common Lisp standard.
This is undefined:
(let ((x '(a b c)))
(setf (car x) 10))
This works:
(let ((x (list 'a 'b 'c)))
(setf (car x) 10))

Serial port communication in common lisp

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.

Resources