suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/unsafe/ffi -> ffi/unsafe, etc.

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-26 18:05:29 -06:00
parent 0acbb358ce
commit b7c184632b
50 changed files with 4635 additions and 4640 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/ffi/c-printf.ss
View File

@ -1,39 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
;; This code demonstrates how to interface `printf' which can be used with
;; different arities and types. Also, `printf' is unsafe unless this code will
;; parse the format string and make sure that all the types match, instead,
;; this code demonstrates how to provide unsafe bindings in a way that forces
;; users to admit that `(c-printf-is-dangerous!)'.
;; It's not too useful, since the C printf will obviously ignore
;; `current-output-port'.
(provide* (unsafe c-printf))
(define interfaces (make-hash))
(define (c-printf fmt . args)
(define itypes
(cons _string
(map (lambda (x)
(cond [(and (integer? x) (exact? x)) _int]
[(and (number? x) (real? x)) _double*]
[(string? x) _string]
[(bytes? x) _bytes]
[(symbol? x) _symbol]
[else (error 'c-printf
"don't know how to deal with ~e" x)]))
args)))
(let ([printf (hash-ref interfaces itypes
(lambda ()
;; Note: throws away the return value of printf
(let ([i (get-ffi-obj "printf" #f
(_cprocedure itypes _void))])
(hash-set! interfaces itypes i)
i)))])
(apply printf fmt args)))
(define-unsafer c-printf-is-dangerous!)

63
collects/ffi/crypt.ss
View File

@ -1,63 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libcrypt (ffi-lib "libcrypt"))
(provide crypt)
(define crypt
(get-ffi-obj "crypt" libcrypt (_fun _string _string -> _bytes)))
(define set-key*
(get-ffi-obj "setkey" libcrypt (_fun _bytes -> _void)))
(define encrypt*
(get-ffi-obj "encrypt" libcrypt (_fun _bytes _bool -> _void)))
;; see the encrypt(3) man page for the following
(define (*crypt str key flag)
(set-key* key)
(let ([str (string8->keystring str)])
(encrypt* str flag)
(keystring->string8 str)))
(provide encrypt decrypt)
(define (encrypt str key) (*crypt (string->bytes/utf-8 str) key #f))
(define (decrypt str key) (bytes->string/utf-8 (*crypt str key #t)))
(define (string8->keystring str)
(let* ([len (bytes-length str)]
[str (cond
[(> len 8) (subbytes str 0 8)]
[(< len 8) (bytes-append str (make-bytes (- 8 len) 32))]
[else str])]
[bin (apply string-append
(map (lambda (x)
(let* ([bin (format "~b" x)]
[len (string-length bin)])
(if (< (string-length bin) 8)
(string-append (make-string (- 8 len) #\0) bin)
bin)))
(bytes->list str)))])
(list->bytes
(map (lambda (x)
(case x
[(#\0) 0] [(#\1) 1]
[else (error 'string8->keystring "something bad happened")]))
(string->list bin)))))
(define (keystring->string8 bin)
(unless (= 64 (bytes-length bin))
(error 'keystring->string8 "bad input size: ~s" bin))
(let ([bin (apply string (map (lambda (x)
(case x
[(0) #\0] [(1) #\1]
[else (error 'keystring->string8
"something bad happened")]))
(bytes->list bin)))])
(apply bytes
(let loop ([n (- 64 8)] [r '()])
(if (< n 0)
r
(loop (- n 8) (cons (string->number (substring bin n (+ n 8)) 2)
r)))))))

7
collects/ffi/cvector.rkt Normal file
View File

@ -0,0 +1,7 @@
#lang racket/base
(require "unsafe/cvector.ss")
(provide (except-out (all-from-out "unsafe/cvector.ss")
make-cvector*))

78
collects/ffi/esd.ss
View File

@ -1,78 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libesd (ffi-lib "libesd"))
;; Use this type to properly close the esd channel
(define-struct esd (num))
(define _esd
(make-ctype _int esd-num
(lambda (e)
(if (and (integer? e) (<= 0 e))
(let ([new (make-esd e)])
(register-finalizer new esd-close)
new)
(error '_esd "expecting an integer >=0, got: ~e" e)))))
;; Use this type to free collected samples
(define-struct sample (num))
(define _sample
(make-ctype _int sample-num
(lambda (s)
(if (and (integer? s) (<= 0 s))
(let ([new (make-sample s)])
(register-finalizer
new
(lambda (x)
(esd-sample-free x)))
new)
(error '_sample "expecting an integer >=0, got: ~e" s)))))
;; similar but no finalizer
(define _sample* (make-ctype _int sample-num make-sample))
(provide esd-open-sound)
(define esd-open-sound ; -> esd
(let ([f (get-ffi-obj "esd_open_sound" libesd (_fun _string -> _esd))])
(lambda host? (f (and (pair? host?) (car host?))))))
(define (with-default ffi)
(lambda args
(if (and (pair? args) (esd? (car args)))
(apply ffi args)
(apply ffi (default-esd) args))))
(define (c-name x)
(regexp-replaces x '((#rx"-" "_") (#rx"[*?]$" ""))))
(define-syntax defesd
(syntax-rules (: _esd)
[(_ name : [_esd] type ...)
(define name
(with-default
(get-ffi-obj (c-name 'name) libesd (_fun _esd type ...))))]
[(_ name : type ...)
(define name
(get-ffi-obj (c-name 'name) libesd (_fun type ...)))]))
(define-syntax defesd*
(syntax-rules ()
[(_ name x ...) (begin (provide name) (defesd name x ...))]))
(defesd esd-close : [_esd] -> _int)
(defesd* esd-send-auth : [_esd] -> _int)
(defesd* esd-lock : [_esd] -> _int)
(defesd* esd-unlock : [_esd] -> _int)
(defesd* esd-standby : [_esd] -> _int)
(defesd* esd-resume : [_esd] -> _int)
(defesd* esd-get-latency : [_esd] -> _int)
(defesd* esd-play-file : (prefix : _string) _file (fallback? : _bool) -> _int)
(defesd* esd-file-cache : [_esd] (prefix : _string) _file -> _sample)
(defesd* esd-sample-getid : [_esd] _string -> _sample*)
(defesd esd-sample-free : [_esd] _sample -> _int)
(defesd* esd-sample-play : [_esd] _sample -> _int)
(defesd* esd-sample-loop : [_esd] _sample -> _int)
(defesd* esd-sample-stop : [_esd] _sample -> _int)
(defesd* esd-sample-kill : [_esd] _sample -> _int)
(provide default-esd)
(define default-esd (make-parameter (esd-open-sound) esd?))

44
collects/ffi/examples/c-printf.ss Executable file → Normal file
View File

@ -1,13 +1,39 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/c-printf)
(require mzlib/foreign) (unsafe!)
(c-printf-is-dangerous!) ; see last example below
;; This code demonstrates how to interface `printf' which can be used with
;; different arities and types. Also, `printf' is unsafe unless this code will
;; parse the format string and make sure that all the types match, instead,
;; this code demonstrates how to provide unsafe bindings in a way that forces
;; users to admit that `(c-printf-is-dangerous!)'.
(c-printf "|%4d| |%04d| |%-4d|\n" 12 34 56)
(c-printf "|%4d| |%04d| |%-4d|\n" "12" "34" "56")
(c-printf "Bye bye sanity:\n")
(c-printf "%s\n" 0)
(c-printf "%s\n" 1234)
;; It's not too useful, since the C printf will obviously ignore
;; `current-output-port'.
(provide* (unsafe c-printf))
(define interfaces (make-hash))
(define (c-printf fmt . args)
(define itypes
(cons _string
(map (lambda (x)
(cond [(and (integer? x) (exact? x)) _int]
[(and (number? x) (real? x)) _double*]
[(string? x) _string]
[(bytes? x) _bytes]
[(symbol? x) _symbol]
[else (error 'c-printf
"don't know how to deal with ~e" x)]))
args)))
(let ([printf (hash-ref interfaces itypes
(lambda ()
;; Note: throws away the return value of printf
(let ([i (get-ffi-obj "printf" #f
(_cprocedure itypes _void))])
(hash-set! interfaces itypes i)
i)))])
(apply printf fmt args)))
(define-unsafer c-printf-is-dangerous!)

72
collects/ffi/examples/crypt.ss Executable file → Normal file
View File

@ -1,19 +1,63 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/crypt)
(require mzlib/foreign) (unsafe!)
(define passwd "foo")
(define salt "xz")
(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
(define libcrypt (ffi-lib "libcrypt"))
;; md5-based version
(set! salt "$1$somesalt$")
(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
(provide crypt)
(define crypt
(get-ffi-obj "crypt" libcrypt (_fun _string _string -> _bytes)))
(newline)
(define foo "foo bar")
(define key (string->bytes/utf-8 "my key"))
(printf ">>> ~s --encrypt--> ~s --decrypt--> ~s\n"
foo (encrypt foo key) (decrypt (encrypt foo key) key))
(define set-key*
(get-ffi-obj "setkey" libcrypt (_fun _bytes -> _void)))
(define encrypt*
(get-ffi-obj "encrypt" libcrypt (_fun _bytes _bool -> _void)))
;; see the encrypt(3) man page for the following
(define (*crypt str key flag)
(set-key* key)
(let ([str (string8->keystring str)])
(encrypt* str flag)
(keystring->string8 str)))
(provide encrypt decrypt)
(define (encrypt str key) (*crypt (string->bytes/utf-8 str) key #f))
(define (decrypt str key) (bytes->string/utf-8 (*crypt str key #t)))
(define (string8->keystring str)
(let* ([len (bytes-length str)]
[str (cond
[(> len 8) (subbytes str 0 8)]
[(< len 8) (bytes-append str (make-bytes (- 8 len) 32))]
[else str])]
[bin (apply string-append
(map (lambda (x)
(let* ([bin (format "~b" x)]
[len (string-length bin)])
(if (< (string-length bin) 8)
(string-append (make-string (- 8 len) #\0) bin)
bin)))
(bytes->list str)))])
(list->bytes
(map (lambda (x)
(case x
[(#\0) 0] [(#\1) 1]
[else (error 'string8->keystring "something bad happened")]))
(string->list bin)))))
(define (keystring->string8 bin)
(unless (= 64 (bytes-length bin))
(error 'keystring->string8 "bad input size: ~s" bin))
(let ([bin (apply string (map (lambda (x)
(case x
[(0) #\0] [(1) #\1]
[else (error 'keystring->string8
"something bad happened")]))
(bytes->list bin)))])
(apply bytes
(let loop ([n (- 64 8)] [r '()])
(if (< n 0)
r
(loop (- n 8) (cons (string->number (substring bin n (+ n 8)) 2)
r)))))))

99
collects/ffi/examples/esd.ss Executable file → Normal file
View File

@ -1,31 +1,78 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/esd)
(require mzlib/foreign) (unsafe!)
(printf "default = ~s\n" (default-esd))
(printf "latency = ~s\n" (esd-get-latency))
(printf "standby -> ~s\n" (esd-standby))
(sleep 1)
(printf "resume -> ~s\n" (esd-resume))
(define libesd (ffi-lib "libesd"))
(printf "Normal play...\n")
(esd-play-file "esd.ss" "~/stuff/sounds/Eeeooop.wav" #t)
(sleep 1)
;; Use this type to properly close the esd channel
(define-struct esd (num))
(define _esd
(make-ctype _int esd-num
(lambda (e)
(if (and (integer? e) (<= 0 e))
(let ([new (make-esd e)])
(register-finalizer new esd-close)
new)
(error '_esd "expecting an integer >=0, got: ~e" e)))))
(printf "Sample play...\n")
(let ((sample-id (esd-file-cache "foooo" "~/stuff/sounds/Eeeooop.wav")))
(printf ">>> sample = ~s\n" sample-id)
(printf ">>> getid -> ~s\n"
(esd-sample-getid "foooo:/home/eli/stuff/sounds/Eeeooop.wav"))
(printf "playing...\n")
(esd-sample-play sample-id)
(sleep 1)
(printf "looping...\n")
(esd-sample-loop sample-id)
(sleep 3)
(printf "enough!\n")
(esd-sample-stop sample-id)
(sleep 1)
(printf "bye.\n"))
;; Use this type to free collected samples
(define-struct sample (num))
(define _sample
(make-ctype _int sample-num
(lambda (s)
(if (and (integer? s) (<= 0 s))
(let ([new (make-sample s)])
(register-finalizer
new
(lambda (x)
(esd-sample-free x)))
new)
(error '_sample "expecting an integer >=0, got: ~e" s)))))
;; similar but no finalizer
(define _sample* (make-ctype _int sample-num make-sample))
(provide esd-open-sound)
(define esd-open-sound ; -> esd
(let ([f (get-ffi-obj "esd_open_sound" libesd (_fun _string -> _esd))])
(lambda host? (f (and (pair? host?) (car host?))))))
(define (with-default ffi)
(lambda args
(if (and (pair? args) (esd? (car args)))
(apply ffi args)
(apply ffi (default-esd) args))))
(define (c-name x)
(regexp-replaces x '((#rx"-" "_") (#rx"[*?]$" ""))))
(define-syntax defesd
(syntax-rules (: _esd)
[(_ name : [_esd] type ...)
(define name
(with-default
(get-ffi-obj (c-name 'name) libesd (_fun _esd type ...))))]
[(_ name : type ...)
(define name
(get-ffi-obj (c-name 'name) libesd (_fun type ...)))]))
(define-syntax defesd*
(syntax-rules ()
[(_ name x ...) (begin (provide name) (defesd name x ...))]))
(defesd esd-close : [_esd] -> _int)
(defesd* esd-send-auth : [_esd] -> _int)
(defesd* esd-lock : [_esd] -> _int)
(defesd* esd-unlock : [_esd] -> _int)
(defesd* esd-standby : [_esd] -> _int)
(defesd* esd-resume : [_esd] -> _int)
(defesd* esd-get-latency : [_esd] -> _int)
(defesd* esd-play-file : (prefix : _string) _file (fallback? : _bool) -> _int)
(defesd* esd-file-cache : [_esd] (prefix : _string) _file -> _sample)
(defesd* esd-sample-getid : [_esd] _string -> _sample*)
(defesd esd-sample-free : [_esd] _sample -> _int)
(defesd* esd-sample-play : [_esd] _sample -> _int)
(defesd* esd-sample-loop : [_esd] _sample -> _int)
(defesd* esd-sample-stop : [_esd] _sample -> _int)
(defesd* esd-sample-kill : [_esd] _sample -> _int)
(provide default-esd)
(define default-esd (make-parameter (esd-open-sound) esd?))

3073
collects/ffi/examples/magick.ss Executable file → Normal file
View File

File diff suppressed because it is too large Load Diff

364
collects/ffi/examples/sndfile.ss Executable file → Normal file
View File

@ -1,33 +1,343 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/sndfile)
(require mzlib/foreign) (unsafe!)
;; (require swindle)
(define libsndfile (ffi-lib "libsndfile"))
(define (add-half x y)
(/ (+ x (* y 0.5)) 1.5))
;; ==================== Types etc ====================
(define (repeated-list x n)
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons x r)))))
;; This is the scheme represtenatation of the soundfile that is handeled by
;; libsndfile.
(let-values ([(data meta) (read-sound* "x.wav")])
(printf ">>> data-length: ~s\n>>> meta: ~s\n" (length data) meta)
(let* ([data data #;
(list-of (list (add-half (1st x) (1st y))
(add-half (2nd x) (2nd y)))
(x <- data
and
y <- (append (repeated-list (list 0.0 0.0) 11025) data)
and
i <- 0.1 0.12 ..))])
(printf "writing to y.wav\n")
(write-sound* "y.wav"
;data
;(append data (reverse data))
(append data (reverse (map reverse data)))
`((artist "Eli") (comment "Comment") (title "Title")
(date "1/1/1999") (software "mzscheme")
,@meta))))
;; In libsndfile the sndfile object is represented as a pointer. When
;; translating scheme->c the struct will just return the pointer. When
;; translating from c->scheme, ie. creating the object in scheme it will be
;; wrapped by an object finalizer that uses the libsndfile fuction sf_close that
;; returns a 0 upon successful termination or an error.
(define-struct sndfile (ptr [info #:mutable]))
(define _sndfile
(make-ctype _pointer sndfile-ptr
(lambda (p)
(if p
(make-sndfile p #f)
(error '_sndfile "got a NULL pointer (bad info?)")))))
;; sf_count_t is a count type that depends on the operating system however it
;; seems to be a long int for all the supported ones so in this scase we just
;; define it as two ints.
(define _sf-count-t _int64)
(define _sf-mode
(_bitmask '(sfm-read = #x10
sfm-write = #x20
sfm-rdwrt = #x30)))
(define str-types '(title copyright software artist comment date))
(define _sf-str-type (_enum (cons "dummy" str-types))) ; begins from 1
(define _sf-format
(let ([majors ; Major formats
'((wav #x010000) ; Microsoft WAV format (little endian)
(aiff #x020000) ; Apple/SGI AIFF format (big endian)
(au #x030000) ; Sun/NeXT AU format (big endian)
(raw #x040000) ; RAW PCM data
(paf #x050000) ; Ensoniq PARIS file format
(svx #x060000) ; Amiga IFF / SVX8 / SV16 format
(nist #x070000) ; Sphere NIST format
(voc #x080000) ; VOC files
(ircam #x0A0000) ; Berkeley/IRCAM/CARL
(w64 #x0B0000) ; Sonic Foundry's 64 bit RIFF/WAV
(mat4 #x0C0000) ; Matlab (tm) V4.2 / GNU Octave 2.0
(mat5 #x0D0000) ; Matlab (tm) V5.0 / GNU Octave 2.1
(pvf #x0E0000) ; Portable Voice Format
(xi #x0F0000) ; Fasttracker 2 Extended Instrument
(htk #x100000) ; HMM Tool Kit format
(sds #x110000) ; Midi Sample Dump Standard
(avr #x120000) ; Audio Visual Research
(wavex #x130000) ; MS WAVE with WAVEFORMATEX
)]
[subtypes ; Subtypes from here on
'((pcm-s8 #x0001) ; Signed 8 bit data
(pcm-16 #x0002) ; Signed 16 bit data
(pcm-24 #x0003) ; Signed 24 bit data
(pcm-32 #x0004) ; Signed 32 bit data
(pcm-u8 #x0005) ; Unsigned 8 bit data (WAV and RAW only)
(float #x0006) ; 32 bit float data
(double #x0007) ; 64 bit float data
(ulaw #x0010) ; U-Law encoded
(alaw #x0011) ; A-Law encoded
(ima-adpcm #x0012) ; IMA ADPCM
(ms-adpcm #x0013) ; Microsoft ADPCM
(gsm610 #x0020) ; GSM 6.10 encoding
(vox-adpcm #x0021) ; OKI / Dialogix ADPCM
(g721-32 #x0030) ; 32kbs G721 ADPCM encoding
(g723-24 #x0031) ; 24kbs G723 ADPCM encoding
(g723-40 #x0032) ; 40kbs G723 ADPCM encoding
(dwvw-12 #x0040) ; 12 bit Delta Width Variable Word encoding
(dwvw-16 #x0041) ; 16 bit Delta Width Variable Word encoding
(dwvw-24 #x0042) ; 24 bit Delta Width Variable Word encoding
(dwvw-n #x0043) ; N bit Delta Width Variable Word encoding
(dpcm-8 #x0050) ; 8 bit differential PCM (XI only)
(dpcm-16 #x0051) ; 16 bit differential PCM (XI only)
)]
[endians ; Endian-ness options
'((file #x00000000) ; Default file endian-ness
(little #x10000000) ; Force little endian-ness
(big #x20000000) ; Force big endian-ness
(cpu #x30000000) ; Force CPU endian-ness
)]
[submask #x0000FFFF]
[typemask #x0FFF0000]
[endmask #x30000000])
(define (rev-find n l)
(let loop ([l l])
(cond [(null? l) #f]
[(eq? n (cadar l)) (caar l)]
[else (loop (cdr l))])))
(make-ctype _int
(lambda (syms)
(let ([major #f] [subtype #f] [endian #f])
(for-each
(lambda (sym)
(cond [(assq sym majors) =>
(lambda (x)
(if major
(error 'sf-format "got two major modes: ~s" syms)
(set! major (cadr x))))]
[(assq sym subtypes) =>
(lambda (x)
(if subtype
(error 'sf-format "got two subtype modes: ~s" syms)
(set! subtype (cadr x))))]
[(assq sym endians) =>
(lambda (x)
(if endian
(error 'sf-format "got two endian modes: ~s" syms)
(set! endian (cadr x))))]
[else (error 'sf-format "got a bad symbol: ~s" sym)]))
(if (list? syms) syms (list syms)))
(bitwise-ior (or major 0) (or subtype 0) (or endian 0))))
(lambda (n)
(let ([subtype (rev-find (bitwise-and n submask) subtypes)]
[major (rev-find (bitwise-and n typemask) majors)]
[endian (rev-find (bitwise-and n endmask) endians)])
(unless subtype
(error 'sf-format "got a bad number from C for subtype: ~x"
(bitwise-and n submask)))
(unless major
(error 'sf-format "got a bad number from C for major: ~x"
(bitwise-and n typemask)))
(unless endian
(error 'sf-format "got a bad number from C for endian: ~x"
(bitwise-and n endmask)))
(list major subtype endian))))))
(define-cstruct _sf-info
((frames _sf-count-t)
(samplerate _int)
(channels _int)
(format _sf-format)
(sections _int)
(seekable _bool)))
;; ==================== Utilities ====================
(define-syntax defsndfile
(syntax-rules (:)
[(_ name : type ...)
(define name
(get-ffi-obj (regexp-replaces 'name '((#rx"-" "_")))
libsndfile (_fun type ...)))]))
(define (n-split l n)
(let loop ([l l][i 0][a2 null][a null])
(cond
[(null? l) (let ([a (if (null? a2)
a
(cons (reverse a2) a))])
(reverse a))]
[(= i n) (loop l 0 null (cons (reverse a2) a))]
[else (loop (cdr l) (add1 i) (cons (car l) a2) a)])))
;; ==================== sndfile API ====================
(defsndfile sf-close : _sndfile -> _int)
(defsndfile sf-open : (path mode . info) ::
(path : _file)
(mode : _sf-mode)
(info : _sf-info-pointer
= (if (pair? info) (car info) (make-sf-info 0 0 0 '() 0 #f)))
-> (sf : _sndfile)
-> (begin (set-sndfile-info! sf info) sf))
(defsndfile sf-format-check : _sf-info-pointer -> _bool)
(defsndfile sf-readf-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-get-string : _sndfile _sf-str-type -> _string)
(defsndfile sf-set-string : _sndfile _sf-str-type _string -> _bool)
;; ==================== Utilities for the Scheme interface ====================
(define (get-strings sndfile)
(let loop ([sts str-types] [r '()])
(cond [(null? sts) (reverse r)]
[(sf-get-string sndfile (car sts)) =>
(lambda (x)
(loop (cdr sts) (cons (list (car sts) (string-copy x)) r)))]
[else (loop (cdr sts) r)])))
(define (set-strings sndfile meta)
(for-each (lambda (st)
(cond [(assq st meta) =>
(lambda (x) (sf-set-string sndfile st (cadr x)))]))
str-types))
(define (read-sound-internal file meta?)
(let* ([sndfile (sf-open file 'sfm-read)]
[strings (and meta? (get-strings sndfile))]
[info (sndfile-info sndfile)]
[frames (sf-info-frames info)]
[channels (sf-info-channels info)]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[readf (case (sample-type)
[(short) sf-readf-short]
[(int) sf-readf-int]
[(float) sf-readf-double])]
[cblock (malloc (* frames channels) stype)]
[num-read (readf sndfile cblock frames)]
[data (cblock->list cblock stype (* num-read channels))]
[data (if (> channels 1) (n-split data channels) data)])
(unless (= frames num-read)
(error 'read-sound-internal
"wanted ~s frames, but got ~s" frames num-read))
(begin0 (if meta?
(values data `((frames ,frames)
(samplerate ,(sf-info-samplerate info))
(channels ,channels)
(format ,(sf-info-format info))
(sections ,(sf-info-sections info))
,@strings))
data)
(sf-close sndfile))))
(define (frame-list->cblock data frames channels type)
(cond
[(null? data) #f]
[(and (= 1 channels) (not (pair? (car data)))) (list->cblock data type)]
[else
(let ([test (lambda (x)
(and (list? x) (= channels (length x)) (andmap number? x)))])
(unless (andmap test data)
(error 'frame-list->cblock "got a bad frame: ~e"
(ormap (lambda (x) (and (not (test x)) x)) data))))
(let ([cblock (malloc (* channels frames) type)]
[i 0])
(let loop ([d data])
(cond [(number? d) (ptr-set! cblock type i d) (set! i (add1 i))]
[(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)]))
(define (write-sound-internal file data meta)
(let* ([frames (length data)]
[channels (if (or (null? data) (not (pair? (car data))))
1 ; 1-channel if no data, or data is not made of lists
(length (car data)))]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[writef (case (sample-type)
[(short) sf-writef-short]
[(int) sf-writef-int]
[(float) sf-writef-double])]
[cblock (frame-list->cblock data frames channels stype)]
[format (cond [(assq 'format meta) => cadr]
[else (guess-format file)])]
[samplerate (cond [(assq 'samplerate meta) => cadr]
[else (default-samplerate)])]
[info (make-sf-info frames samplerate channels format 1 #f)]
[_ (unless (sf-format-check info)
(error 'write-sound-internal "bad format: ~s" format))]
[sndfile (sf-open file 'sfm-write info)]
[_ (set-strings sndfile meta)]
[num-write (writef sndfile cblock frames)])
(unless (= frames num-write)
(error 'write-sound-internal
"wanted to write ~s frames, but wrote only ~s" frames num-write))
(sf-close sndfile)
(void)))
(define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file))
(#rx"\\.wave?" (wav pcm-16 file))
(#rx"\\.au" (au pcm-16 file))
(#rx"\\.snd" (au pcm-16 file))
(#rx"\\.svx" (svx pcm-16 file))
(#rx"\\.paf" (paf pcm-16 big))
(#rx"\\.fap" (paf pcm-16 little))
(#rx"\\.nist" (nist pcm-16 little))
(#rx"\\.ircam" (ircam pcm-16 little))
(#rx"\\.sf" (ircam pcm-16 little))
(#rx"\\.voc" (voc pcm-16 file))
(#rx"\\.w64" (w64 pcm-16 file))
(#rx"\\.raw" (raw pcm-16 cpu))
(#rx"\\.mat4" (mat4 pcm-16 little))
(#rx"\\.mat5" (mat5 pcm-16 little))
(#rx"\\.mat" (mat4 pcm-16 little))
(#rx"\\.pvf" (pvf pcm-16 file))
(#rx"\\.sds" (sds pcm-16 file))
(#rx"\\.xi" (xi dpcm-16 file))))
(define (guess-format filename)
(let loop ([xs file-format-table])
(cond [(null? xs) (default-file-format)]
[(regexp-match (caar xs) filename) (cadar xs)]
[else (loop (cdr xs))])))
;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, or 'float
(provide sample-type)
(define sample-type
(make-parameter
'float (lambda (x)
(if (memq x '(short int float))
x (error 'sample-type "bad type: ~s" x)))))
;; TODO: add a parameter that will determine if you get a list, vector or
;; srfi/4-like thing. possibly also determine if a list/vector gets automatic
;; treatment of 1-channel - not converting it into a list of singleton lists.
(provide default-samplerate)
(define default-samplerate
(make-parameter
11025 (lambda (x)
(if (and (integer? x) (positive? x))
x (error 'default-samplerate "bad samplerate: ~s" x)))))
(provide default-file-format)
(define default-file-format ; no guard, but should be good for _sf-format
(make-parameter '(wav pcm-16 file)))
(provide read-sound)
(define (read-sound file)
(read-sound-internal file #f))
(provide read-sound*)
(define (read-sound* file)
(read-sound-internal file #t))
(provide write-sound)
(define (write-sound file data)
(write-sound-internal file data '()))
;; meta is used only for samplerate & format
(provide write-sound*)
(define (write-sound* file data meta)
(write-sound-internal file data meta))

66
collects/ffi/examples/tcl.ss Executable file → Normal file
View File

@ -1,25 +1,49 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/tcl)
(require mzlib/foreign) (unsafe!)
(define (tcldemo . strs)
(for-each (lambda (s)
(printf "> ~a\n" s)
(with-handlers ([void (lambda (e)
(display (if (exn? e) (exn-message e) e)
(current-error-port))
(newline (current-error-port)))])
(printf "~a\n" (eval-tcl s))))
strs))
(define libtcl (ffi-lib "libtcl"))
(tcldemo "puts 123"
"puts $a"
"set a {this is some stupid string}"
"set b [list a a]"
"set c {[list $a $a]}"
"puts \"a = \\\"$a\\\"\""
"puts \"b = \\\"$b\\\"\""
"puts \"c = \\\"$c\\\"\""
"puts \"even better... \\\"[expr $c]\\\"\"")
(provide current-interp create-interp eval-tcl)
(define current-interp
(make-parameter
#f (lambda (x)
(if (and x (cpointer? x))
x
(error 'tcl:current-interp
"expecting a non-void C pointer, got ~s" x)))))
;; This creates _interp as a type to be used for functions that return an
;; interpreter that should be destroyed with delete-interp.
(define _interp
(make-ctype _pointer #f ; no op when going to C
(lambda (interp)
(when interp (register-finalizer interp delete-interp))
interp)))
;; This is for arguments that always use the value of current-interp
(define-fun-syntax _interp*
(syntax-id-rules ()
[_ (type: _interp expr: (current-interp))]))
(define create-interp
(get-ffi-obj "Tcl_CreateInterp" libtcl (_fun -> _interp)))
(define delete-interp
(let ([f (get-ffi-obj "Tcl_DeleteInterp" libtcl (_fun _interp -> _void))])
(lambda (i) (f i))))
(current-interp (create-interp))
(define get-string-result
(get-ffi-obj "Tcl_GetStringResult" libtcl (_fun _interp -> _string)))
(define _tclret
(make-ctype (_enum '(ok error return break continue))
(lambda (x) (error "tclret is only for return values"))
(lambda (x)
(when (eq? x 'error) (error 'tcl (get-string-result (current-interp))))
x)))
(define eval-tcl
(get-ffi-obj "Tcl_Eval" libtcl (_fun _interp* (expr : _string) -> _tclret)))

13
collects/ffi/examples/use-c-printf.ss Executable file
View File

@ -0,0 +1,13 @@
#! /usr/bin/env racket
#lang racket/base
(require "c-printf.ss")
(c-printf-is-dangerous!) ; see last example below
(c-printf "|%4d| |%04d| |%-4d|\n" 12 34 56)
(c-printf "|%4d| |%04d| |%-4d|\n" "12" "34" "56")
(c-printf "Bye bye sanity:\n")
(c-printf "%s\n" 0)
(c-printf "%s\n" 1234)

19
collects/ffi/examples/use-crypt.ss Executable file
View File

@ -0,0 +1,19 @@
#! /usr/bin/env racket
#lang racket/base
(require "crypt.ss")
(define passwd "foo")
(define salt "xz")
(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
;; md5-based version
(set! salt "$1$somesalt$")
(printf ">>> crypt(~s,~s) = ~s\n" passwd salt (crypt passwd salt))
(newline)
(define foo "foo bar")
(define key (string->bytes/utf-8 "my key"))
(printf ">>> ~s --encrypt--> ~s --decrypt--> ~s\n"
foo (encrypt foo key) (decrypt (encrypt foo key) key))

31
collects/ffi/examples/use-esd.ss Executable file
View File

@ -0,0 +1,31 @@
#! /usr/bin/env racket
#lang racket/base
(require "esd.ss")
(printf "default = ~s\n" (default-esd))
(printf "latency = ~s\n" (esd-get-latency))
(printf "standby -> ~s\n" (esd-standby))
(sleep 1)
(printf "resume -> ~s\n" (esd-resume))
(printf "Normal play...\n")
(esd-play-file "esd.ss" "~/stuff/sounds/Eeeooop.wav" #t)
(sleep 1)
(printf "Sample play...\n")
(let ((sample-id (esd-file-cache "foooo" "~/stuff/sounds/Eeeooop.wav")))
(printf ">>> sample = ~s\n" sample-id)
(printf ">>> getid -> ~s\n"
(esd-sample-getid "foooo:/home/eli/stuff/sounds/Eeeooop.wav"))
(printf "playing...\n")
(esd-sample-play sample-id)
(sleep 1)
(printf "looping...\n")
(esd-sample-loop sample-id)
(sleep 3)
(printf "enough!\n")
(esd-sample-stop sample-id)
(sleep 1)
(printf "bye.\n"))

316
collects/ffi/examples/use-magick.ss Executable file
View File

@ -0,0 +1,316 @@
#! /usr/bin/env racket
#lang racket/base
(require "magick.ss" (for-syntax racket/base))
(define-syntax (test stx)
(syntax-case stx ()
[(_ (func arg ...))
(with-syntax ([(tmp ...) (generate-temporaries #'(arg ...))])
#'(let ([tmp arg] ...)
(printf ">>> ~s~s\n" 'func `(,tmp ...))
(let ([r (func tmp ...)])
(printf " -> ~s\n" r)
r)))]))
;; (test (MagickGetPackageName))
;; (test (MagickGetCopyright))
;; (test (MagickGetVersion))
;; (test (MagickGetReleaseDate))
;; (test (MagickGetQuantumDepth))
;; (test (MagickQueryConfigureOptions "CO*"))
;; (test (MagickQueryFonts "Cou*"))
;; (test (MagickQueryFormats "J*"))
;; (test (MagickGetHomeURL))
;; (define w (test (NewMagickWand)))
;; (test (MagickGetImageFilename w))
;; (test (MagickReadImage w "~/html/images/eli.jpg"))
(define w (test (MagickReadImage "~/html/images/eli.jpg")))
;; (test (MagickGetImageFilename w))
;; (test (MagickGetImageFilename w))
;; (test (MagickGetImageFormat w))
;; (test (MagickGetImageCompression w))
;; (test (MagickGetImageDispose w))
;; (test (MagickGetImageType w))
;; (test (MagickGetImageInterlaceScheme w))
;; (test (MagickGetImageIndex w))
;; (test (MagickGetImageSize w))
;; (test (MagickGetImageSignature w))
;; (test (MagickBlurImage w 2.0 1.0))
;; ;; (test (MagickReadImage w "~/html/images/eeli.jpg"))
;; ;; (test (MagickGetException w))
;; (test (MagickSwirlImage w 90.0))
;; (test (MagickWaveImage w 4.0 40.0))
;; (test (MagickCharcoalImage w 5.0 0.7))
;; (test (MagickGetImageCompose w))
;; (test (MagickGetImageColorspace w))
;; (test (MagickCommentImage w "This is my test image"))
;; (test (MagickWriteImage w "~/tmp/x.jpg"))
;; (test (MagickDisplayImage w #f))
;; (test (MagickDescribeImage w))
;; (test (MagickGetImageWidth w))
;; (test (MagickGetImageHeight w))
;; (test (MagickGetImageChannelDepth w 'RedChannel))
;; (test (MagickGetImageExtrema w))
;; (test (MagickGetImageChannelExtrema w 'RedChannel))
;; (test (MagickGetImageChannelMean w 'RedChannel))
;; (test (MagickGetImageColors w))
;; (test (MagickGetImageDelay w))
;; (test (MagickSetImageDelay w 20))
;; (test (MagickGetImageDelay w))
;; (test (MagickGetImageDepth w))
;; (test (MagickSetImageDepth w 2))
;; (test (MagickGetImageDepth w))
;; (test (MagickGetImageIterations w))
;; (test (MagickSetImageIterations w 4))
;; (test (MagickGetImageIterations w))
;; (test (MagickGetSamplingFactors w))
;; (test (MagickSetSamplingFactors w '(2.0 1.0 0.5)))
;; (test (MagickGetSamplingFactors w))
;; (test (MagickGetImageRenderingIntent w))
;; (test (MagickSetImageRenderingIntent w 'SaturationIntent))
;; (test (MagickGetImageRenderingIntent w))
;; (test (MagickGetImageUnits w))
;; (test (MagickSetImageUnits w 'PixelsPerInchResolution))
;; (test (MagickGetImageUnits w))
;; (test (MagickGetImageVirtualPixelMethod w))
;; (test (MagickSetImageVirtualPixelMethod w 'EdgeVirtualPixelMethod))
;; (test (MagickGetImageVirtualPixelMethod w))
;; (test (MagickGetImageWhitePoint w))
;; (test (MagickSetImageWhitePoint w 3.0 4.0))
;; (test (MagickGetImageWhitePoint w))
;; (test (MagickGetImageResolution w))
;; (test (MagickSetImageResolution w 33.0 33.0))
;; (test (MagickGetImageResolution w))
;; (test (MagickGetSize w))
;; (test (MagickSetSize w 20 20))
;; (test (MagickGetSize w))
;; (test (MagickGetImageProfile w "ICC"))
;; (test (MagickAdaptiveThresholdImage w 2 2 0))
;; (test (MagickAddNoiseImage w 'LaplacianNoise))
;; (test (MagickEmbossImage w 1.0 0.5))
;; (test (MagickEvaluateImage w 'MaxEvaluateOperator 30768.0))
;; (test (MagickEvaluateImage w 'MinEvaluateOperator 34768.0))
;; (test (MagickEvaluateImageChannel w 'RedChannel 'MaxEvaluateOperator 28768.0))
;; (test (MagickEvaluateImageChannel w 'RedChannel 'MinEvaluateOperator 36768.0))
;; (test (MagickGetImageGamma w))
;; (test (MagickGammaImage w 0.5))
;; (test (MagickSetImageGamma w 0.5))
;; (test (MagickGetImageGamma w))
;; (test (MagickGaussianBlurImage w 5.0 2.0))
;; (test (MagickGaussianBlurImageChannel w 'RedChannel 1.0 0.1))
;; (test (MagickGetImageRedPrimary w))
;; (test (MagickSetImageRedPrimary w 20.0 20.0))
;; (test (MagickGetImageRedPrimary w))
;; (test (MagickTransformImage w "120x120+10+10" "100x100+0+0"))
;; (test (MagickThresholdImage w 32768.0))
;; (test (MagickThresholdImageChannel w 'RedChannel 32768.0))
;; (test (MagickSpreadImage w 2.0))
;; (test (MagickOilPaintImage w 3.0))
;; (test (MagickSpliceImage w 100 100 50 50))
;; (test (MagickSolarizeImage w 2.0))
;; (test (MagickShaveImage w 20 50))
;; (test (MagickSharpenImage w 10.0 9.0))
;; (test (MagickPosterizeImage w 2 #t))
;; (test (MagickContrastImage w 20))
;; (test (MagickEdgeImage w 5.0))
;; (test (MagickImplodeImage w 0.5))
;; (test (MagickConvolveImage
;; w '(( 0.0 -1.0 0.0) ; sharpen
;; (-1.0 5.0 -1.0)
;; ( 0.0 -1.0 0.0))))
;; (test (MagickConvolveImage ; sharpen++
;; w '((-1.0 -1.0 -1.0)
;; (-1.0 9.0 -1.0)
;; (-1.0 -1.0 -1.0))))
;; (test (MagickConvolveImage ; blur
;; w '(( 1.0 1.0 1.0)
;; ( 1.0 1.0 1.0)
;; ( 1.0 1.0 1.0))))
;; (test (MagickConvolveImage ; edge enhance
;; w '(( 0.0 0.0 0.0)
;; (-1.0 1.0 0.0)
;; ( 0.0 0.0 0.0))))
;; (test (MagickConvolveImage ; edge enhance++
;; w '((-1.0 0.0 1.0)
;; (-1.0 0.0 1.0)
;; (-1.0 0.0 1.0))))
;; (test (MagickConvolveImage ; edge detect
;; w '(( 0.0 1.0 0.0)
;; ( 1.0 -4.0 1.0)
;; ( 0.0 1.0 0.0))))
;; (test (MagickConvolveImage ; emboss
;; w '((-2.0 -1.0 0.0)
;; (-1.0 1.0 1.0)
;; ( 0.0 1.0 2.0))))
;; (test (MagickConvolveImageChannel
;; w 'RedChannel '((1.0 0.0 0.0 0.0 1.0)
;; (0.0 0.0 0.0 0.0 0.0)
;; (0.0 0.0 -1.0 0.0 0.0)
;; (0.0 0.0 0.0 0.0 0.0)
;; (1.0 0.0 0.0 0.0 1.0))))
;; (define pixels (test (MagickGetImagePixels w 0 0 40 40 "RGB" 'ShortPixel)))
;; (test (MagickSetImagePixels
;; w 0 0 "RGB" 'ShortPixel
;; (let ([pixels (map (lambda (x) (append x x))
;; pixels)])
;; (append pixels
;; (map (lambda (row)
;; (map (lambda (pixel)
;; (list (cadr pixel) (caddr pixel) (car pixel))
;; ;; (map (lambda (v) (- 65535 v)) pixel)
;; )
;; row))
;; pixels)))))
;; (test (MagickLabelImage w "FOO"))
;; (test (MagickLevelImage w 20000.0 1.0 45535.0))
;; (test (MagickMedianFilterImage w 2.0))
;; (test (MagickModulateImage w 100.0 100.0 40.0))
;; (test (MagickMotionBlurImage w 10.0 10.0 60.0))
;; (test (MagickNegateImage w #f))
;; (test (MagickNegateImageChannel w 'GreenChannel #f))
;; (test (MagickNormalizeImage w))
;; (test (MagickRaiseImage w 10 10 20 20 #f))
;; (MagickMinifyImage w) (MagickMinifyImage w) (MagickMinifyImage w)
;; (test (MagickResampleImage w 576.0 576.0 'UndefinedFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'BoxFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'TriangleFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'HermiteFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'HanningFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'HammingFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'BlackmanFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'GaussianFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'QuadraticFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'CubicFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'CatromFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'MitchellFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'LanczosFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'BesselFilter 1.0))
;; (test (MagickResampleImage w 576.0 576.0 'SincFilter 1.0))
;; (test (MagickOpaqueImage w "black" "yellow" 20000.0))
;; (test (MagickColorFloodfillImage w "yellow" 20000.0 "black" 0 0))
;; (test (MagickColorFloodfillImage w "yellow" 20000.0 #f 0 0))
;; (test (MagickColorFloodfillImage w '(65535 0 0) 20000.0 "black" 0 0))
;; (test (MagickColorFloodfillImage w '(65535 0 0 32737) 20000.0 "black" 0 0))
;; (test (MagickTransparentImage w "black" 16384 20000.0))
;; (test (MagickWriteImage w "~/tmp/x.png"))
;; (test (MagickResetIterator w))
;; (test (MagickGetImageProfile w "ICC"))
;; (test (MagickSetImageProfile w "ICC" "foo"))
;; (test (MagickGetImageProfile w "ICC"))
;; (test (MagickGetImageBackgroundColor w))
;; (test (MagickDisplayImage w))
;; (for-each
;; (lambda (p) (MagickDisplayImage (test (MagickPreviewImages w p))))
;; '(UndefinedPreview RotatePreview ShearPreview RollPreview HuePreview
;; SaturationPreview BrightnessPreview GammaPreview SpiffPreview DullPreview
;; GrayscalePreview QuantizePreview DespecklePreview ReduceNoisePreview
;; AddNoisePreview SharpenPreview BlurPreview ThresholdPreview
;; EdgeDetectPreview SpreadPreview SolarizePreview ShadePreview RaisePreview
;; SegmentPreview SwirlPreview ImplodePreview WavePreview OilPaintPreview
;; CharcoalDrawingPreview JPEGPreview))
;; (test (MagickDisplayImage
;; (MagickFxImageChannel w 'AllChannels "(p[-4,-4].r+p[4,4].g)/2")))
;; (test (MagickMagnifyImage w))
;; (let ([ww (CloneMagickWand w)])
;; (test (MagickMinifyImage ww))
;; (test (MagickMinifyImage ww))
;; (test (MagickMinifyImage ww))
;; (test (MagickDisplayImage (MagickTextureImage w ww))))
;; (test (MagickChopImage w 100 100 10 10))
;; (test (MagickCropImage w 100 100 10 10))
;; (test (MagickDisplayImage w))
;; (define w1 (test (CloneMagickWand w)))
;; (test (MagickBlurImage w1 1.0 0.18))
;; (define t (cadr (test (MagickCompareImageChannels
;; w w1 'RedChannels 'MeanSquaredErrorMetric))))
;; (test (MagickDisplayImage t))
;; (test (MagickReadImage w "~/html/images/EliRegina.jpg"))
;; (define morph (test (MagickMorphImages w 20)))
;; (test (MagickWriteImage morph "~/tmp/x.gif"))
;; (MagickAnimateImages morph)
;; (let ([x (test (MagickWriteImageBlob w))])
;; (with-output-to-file "~/tmp/x" (lambda () (display x)) 'truncate)
;; (let ([ww (NewMagickWand)])
;; (test (MagickReadImageBlob ww x))
;; (MagickDisplayImage ww)))
;; (define w (test (NewMagickWand)))
;; (test (MagickReadImage w "~/html/images/spinlambda.gif"))
;; (test (MagickDisplayImage (test (MagickAppendImages w #f))))
;; (test (MagickDisplayImage (MagickAverageImages w)))
;; (test (MagickDisplayImage (test (MagickDeconstructImages w))))
;; (MagickAnimateImages w)
;; (let ([y (NewPixelWand "yellow")]
;; [c (test (PixelGetQuantumColor "yellow"))]
;; [r (NewPixelWand "red")]
;; [rgb (lambda (p)
;; (map (lambda (f) (f p))
;; (list PixelGetRedQuantum
;; PixelGetGreenQuantum
;; PixelGetBlueQuantum)))])
;; (printf ">>> y = ~s\n" (rgb y))
;; (printf ">>> r1 = ~s\n" (rgb r))
;; (PixelSetQuantumColor r c)
;; (printf ">>> r2 = ~s\n" (rgb r)))
;; (define i (test (NewPixelRegionIterator w 0 0 10 10)))
;; (test (PixelSetIteratorRow i 5))
;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
;; (test (map PixelGetRedQuantum (PixelGetNextRow i)))
(define d (test (NewDrawingWand)))
;; (test (DrawGetTextEncoding d))
;; (test (MagickQueryFonts "Cou*"))
(test (DrawSetFont d "Courier-Bold"))
(test (DrawGetFont d))
(test (DrawSetFontSize d 96.0))
(test (DrawSetFontStretch d 'UltraCondensedStretch))
(test (DrawSetFontStyle d 'ObliqueStyle))
(test (DrawSetFontWeight d 24))
(test (DrawSetGravity d 'CenterGravity))
(test (DrawGetStrokeDashArray d))
(test (DrawSetStrokeDashArray d '(20.0 20.0)))
(test (DrawGetStrokeDashArray d))
(test (DrawSetStrokeColor d "red"))
(test (DrawSetStrokeAntialias d #t))
(test (DrawSetStrokeWidth d 5.0))
(test (DrawSetStrokeLineCap d 'RoundCap))
(test (DrawSetStrokeOpacity d 0.5))
;; (test (DrawLine d 0.0 0.0 200.0 200.0))
(define line '((10.0 10.0) (100.0 100.0) (100.0 10.0) (50.0 20.0)))
;; (test (DrawPolyline d line))
;; (test (DrawPolygon d line))
;; (test (DrawBezier d line))
;; (test (DrawLine d 0.0 0.0 100.0 100.0))
;; (test (DrawLine d 5.0 0.0 105.0 100.0))
;; (test (DrawLine d 10.0 0.0 110.0 100.0))
(test (DrawAffine d '(0.0 1.0 1.0 0.5 0.0 0.0)))
(test (DrawAnnotation d 0.0 0.0 "FOO"))
;; (test (DrawArc d 0.0 0.0 100.0 100.0 0.0 270.0))
;; (test (DrawCircle d 50.0 50.0 50.0 0.0))
(test (MagickDrawImage w d))
(test (MagickDisplayImage w))

33
collects/ffi/examples/use-sndfile.ss Executable file
View File

@ -0,0 +1,33 @@
#! /usr/bin/env racket
#lang racket/base
(require "sndfile.ss")
;; (require swindle)
(define (add-half x y)
(/ (+ x (* y 0.5)) 1.5))
(define (repeated-list x n)
(let loop ([n n] [r '()])
(if (zero? n) r (loop (sub1 n) (cons x r)))))
(let-values ([(data meta) (read-sound* "x.wav")])
(printf ">>> data-length: ~s\n>>> meta: ~s\n" (length data) meta)
(let* ([data data #;
(list-of (list (add-half (1st x) (1st y))
(add-half (2nd x) (2nd y)))
(x <- data
and
y <- (append (repeated-list (list 0.0 0.0) 11025) data)
and
i <- 0.1 0.12 ..))])
(printf "writing to y.wav\n")
(write-sound* "y.wav"
;data
;(append data (reverse data))
(append data (reverse (map reverse data)))
`((artist "Eli") (comment "Comment") (title "Title")
(date "1/1/1999") (software "mzscheme")
,@meta))))

25
collects/ffi/examples/use-tcl.ss Executable file
View File

@ -0,0 +1,25 @@
#! /usr/bin/env racket
#lang racket/base
(require "tcl.ss")
(define (tcldemo . strs)
(for-each (lambda (s)
(printf "> ~a\n" s)
(with-handlers ([void (lambda (e)
(display (if (exn? e) (exn-message e) e)
(current-error-port))
(newline (current-error-port)))])
(printf "~a\n" (eval-tcl s))))
strs))
(tcldemo "puts 123"
"puts $a"
"set a {this is some stupid string}"
"set b [list a a]"
"set c {[list $a $a]}"
"puts \"a = \\\"$a\\\"\""
"puts \"b = \\\"$b\\\"\""
"puts \"c = \\\"$c\\\"\""
"puts \"even better... \\\"[expr $c]\\\"\"")

55
collects/ffi/examples/use-xmmsctrl.ss Executable file
View File

@ -0,0 +1,55 @@
#! /usr/bin/env racket
#lang racket/base
(require (prefix-in xmms- "xmmsctrl.ss"))
(printf "version: ~s\n" (xmms-get-version))
(printf "skin: ~s\n" (xmms-get-skin))
(printf "volume: ~s\n" (xmms-get-volume))
(printf "balance: ~s\n" (xmms-get-balance))
(printf "number of tracks: ~s\n" (xmms-get-playlist-length))
(printf "Track #10 file = ~s\n" (xmms-get-playlist-file 10))
(printf "Track #10 title = ~s\n" (xmms-get-playlist-title 10))
(printf "Track #10 time = ~s\n" (xmms-get-playlist-time 10))
;; (define all-files
;; (let loop ((i (sub1 (xmms-get-playlist-length))) (files '()))
;; (if (< i 0)
;; files (loop (sub1 i) (cons (xmms-get-playlist-file i) files)))))
;; (printf "Number of files: ~s\n" (length all-files))
;; (sleep 1)
;; (xmms-playlist (list (car all-files) (caddr all-files) (cadddr all-files)) #f)
;; (sleep 1)
;; (xmms-playlist all-files #f)
;; (sleep 1)
;; (xmms-stop)
;; (let ([eq (xmms-get-eq)])
;; (xmms-set-eq (list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
;; (sleep 1)
;; (xmms-set-eq eq)
;; (sleep 1))
(xmms-set-playlist-pos 10)
(printf "playing? -> ~s\n" (xmms-is-playing?))
(xmms-play)
(define t
(thread (lambda ()
(let loop ()
(printf ">>> ~s\n" (xmms-get-output-time)) (sleep .1) (loop)))))
(define (back-sec)
(let ([t (- (xmms-get-output-time) 1000)])
(printf "Jumping to ~s\n" t)
(xmms-jump-to-time t)))
(sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3)
(kill-thread t)
(printf "playing? -> ~s\n" (xmms-is-playing?))
(printf "pos -> ~s\n" (xmms-get-playlist-pos))
(printf "info -> ~s\n" (xmms-get-info))
(xmms-playlist-next)
(sleep 1)
(printf "pos -> ~s\n" (xmms-get-playlist-pos))
(xmms-stop)

75
collects/ffi/examples/use-xosd.ss Executable file
View File

@ -0,0 +1,75 @@
#! /usr/bin/env racket
#lang racket/base
(require "xosd.ss")
(define x (xosd-create))
;; (xost-set-bar-length x 12)
(xosd-set-pos x 'middle)
(xosd-set-align x 'center)
(xosd-set-shadow-offset x 7)
(xosd-set-outline-offset x 2)
(xosd-set-colour x "yellow")
(xosd-set-shadow-colour x "black")
(xosd-set-outline-colour x "blue")
(xosd-set-font x "-adobe-courier-bold-r-*-*-34-*-*-*-*-*-*-*")
(printf ">>> xosd=~s, lines=~s, colour=~s\n"
x (xosd-get-number-lines x) (xosd-get-colour x))
(xosd-display-string x "Xosd Test")
;; this doesn't work for some reason
;; (xosd-set-timeout x 1)
;; (xosd-wait-until-no-display x)
(sleep 2)
(xosd-set-timeout x 0)
(let loop ([n 10])
(unless (zero? n)
(xosd-show x)
(sleep .05)
(xosd-hide x)
(sleep .05)
(loop (sub1 n))))
(let ([f (lambda (disp)
(let loop ([n 100])
(when (> n 0) (disp x n) (sleep .1) (loop (- n 5)))))])
(xosd-set-bar-length x 10)
(f xosd-display-percentage)
(sleep 1)
(xosd-set-bar-length x 20)
(f xosd-display-slider)
(xosd-hide x)
(sleep 1)
(xosd-display-string x "FOO")
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x))))
(xosd-hide x)
(sleep 1)
(set! x (xosd-create 4))
(xosd-set-pos x 'middle)
(xosd-set-align x 'center)
(xosd-set-font x "-adobe-courier-bold-r-*-*-25-*-*-*-*-*-*-*")
(xosd-set-shadow-offset x 7)
(xosd-set-outline-offset x 2)
(xosd-display-string x "This is the first line" 0)
(xosd-display-string x "and the second line" 1)
(xosd-display-string x "the third one" 2)
(xosd-display-string x "and finally the fourth line" 3)
(sleep 2) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1)

148
collects/ffi/examples/xmmsctrl.ss Executable file → Normal file
View File

@ -1,55 +1,109 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require (prefix-in xmms- ffi/xmmsctrl))
(require mzlib/foreign) (unsafe!)
(printf "version: ~s\n" (xmms-get-version))
(printf "skin: ~s\n" (xmms-get-skin))
(printf "volume: ~s\n" (xmms-get-volume))
(printf "balance: ~s\n" (xmms-get-balance))
(printf "number of tracks: ~s\n" (xmms-get-playlist-length))
(printf "Track #10 file = ~s\n" (xmms-get-playlist-file 10))
(printf "Track #10 title = ~s\n" (xmms-get-playlist-title 10))
(printf "Track #10 time = ~s\n" (xmms-get-playlist-time 10))
(define libxmms (ffi-lib "libxmms"))
;; (define all-files
;; (let loop ((i (sub1 (xmms-get-playlist-length))) (files '()))
;; (if (< i 0)
;; files (loop (sub1 i) (cons (xmms-get-playlist-file i) files)))))
;; (printf "Number of files: ~s\n" (length all-files))
;; (sleep 1)
;; (xmms-playlist (list (car all-files) (caddr all-files) (cadddr all-files)) #f)
;; (sleep 1)
;; (xmms-playlist all-files #f)
;; (sleep 1)
;; (xmms-stop)
(provide session)
(define session
(make-parameter
0 (lambda (x)
(if (integer? x)
x
(error 'xmms-session "expecting an integer, got ~s" x)))))
;; (let ([eq (xmms-get-eq)])
;; (xmms-set-eq (list 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
;; (sleep 1)
;; (xmms-set-eq eq)
;; (sleep 1))
;; used for playlist position values
(define _pos _int)
(xmms-set-playlist-pos 10)
(printf "playing? -> ~s\n" (xmms-is-playing?))
(xmms-play)
;; number of equalizer bands
(define eq-bands 10)
(define t
(thread (lambda ()
(let loop ()
(printf ">>> ~s\n" (xmms-get-output-time)) (sleep .1) (loop)))))
(define (back-sec)
(let ([t (- (xmms-get-output-time) 1000)])
(printf "Jumping to ~s\n" t)
(xmms-jump-to-time t)))
(sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3) (back-sec) (sleep 3)
(kill-thread t)
;; used for getting the default session from the session parameter
(define-fun-syntax _session
(syntax-id-rules (_session)
[_session (type: _int pre: (session))]))
(printf "playing? -> ~s\n" (xmms-is-playing?))
(printf "pos -> ~s\n" (xmms-get-playlist-pos))
(printf "info -> ~s\n" (xmms-get-info))
(xmms-playlist-next)
(sleep 1)
(printf "pos -> ~s\n" (xmms-get-playlist-pos))
(xmms-stop)
(define-syntax defxmms
(syntax-rules (:)
[(_ name : x ...)
(begin
(provide name)
(define name
(get-ffi-obj
(regexp-replaces
'name '((#rx"-" "_") (#rx"[?]$" "") (#rx"^" "xmms_remote_")))
libxmms (_fun x ...))))]))
(defxmms playlist : (files enqueue?) ::
_session
(files : (_list i _string))
(_int = (length files))
(enqueue? : _bool)
-> _void)
(defxmms get-version : _session -> _int)
;; The second argument is a GList (see glib/glist.h) which requires structs,
;; but the playlist function is sufficient (looks like this is for glib code).
;; (defxmms playlist-add : _session "GList * list" -> _void)
(defxmms playlist-delete : _session _pos -> _void)
(defxmms play : _session -> _void)
(defxmms pause : _session -> _void)
(defxmms stop : _session -> _void)
(defxmms is-playing? : _session -> _bool)
(defxmms is-paused? : _session -> _bool)
(defxmms get-playlist-pos : _session -> _pos)
(defxmms set-playlist-pos : _session _pos -> _void)
(defxmms get-playlist-length : _session -> _pos)
(defxmms playlist-clear : _session -> _void)
(defxmms get-output-time : _session -> _int)
(defxmms jump-to-time : _session _int -> _void)
(defxmms get-volume : _session (l : (_ptr o _int)) (r : (_ptr o _int))
-> _void -> (list l r))
(defxmms get-main-volume : _session -> _int)
(defxmms get-balance : _session -> _int)
(defxmms set-volume : _session (l : _int) (r : _int) -> _void)
(defxmms set-main-volume : _session _int -> _void)
(defxmms set-balance : _session _int -> _void)
(defxmms get-skin : _session -> _file)
(defxmms set-skin : _session _file -> _void)
(defxmms get-playlist-file : _session _pos -> _string)
(defxmms get-playlist-title : _session _pos -> _string)
(defxmms get-playlist-time : _session _pos -> _int)
(defxmms get-info : _session
(rate : (_ptr o _int))
(freq : (_ptr o _int))
(nch : (_ptr o _int))
-> _void -> (list rate freq nch))
(defxmms main-win-toggle : _session (show? : _bool) -> _void)
(defxmms pl-win-toggle : _session (show? : _bool) -> _void)
(defxmms eq-win-toggle : _session (show? : _bool) -> _void)
(defxmms is-main-win? : _session -> _bool)
(defxmms is-pl-win? : _session -> _bool)
(defxmms is-eq-win? : _session -> _bool)
(defxmms show-prefs-box : _session -> _void)
(defxmms toggle-aot : _session (ontop? : _bool) -> _void)
(defxmms eject : _session -> _void)
(defxmms playlist-prev : _session -> _void)
(defxmms playlist-next : _session -> _void)
(defxmms playlist-add-url-string : _session _string -> _void)
(defxmms is-running? : _session -> _bool)
(defxmms toggle-repeat : _session -> _void)
(defxmms toggle-shuffle : _session -> _void)
(defxmms is-repeat? : _session -> _bool)
(defxmms is-shuffle? : _session -> _bool)
(defxmms get-eq : _session
(preamp : (_ptr o _float))
(bands : (_ptr o _pointer))
-> _void
-> (cons preamp (cblock->list bands _float eq-bands)))
(defxmms get-eq-preamp : _session -> _float)
(defxmms get-eq-band : _session (band : _int) -> _float)
(defxmms set-eq : (l) ::
_session
(preamp : _float = (car l))
(bands : (_list i _float) = (cdr l))
-> _void)
(defxmms set-eq-preamp : _session (preamp : _float) -> _void)
(defxmms set-eq-band : _session (band : _int) _float -> _void)
(defxmms quit : _session -> _void)
(defxmms play-pause : _session -> _void)
(defxmms playlist-ins-url-string : _session _string _pos -> _void)

157
collects/ffi/examples/xosd.ss Executable file → Normal file
View File

@ -1,75 +1,104 @@
#! /usr/bin/env mzscheme
#lang scheme/base
(require ffi/xosd)
(require mzlib/foreign) (unsafe!)
(define x (xosd-create))
(define libxosd (ffi-lib "libxosd"))
;; (xost-set-bar-length x 12)
(xosd-set-pos x 'middle)
(xosd-set-align x 'center)
(xosd-set-shadow-offset x 7)
(xosd-set-outline-offset x 2)
(xosd-set-colour x "yellow")
(xosd-set-shadow-colour x "black")
(xosd-set-outline-colour x "blue")
(xosd-set-font x "-adobe-courier-bold-r-*-*-34-*-*-*-*-*-*-*")
;; Use this type to properly destroy an xosd object
(define _xosd (make-ctype (_cpointer "xosd") #f
(lambda (p)
(if p
(register-finalizer p xosd-destroy)
(error '_xosd "got a NULL pointer"))
p)))
(printf ">>> xosd=~s, lines=~s, colour=~s\n"
x (xosd-get-number-lines x) (xosd-get-colour x))
(define-syntax defxosd
(syntax-rules (:)
[(_ name : type ...)
(define name
(get-ffi-obj (regexp-replaces 'name '((#rx"-" "_") (#rx"[*?]$" "")))
libxosd (_fun type ...)))]))
(xosd-display-string x "Xosd Test")
(define-syntax defxosd*
(syntax-rules ()
[(_ name x ...) (begin (provide name) (defxosd name x ...))]))
;; this doesn't work for some reason
;; (xosd-set-timeout x 1)
;; (xosd-wait-until-no-display x)
(define _status
(make-ctype _int #f
(lambda (x)
(if (eq? -1 x)
(error 'xosd "~a"
(or (get-ffi-obj "xosd_error" libxosd _string)
"unknown xosd error"))
x))))
(sleep 2)
(xosd-set-timeout x 0)
(define _sbool
(make-ctype _status #f
(lambda (x)
(case x [(1) #t] [(0) #f] [else (error "bad boolean value: ~e" x)]))))
(let loop ([n 10])
(unless (zero? n)
(xosd-show x)
(sleep .05)
(xosd-hide x)
(sleep .05)
(loop (sub1 n))))
;; ===== Initializing =========================================================
(let ([f (lambda (disp)
(let loop ([n 100])
(when (> n 0) (disp x n) (sleep .1) (loop (- n 5)))))])
(xosd-set-bar-length x 10)
(f xosd-display-percentage)
(sleep 1)
(xosd-set-bar-length x 20)
(f xosd-display-slider)
(xosd-hide x)
(sleep 1)
(xosd-display-string x "FOO")
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x n) (xosd-show x)))
(f (lambda (x n)
(xosd-hide x) (xosd-set-vertical-offset x (- 100 n)) (xosd-show x))))
(xosd-hide x)
(sleep 1)
(defxosd* xosd-create : ; [num-lines = 1] -> xosd-obj
args :: (num-lines : _int = (if (pair? args) (car args) 1)) -> _xosd)
(defxosd xosd-destroy : _xosd -> _int)
(set! x (xosd-create 4))
(xosd-set-pos x 'middle)
(xosd-set-align x 'center)
(xosd-set-font x "-adobe-courier-bold-r-*-*-25-*-*-*-*-*-*-*")
(xosd-set-shadow-offset x 7)
(xosd-set-outline-offset x 2)
(xosd-display-string x "This is the first line" 0)
(xosd-display-string x "and the second line" 1)
(xosd-display-string x "the third one" 2)
(xosd-display-string x "and finally the fourth line" 3)
(sleep 2) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1) (xosd-scroll x 1)
(sleep 1)
(defxosd* xosd-is-onscreen? : _xosd -> _sbool)
;; ===== Displaying & Hiding ==================================================
(defxosd xosd-show* : _xosd -> _status)
(provide xosd-show)
(define (xosd-show xosd) (unless (xosd-is-onscreen? xosd) (xosd-show* xosd)))
(defxosd xosd-hide* : _xosd -> _status)
(provide xosd-hide)
(define (xosd-hide xosd) (when (xosd-is-onscreen? xosd) (xosd-hide* xosd)))
(defxosd* xosd-set-timeout : _xosd _int -> _status)
(defxosd* xosd-wait-until-no-display : _xosd -> _status)
;; ===== Attributed ===========================================================
(define _xosd-pos (_enum '(top bottom middle)))
(define _xosd-align (_enum '(left center right)))
(defxosd* xosd-set-pos : _xosd _xosd-pos -> _status)
(defxosd* xosd-set-align : _xosd _xosd-align -> _status)
(defxosd* xosd-set-horizontal-offset : _xosd _int -> _status)
(defxosd* xosd-set-vertical-offset : _xosd _int -> _status)
(defxosd* xosd-set-shadow-offset : _xosd _int -> _status)
(defxosd* xosd-set-outline-offset : _xosd _int -> _status)
(defxosd* xosd-set-colour : _xosd _string -> _status)
(defxosd* xosd-set-shadow-colour : _xosd _string -> _status)
(defxosd* xosd-set-outline-colour : _xosd _string -> _status)
(defxosd* xosd-set-font : _xosd _string -> _status)
(defxosd* xosd-get-colour :
_xosd (r : (_ptr o _int)) (g : (_ptr o _int)) (b : (_ptr o _int)) -> _status
-> (list r g b))
(defxosd* xosd-get-number-lines : _xosd -> _status)
;; ===== Content ==============================================================
(define _xosd-command (_enum '(percentage string printf slider)))
(define disp-int*
(get-ffi-obj "xosd_display" libxosd
(_fun _xosd _int _xosd-command _int -> _status)))
(define disp-string*
(get-ffi-obj "xosd_display" libxosd
(_fun _xosd _int _xosd-command _string -> _status)))
(provide xosd-display-percentage xosd-display-string xosd-display-slider)
;; xosd-obj percent [line-num] -> int
(define (xosd-display-percentage xosd percent . line)
(disp-int* xosd (if (pair? line) (car line) 0) 'percentage percent))
;; xosd-obj string [line-num] -> int
(define (xosd-display-string xosd str . line)
(disp-string* xosd (if (pair? line) (car line) 0) 'string str))
;; xosd-obj percent [line-num] -> int
(define (xosd-display-slider xosd int . line)
(disp-int* xosd (if (pair? line) (car line) 0) 'slider int))
(defxosd* xosd-set-bar-length : _xosd _int -> _status)
(defxosd* xosd-scroll : _xosd _int -> _status)

2
collects/ffi/info.ss
View File

@ -1,5 +1,3 @@
#lang setup/infotab
(define name "Sample FFIs")
(define compile-omit-paths '("examples"))

2813
collects/ffi/magick.ss
View File

File diff suppressed because it is too large Load Diff

2
collects/ffi/objc.ss
View File

@ -11,7 +11,7 @@
#'(require (only-in . lib+ids)))]))))
(provide-except-unsafe
racket/unsafe/ffi/objc objc-unsafe!
ffi/unsafe/objc objc-unsafe!
objc_msgSend/typed
objc_msgSendSuper/typed

343
collects/ffi/sndfile.ss
View File

@ -1,343 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libsndfile (ffi-lib "libsndfile"))
;; ==================== Types etc ====================
;; This is the scheme represtenatation of the soundfile that is handeled by
;; libsndfile.
;; In libsndfile the sndfile object is represented as a pointer. When
;; translating scheme->c the struct will just return the pointer. When
;; translating from c->scheme, ie. creating the object in scheme it will be
;; wrapped by an object finalizer that uses the libsndfile fuction sf_close that
;; returns a 0 upon successful termination or an error.
(define-struct sndfile (ptr [info #:mutable]))
(define _sndfile
(make-ctype _pointer sndfile-ptr
(lambda (p)
(if p
(make-sndfile p #f)
(error '_sndfile "got a NULL pointer (bad info?)")))))
;; sf_count_t is a count type that depends on the operating system however it
;; seems to be a long int for all the supported ones so in this scase we just
;; define it as two ints.
(define _sf-count-t _int64)
(define _sf-mode
(_bitmask '(sfm-read = #x10
sfm-write = #x20
sfm-rdwrt = #x30)))
(define str-types '(title copyright software artist comment date))
(define _sf-str-type (_enum (cons "dummy" str-types))) ; begins from 1
(define _sf-format
(let ([majors ; Major formats
'((wav #x010000) ; Microsoft WAV format (little endian)
(aiff #x020000) ; Apple/SGI AIFF format (big endian)
(au #x030000) ; Sun/NeXT AU format (big endian)
(raw #x040000) ; RAW PCM data
(paf #x050000) ; Ensoniq PARIS file format
(svx #x060000) ; Amiga IFF / SVX8 / SV16 format
(nist #x070000) ; Sphere NIST format
(voc #x080000) ; VOC files
(ircam #x0A0000) ; Berkeley/IRCAM/CARL
(w64 #x0B0000) ; Sonic Foundry's 64 bit RIFF/WAV
(mat4 #x0C0000) ; Matlab (tm) V4.2 / GNU Octave 2.0
(mat5 #x0D0000) ; Matlab (tm) V5.0 / GNU Octave 2.1
(pvf #x0E0000) ; Portable Voice Format
(xi #x0F0000) ; Fasttracker 2 Extended Instrument
(htk #x100000) ; HMM Tool Kit format
(sds #x110000) ; Midi Sample Dump Standard
(avr #x120000) ; Audio Visual Research
(wavex #x130000) ; MS WAVE with WAVEFORMATEX
)]
[subtypes ; Subtypes from here on
'((pcm-s8 #x0001) ; Signed 8 bit data
(pcm-16 #x0002) ; Signed 16 bit data
(pcm-24 #x0003) ; Signed 24 bit data
(pcm-32 #x0004) ; Signed 32 bit data
(pcm-u8 #x0005) ; Unsigned 8 bit data (WAV and RAW only)
(float #x0006) ; 32 bit float data
(double #x0007) ; 64 bit float data
(ulaw #x0010) ; U-Law encoded
(alaw #x0011) ; A-Law encoded
(ima-adpcm #x0012) ; IMA ADPCM
(ms-adpcm #x0013) ; Microsoft ADPCM
(gsm610 #x0020) ; GSM 6.10 encoding
(vox-adpcm #x0021) ; OKI / Dialogix ADPCM
(g721-32 #x0030) ; 32kbs G721 ADPCM encoding
(g723-24 #x0031) ; 24kbs G723 ADPCM encoding
(g723-40 #x0032) ; 40kbs G723 ADPCM encoding
(dwvw-12 #x0040) ; 12 bit Delta Width Variable Word encoding
(dwvw-16 #x0041) ; 16 bit Delta Width Variable Word encoding
(dwvw-24 #x0042) ; 24 bit Delta Width Variable Word encoding
(dwvw-n #x0043) ; N bit Delta Width Variable Word encoding
(dpcm-8 #x0050) ; 8 bit differential PCM (XI only)
(dpcm-16 #x0051) ; 16 bit differential PCM (XI only)
)]
[endians ; Endian-ness options
'((file #x00000000) ; Default file endian-ness
(little #x10000000) ; Force little endian-ness
(big #x20000000) ; Force big endian-ness
(cpu #x30000000) ; Force CPU endian-ness
)]
[submask #x0000FFFF]
[typemask #x0FFF0000]
[endmask #x30000000])
(define (rev-find n l)
(let loop ([l l])
(cond [(null? l) #f]
[(eq? n (cadar l)) (caar l)]
[else (loop (cdr l))])))
(make-ctype _int
(lambda (syms)
(let ([major #f] [subtype #f] [endian #f])
(for-each
(lambda (sym)
(cond [(assq sym majors) =>
(lambda (x)
(if major
(error 'sf-format "got two major modes: ~s" syms)
(set! major (cadr x))))]
[(assq sym subtypes) =>
(lambda (x)
(if subtype
(error 'sf-format "got two subtype modes: ~s" syms)
(set! subtype (cadr x))))]
[(assq sym endians) =>
(lambda (x)
(if endian
(error 'sf-format "got two endian modes: ~s" syms)
(set! endian (cadr x))))]
[else (error 'sf-format "got a bad symbol: ~s" sym)]))
(if (list? syms) syms (list syms)))
(bitwise-ior (or major 0) (or subtype 0) (or endian 0))))
(lambda (n)
(let ([subtype (rev-find (bitwise-and n submask) subtypes)]
[major (rev-find (bitwise-and n typemask) majors)]
[endian (rev-find (bitwise-and n endmask) endians)])
(unless subtype
(error 'sf-format "got a bad number from C for subtype: ~x"
(bitwise-and n submask)))
(unless major
(error 'sf-format "got a bad number from C for major: ~x"
(bitwise-and n typemask)))
(unless endian
(error 'sf-format "got a bad number from C for endian: ~x"
(bitwise-and n endmask)))
(list major subtype endian))))))
(define-cstruct _sf-info
((frames _sf-count-t)
(samplerate _int)
(channels _int)
(format _sf-format)
(sections _int)
(seekable _bool)))
;; ==================== Utilities ====================
(define-syntax defsndfile
(syntax-rules (:)
[(_ name : type ...)
(define name
(get-ffi-obj (regexp-replaces 'name '((#rx"-" "_")))
libsndfile (_fun type ...)))]))
(define (n-split l n)
(let loop ([l l][i 0][a2 null][a null])
(cond
[(null? l) (let ([a (if (null? a2)
a
(cons (reverse a2) a))])
(reverse a))]
[(= i n) (loop l 0 null (cons (reverse a2) a))]
[else (loop (cdr l) (add1 i) (cons (car l) a2) a)])))
;; ==================== sndfile API ====================
(defsndfile sf-close : _sndfile -> _int)
(defsndfile sf-open : (path mode . info) ::
(path : _file)
(mode : _sf-mode)
(info : _sf-info-pointer
= (if (pair? info) (car info) (make-sf-info 0 0 0 '() 0 #f)))
-> (sf : _sndfile)
-> (begin (set-sndfile-info! sf info) sf))
(defsndfile sf-format-check : _sf-info-pointer -> _bool)
(defsndfile sf-readf-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-readf-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-short : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-int : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-writef-double : _sndfile _pointer _sf-count-t -> _sf-count-t)
(defsndfile sf-get-string : _sndfile _sf-str-type -> _string)
(defsndfile sf-set-string : _sndfile _sf-str-type _string -> _bool)
;; ==================== Utilities for the Scheme interface ====================
(define (get-strings sndfile)
(let loop ([sts str-types] [r '()])
(cond [(null? sts) (reverse r)]
[(sf-get-string sndfile (car sts)) =>
(lambda (x)
(loop (cdr sts) (cons (list (car sts) (string-copy x)) r)))]
[else (loop (cdr sts) r)])))
(define (set-strings sndfile meta)
(for-each (lambda (st)
(cond [(assq st meta) =>
(lambda (x) (sf-set-string sndfile st (cadr x)))]))
str-types))
(define (read-sound-internal file meta?)
(let* ([sndfile (sf-open file 'sfm-read)]
[strings (and meta? (get-strings sndfile))]
[info (sndfile-info sndfile)]
[frames (sf-info-frames info)]
[channels (sf-info-channels info)]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[readf (case (sample-type)
[(short) sf-readf-short]
[(int) sf-readf-int]
[(float) sf-readf-double])]
[cblock (malloc (* frames channels) stype)]
[num-read (readf sndfile cblock frames)]
[data (cblock->list cblock stype (* num-read channels))]
[data (if (> channels 1) (n-split data channels) data)])
(unless (= frames num-read)
(error 'read-sound-internal
"wanted ~s frames, but got ~s" frames num-read))
(begin0 (if meta?
(values data `((frames ,frames)
(samplerate ,(sf-info-samplerate info))
(channels ,channels)
(format ,(sf-info-format info))
(sections ,(sf-info-sections info))
,@strings))
data)
(sf-close sndfile))))
(define (frame-list->cblock data frames channels type)
(cond
[(null? data) #f]
[(and (= 1 channels) (not (pair? (car data)))) (list->cblock data type)]
[else
(let ([test (lambda (x)
(and (list? x) (= channels (length x)) (andmap number? x)))])
(unless (andmap test data)
(error 'frame-list->cblock "got a bad frame: ~e"
(ormap (lambda (x) (and (not (test x)) x)) data))))
(let ([cblock (malloc (* channels frames) type)]
[i 0])
(let loop ([d data])
(cond [(number? d) (ptr-set! cblock type i d) (set! i (add1 i))]
[(pair? d) (loop (car d)) (loop (cdr d))]))
cblock)]))
(define (write-sound-internal file data meta)
(let* ([frames (length data)]
[channels (if (or (null? data) (not (pair? (car data))))
1 ; 1-channel if no data, or data is not made of lists
(length (car data)))]
[stype (case (sample-type)
[(short) _int16] [(int) _int] [(float) _double*])]
[writef (case (sample-type)
[(short) sf-writef-short]
[(int) sf-writef-int]
[(float) sf-writef-double])]
[cblock (frame-list->cblock data frames channels stype)]
[format (cond [(assq 'format meta) => cadr]
[else (guess-format file)])]
[samplerate (cond [(assq 'samplerate meta) => cadr]
[else (default-samplerate)])]
[info (make-sf-info frames samplerate channels format 1 #f)]
[_ (unless (sf-format-check info)
(error 'write-sound-internal "bad format: ~s" format))]
[sndfile (sf-open file 'sfm-write info)]
[_ (set-strings sndfile meta)]
[num-write (writef sndfile cblock frames)])
(unless (= frames num-write)
(error 'write-sound-internal
"wanted to write ~s frames, but wrote only ~s" frames num-write))
(sf-close sndfile)
(void)))
(define file-format-table
'((#rx"\\.aiff?" (aiff pcm-16 file))
(#rx"\\.wave?" (wav pcm-16 file))
(#rx"\\.au" (au pcm-16 file))
(#rx"\\.snd" (au pcm-16 file))
(#rx"\\.svx" (svx pcm-16 file))
(#rx"\\.paf" (paf pcm-16 big))
(#rx"\\.fap" (paf pcm-16 little))
(#rx"\\.nist" (nist pcm-16 little))
(#rx"\\.ircam" (ircam pcm-16 little))
(#rx"\\.sf" (ircam pcm-16 little))
(#rx"\\.voc" (voc pcm-16 file))
(#rx"\\.w64" (w64 pcm-16 file))
(#rx"\\.raw" (raw pcm-16 cpu))
(#rx"\\.mat4" (mat4 pcm-16 little))
(#rx"\\.mat5" (mat5 pcm-16 little))
(#rx"\\.mat" (mat4 pcm-16 little))
(#rx"\\.pvf" (pvf pcm-16 file))
(#rx"\\.sds" (sds pcm-16 file))
(#rx"\\.xi" (xi dpcm-16 file))))
(define (guess-format filename)
(let loop ([xs file-format-table])
(cond [(null? xs) (default-file-format)]
[(regexp-match (caar xs) filename) (cadar xs)]
[else (loop (cdr xs))])))
;; ==================== Exposed Scheme interface ====================
;; types of samples we handle: 'short, 'int, or 'float
(provide sample-type)
(define sample-type
(make-parameter
'float (lambda (x)
(if (memq x '(short int float))
x (error 'sample-type "bad type: ~s" x)))))
;; TODO: add a parameter that will determine if you get a list, vector or
;; srfi/4-like thing. possibly also determine if a list/vector gets automatic
;; treatment of 1-channel - not converting it into a list of singleton lists.
(provide default-samplerate)
(define default-samplerate
(make-parameter
11025 (lambda (x)
(if (and (integer? x) (positive? x))
x (error 'default-samplerate "bad samplerate: ~s" x)))))
(provide default-file-format)
(define default-file-format ; no guard, but should be good for _sf-format
(make-parameter '(wav pcm-16 file)))
(provide read-sound)
(define (read-sound file)
(read-sound-internal file #f))
(provide read-sound*)
(define (read-sound* file)
(read-sound-internal file #t))
(provide write-sound)
(define (write-sound file data)
(write-sound-internal file data '()))
;; meta is used only for samplerate & format
(provide write-sound*)
(define (write-sound* file data meta)
(write-sound-internal file data meta))

49
collects/ffi/tcl.ss
View File

@ -1,49 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libtcl (ffi-lib "libtcl"))
(provide current-interp create-interp eval-tcl)
(define current-interp
(make-parameter
#f (lambda (x)
(if (and x (cpointer? x))
x
(error 'tcl:current-interp
"expecting a non-void C pointer, got ~s" x)))))
;; This creates _interp as a type to be used for functions that return an
;; interpreter that should be destroyed with delete-interp.
(define _interp
(make-ctype _pointer #f ; no op when going to C
(lambda (interp)
(when interp (register-finalizer interp delete-interp))
interp)))
;; This is for arguments that always use the value of current-interp
(define-fun-syntax _interp*
(syntax-id-rules ()
[_ (type: _interp expr: (current-interp))]))
(define create-interp
(get-ffi-obj "Tcl_CreateInterp" libtcl (_fun -> _interp)))
(define delete-interp
(let ([f (get-ffi-obj "Tcl_DeleteInterp" libtcl (_fun _interp -> _void))])
(lambda (i) (f i))))
(current-interp (create-interp))
(define get-string-result
(get-ffi-obj "Tcl_GetStringResult" libtcl (_fun _interp -> _string)))
(define _tclret
(make-ctype (_enum '(ok error return break continue))
(lambda (x) (error "tclret is only for return values"))
(lambda (x)
(when (eq? x 'error) (error 'tcl (get-string-result (current-interp))))
x)))
(define eval-tcl
(get-ffi-obj "Tcl_Eval" libtcl (_fun _interp* (expr : _string) -> _tclret)))

195
collects/racket/unsafe/ffi.rkt → collects/ffi/unsafe.rkt
View File

@ -974,201 +974,6 @@
[(_ . xs) (_bytes . xs)]
[_ _bytes]))
;; ----------------------------------------------------------------------------
;; Safe raw vectors
(define-struct cvector (ptr type length))
(provide cvector? cvector-length cvector-type cvector-ptr
;; make-cvector* is a dangerous operation
(protect-out (rename-out [make-cvector make-cvector*])))
(define _cvector* ; used only as input types
(make-ctype _pointer cvector-ptr
(lambda (x)
(error '_cvector
"cannot automatically convert a C pointer to a cvector"))))
;; (_cvector <mode> [<type> <len>]) | _cevector
;; Same as _list etc above, except that it uses C vectors.
(provide _cvector)
(define-fun-syntax _cvector
(syntax-id-rules (i o io)
[(_ i ) _cvector*]
[(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector*
pre: (malloc n t)
post: (x => (make-cvector x t n)))]
[(_ io ) (type: _cvector*
bind: tmp
pre: (x => (cvector-ptr x))
post: (x => tmp))]
[(_ . xs) (_cvector* . xs)]
[_ _cvector*]))
(provide (rename-out [allocate-cvector make-cvector]))
(define (allocate-cvector type len)
(make-cvector (if (zero? len) #f ; 0 => NULL
(malloc len type))
type len))
(provide (rename-out [cvector-args cvector]))
(define (cvector-args type . args)
(list->cvector args type))
(define* (cvector-ref v i)
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
(ptr-ref (cvector-ptr v) (cvector-type v) i)
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
i (sub1 (cvector-length v)))))
(define* (cvector-set! v i x)
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
(ptr-set! (cvector-ptr v) (cvector-type v) i x)
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
i (sub1 (cvector-length v)))))
(define* (cvector->list v)
(cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v)))
(define* (list->cvector l type)
(make-cvector (list->cblock l type) type (length l)))
;; ----------------------------------------------------------------------------
;; SRFI-4 implementation
(define-syntax (srfi-4-define/provide stx)
(syntax-case stx ()
[(_ TAG type)
(identifier? #'TAG)
(let ([name (format "~avector" (syntax->datum #'TAG))])
(define (id prefix suffix)
(let* ([name (if prefix (string-append prefix name) name)]
[name (if suffix (string-append name suffix) name)])
(datum->syntax #'TAG (string->symbol name) #'TAG)))
(with-syntax ([TAG? (id "" "?")]
[TAG (id "" "")]
[s:TAG (id "s:" "")]
[make-TAG (id "make-" "")]
[TAG-ptr (id "" "-ptr")]
[TAG-length (id "" "-length")]
[allocate-TAG (id "allocate-" "")]
[TAG* (id "" "*")]
[list->TAG (id "list->" "")]
[TAG->list (id "" "->list")]
[TAG-ref (id "" "-ref")]
[TAG-set! (id "" "-set!")]
[TAG->cpointer (id "" "->cpointer")]
[_TAG (id "_" "")]
[_TAG* (id "_" "*")]
[TAGname name]
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)])
#'(begin
(define-struct TAG (ptr length))
(provide TAG? TAG-length (rename-out [TAG s:TAG]))
(provide (rename-out [allocate-TAG make-TAG]))
(define (allocate-TAG n . init)
(let* ([p (if (eq? n 0) #f (malloc n type))]
[v (make-TAG p n)])
(when (and p (pair? init))
(let ([init (car init)])
(let loop ([i (sub1 n)])
(unless (< i 0)
(ptr-set! p type i init)
(loop (sub1 i))))))
v))
(provide (rename-out [TAG* TAG]))
(define (TAG* . vals)
(list->TAG vals))
(define* (TAG-ref v i)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if f64? ;; use JIT-inlined operation
(unsafe-f64vector-ref v i)
(ptr-ref (TAG-ptr v) type i))
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-ref TAGname v)))
(define* (TAG-set! v i x)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if (and f64? ;; use JIT-inlined operation
(inexact-real? x))
(unsafe-f64vector-set! v i x)
(ptr-set! (TAG-ptr v) type i x))
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-set! TAGname v)))
(define* (TAG->list v)
(if (TAG? v)
(cblock->list (TAG-ptr v) type (TAG-length v))
(raise-type-error 'TAG->list TAGname v)))
(define* (list->TAG l)
(make-TAG (list->cblock l type) (length l)))
(define* (TAG->cpointer v)
(if (TAG? v)
(TAG-ptr v)
(raise-type-error 'TAG->cpointer TAGname v)))
;; same as the _cvector implementation
(provide _TAG)
(define _TAG*
(make-ctype _pointer TAG-ptr
(lambda (x)
(error
'_TAG
"cannot automatically convert a C pointer to a ~a"
TAGname))))
(define-fun-syntax _TAG
(syntax-id-rules (i o io)
[(_ i ) _TAG*]
[(_ o n) (type: _pointer
pre: (malloc n type)
post: (x => (make-TAG x n)))]
[(_ io ) (type: _cvector*
bind: tmp
pre: (x => (TAG-ptr x))
post: (x => tmp))]
[(_ . xs) (_TAG* . xs)]
[_ _TAG*])))))]
[(_ TAG type)
(identifier? #'TAG)]))
;; check that the types that were used above have the proper sizes
(unless (= 4 (ctype-sizeof _float))
(error 'foreign "internal error: float has a bad size (~s)"
(ctype-sizeof _float)))
(unless (= 8 (ctype-sizeof _double*))
(error 'foreign "internal error: double has a bad size (~s)"
(ctype-sizeof _double*)))
(srfi-4-define/provide s8 _int8)
(srfi-4-define/provide s16 _int16)
(srfi-4-define/provide u16 _uint16)
(srfi-4-define/provide s32 _int32)
(srfi-4-define/provide u32 _uint32)
(srfi-4-define/provide s64 _int64)
(srfi-4-define/provide u64 _uint64)
(srfi-4-define/provide f32 _float)
(srfi-4-define/provide f64 _double*)
;; simply rename bytes* to implement the u8vector type
(provide (rename-out [bytes? u8vector? ]
[bytes-length u8vector-length]
[make-bytes make-u8vector ]
[bytes u8vector ]
[bytes-ref u8vector-ref ]
[bytes-set! u8vector-set! ]
[bytes->list u8vector->list ]
[list->bytes list->u8vector ]
[_bytes _u8vector ]))
;; additional `u8vector' bindings for srfi-66
(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
(define* (u8vector-compare v1 v2)
(cond [(bytes<? v1 v2) -1]
[(bytes>? v1 v2) 1]
[else 0]))
(define* (u8vector-copy! src src-start dest dest-start n)
(bytes-copy! dest dest-start src src-start (+ src-start n)))
;; ----------------------------------------------------------------------------
;; Tagged pointers

0
collects/racket/unsafe/ffi/alloc.rkt → collects/ffi/unsafe/alloc.rkt
View File

0
collects/racket/unsafe/ffi/atomic.rkt → collects/ffi/unsafe/atomic.rkt
View File

66
collects/ffi/unsafe/cvector.rkt Normal file
View File

@ -0,0 +1,66 @@
#lang racket/base
(require "../unsafe.ss")
(define-struct cvector (ptr type length))
(provide cvector? cvector-length cvector-type cvector-ptr
;; make-cvector* is a dangerous operation
(protect-out (rename-out [make-cvector make-cvector*])))
(define-syntax define*
(syntax-rules ()
[(_ (name . args) body ...)
(begin (provide name) (define (name . args) body ...))]
[(_ name expr)
(begin (provide name) (define name expr))]))
(define _cvector* ; used only as input types
(make-ctype _pointer cvector-ptr
(lambda (x)
(error '_cvector
"cannot automatically convert a C pointer to a cvector"))))
;; (_cvector <mode> [<type> <len>]) | _cevector
;; Same as _list etc above, except that it uses C vectors.
(provide _cvector)
(define-fun-syntax _cvector
(syntax-id-rules (i o io)
[(_ i ) _cvector*]
[(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector*
pre: (malloc n t)
post: (x => (make-cvector x t n)))]
[(_ io ) (type: _cvector*
bind: tmp
pre: (x => (cvector-ptr x))
post: (x => tmp))]
[(_ . xs) (_cvector* . xs)]
[_ _cvector*]))
(provide (rename-out [allocate-cvector make-cvector]))
(define (allocate-cvector type len)
(make-cvector (if (zero? len) #f ; 0 => NULL
(malloc len type))
type len))
(provide (rename-out [cvector-args cvector]))
(define (cvector-args type . args)
(list->cvector args type))
(define* (cvector-ref v i)
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
(ptr-ref (cvector-ptr v) (cvector-type v) i)
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
i (sub1 (cvector-length v)))))
(define* (cvector-set! v i x)
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
(ptr-set! (cvector-ptr v) (cvector-type v) i x)
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
i (sub1 (cvector-length v)))))
(define* (cvector->list v)
(cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v)))
(define* (list->cvector l type)
(make-cvector (list->cblock l type) type (length l)))

0
collects/racket/unsafe/ffi/define.rkt → collects/ffi/unsafe/define.rkt
View File

2
collects/racket/unsafe/ffi/objc.rkt → collects/ffi/unsafe/objc.rkt
View File

@ -1,5 +1,5 @@
#lang racket/base
(require racket/unsafe/ffi
(require ffi/unsafe
racket/stxparam
(for-syntax racket/base))

145
collects/ffi/vector.rkt Normal file
View File

@ -0,0 +1,145 @@
#lang racket/base
(require "unsafe.ss"
racket/unsafe/ops
(for-syntax racket/base))
(define-syntax define*
(syntax-rules ()
[(_ (name . args) body ...)
(begin (provide name) (define (name . args) body ...))]
[(_ name expr)
(begin (provide name) (define name expr))]))
(define-syntax (srfi-4-define/provide stx)
(syntax-case stx ()
[(_ TAG type)
(identifier? #'TAG)
(let ([name (format "~avector" (syntax->datum #'TAG))])
(define (id prefix suffix)
(let* ([name (if prefix (string-append prefix name) name)]
[name (if suffix (string-append name suffix) name)])
(datum->syntax #'TAG (string->symbol name) #'TAG)))
(with-syntax ([TAG? (id "" "?")]
[TAG (id "" "")]
[s:TAG (id "s:" "")]
[make-TAG (id "make-" "")]
[TAG-ptr (id "" "-ptr")]
[TAG-length (id "" "-length")]
[allocate-TAG (id "allocate-" "")]
[TAG* (id "" "*")]
[list->TAG (id "list->" "")]
[TAG->list (id "" "->list")]
[TAG-ref (id "" "-ref")]
[TAG-set! (id "" "-set!")]
[TAG->cpointer (id "" "->cpointer")]
[_TAG (id "_" "")]
[_TAG* (id "_" "*")]
[TAGname name]
[f64? (if (eq? (syntax-e #'TAG) 'f64) #'#t #'#f)])
#'(begin
(define-struct TAG (ptr length))
(provide TAG? TAG-length (rename-out [TAG s:TAG]))
(provide (rename-out [allocate-TAG make-TAG]))
(define (allocate-TAG n . init)
(let* ([p (if (eq? n 0) #f (malloc n type))]
[v (make-TAG p n)])
(when (and p (pair? init))
(let ([init (car init)])
(let loop ([i (sub1 n)])
(unless (< i 0)
(ptr-set! p type i init)
(loop (sub1 i))))))
v))
(provide (rename-out [TAG* TAG]))
(define (TAG* . vals)
(list->TAG vals))
(define* (TAG-ref v i)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if f64? ;; use JIT-inlined operation
(unsafe-f64vector-ref v i)
(ptr-ref (TAG-ptr v) type i))
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-ref TAGname v)))
(define* (TAG-set! v i x)
(if (TAG? v)
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
(if (and f64? ;; use JIT-inlined operation
(inexact-real? x))
(unsafe-f64vector-set! v i x)
(ptr-set! (TAG-ptr v) type i x))
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
i 'TAG (sub1 (TAG-length v))))
(raise-type-error 'TAG-set! TAGname v)))
(define* (TAG->list v)
(if (TAG? v)
(cblock->list (TAG-ptr v) type (TAG-length v))
(raise-type-error 'TAG->list TAGname v)))
(define* (list->TAG l)
(make-TAG (list->cblock l type) (length l)))
(define* (TAG->cpointer v)
(if (TAG? v)
(TAG-ptr v)
(raise-type-error 'TAG->cpointer TAGname v)))
;; same as the _cvector implementation
(provide _TAG)
(define _TAG*
(make-ctype _pointer TAG-ptr
(lambda (x)
(error
'_TAG
"cannot automatically convert a C pointer to a ~a"
TAGname))))
(define-fun-syntax _TAG
(syntax-id-rules (i o io)
[(_ i ) _TAG*]
[(_ o n) (type: _pointer
pre: (malloc n type)
post: (x => (make-TAG x n)))]
[(_ io ) (type: _cvector*
bind: tmp
pre: (x => (TAG-ptr x))
post: (x => tmp))]
[(_ . xs) (_TAG* . xs)]
[_ _TAG*])))))]
[(_ TAG type)
(identifier? #'TAG)]))
;; check that the types that were used above have the proper sizes
(unless (= 4 (ctype-sizeof _float))
(error 'foreign "internal error: float has a bad size (~s)"
(ctype-sizeof _float)))
(unless (= 8 (ctype-sizeof _double*))
(error 'foreign "internal error: double has a bad size (~s)"
(ctype-sizeof _double*)))
(srfi-4-define/provide s8 _int8)
(srfi-4-define/provide s16 _int16)
(srfi-4-define/provide u16 _uint16)
(srfi-4-define/provide s32 _int32)
(srfi-4-define/provide u32 _uint32)
(srfi-4-define/provide s64 _int64)
(srfi-4-define/provide u64 _uint64)
(srfi-4-define/provide f32 _float)
(srfi-4-define/provide f64 _double*)
;; simply rename bytes* to implement the u8vector type
(provide (rename-out [bytes? u8vector? ]
[bytes-length u8vector-length]
[make-bytes make-u8vector ]
[bytes u8vector ]
[bytes-ref u8vector-ref ]
[bytes-set! u8vector-set! ]
[bytes->list u8vector->list ]
[list->bytes list->u8vector ]
[_bytes _u8vector ]))
;; additional `u8vector' bindings for srfi-66
(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?]))
(define* (u8vector-compare v1 v2)
(cond [(bytes<? v1 v2) -1]
[(bytes>? v1 v2) 1]
[else 0]))
(define* (u8vector-copy! src src-start dest dest-start n)
(bytes-copy! dest dest-start src src-start (+ src-start n)))

109
collects/ffi/xmmsctrl.ss
View File

@ -1,109 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libxmms (ffi-lib "libxmms"))
(provide session)
(define session
(make-parameter
0 (lambda (x)
(if (integer? x)
x
(error 'xmms-session "expecting an integer, got ~s" x)))))
;; used for playlist position values
(define _pos _int)
;; number of equalizer bands
(define eq-bands 10)
;; used for getting the default session from the session parameter
(define-fun-syntax _session
(syntax-id-rules (_session)
[_session (type: _int pre: (session))]))
(define-syntax defxmms
(syntax-rules (:)
[(_ name : x ...)
(begin
(provide name)
(define name
(get-ffi-obj
(regexp-replaces
'name '((#rx"-" "_") (#rx"[?]$" "") (#rx"^" "xmms_remote_")))
libxmms (_fun x ...))))]))
(defxmms playlist : (files enqueue?) ::
_session
(files : (_list i _string))
(_int = (length files))
(enqueue? : _bool)
-> _void)
(defxmms get-version : _session -> _int)
;; The second argument is a GList (see glib/glist.h) which requires structs,
;; but the playlist function is sufficient (looks like this is for glib code).
;; (defxmms playlist-add : _session "GList * list" -> _void)
(defxmms playlist-delete : _session _pos -> _void)
(defxmms play : _session -> _void)
(defxmms pause : _session -> _void)
(defxmms stop : _session -> _void)
(defxmms is-playing? : _session -> _bool)
(defxmms is-paused? : _session -> _bool)
(defxmms get-playlist-pos : _session -> _pos)
(defxmms set-playlist-pos : _session _pos -> _void)
(defxmms get-playlist-length : _session -> _pos)
(defxmms playlist-clear : _session -> _void)
(defxmms get-output-time : _session -> _int)
(defxmms jump-to-time : _session _int -> _void)
(defxmms get-volume : _session (l : (_ptr o _int)) (r : (_ptr o _int))
-> _void -> (list l r))
(defxmms get-main-volume : _session -> _int)
(defxmms get-balance : _session -> _int)
(defxmms set-volume : _session (l : _int) (r : _int) -> _void)
(defxmms set-main-volume : _session _int -> _void)
(defxmms set-balance : _session _int -> _void)
(defxmms get-skin : _session -> _file)
(defxmms set-skin : _session _file -> _void)
(defxmms get-playlist-file : _session _pos -> _string)
(defxmms get-playlist-title : _session _pos -> _string)
(defxmms get-playlist-time : _session _pos -> _int)
(defxmms get-info : _session
(rate : (_ptr o _int))
(freq : (_ptr o _int))
(nch : (_ptr o _int))
-> _void -> (list rate freq nch))
(defxmms main-win-toggle : _session (show? : _bool) -> _void)
(defxmms pl-win-toggle : _session (show? : _bool) -> _void)
(defxmms eq-win-toggle : _session (show? : _bool) -> _void)
(defxmms is-main-win? : _session -> _bool)
(defxmms is-pl-win? : _session -> _bool)
(defxmms is-eq-win? : _session -> _bool)
(defxmms show-prefs-box : _session -> _void)
(defxmms toggle-aot : _session (ontop? : _bool) -> _void)
(defxmms eject : _session -> _void)
(defxmms playlist-prev : _session -> _void)
(defxmms playlist-next : _session -> _void)
(defxmms playlist-add-url-string : _session _string -> _void)
(defxmms is-running? : _session -> _bool)
(defxmms toggle-repeat : _session -> _void)
(defxmms toggle-shuffle : _session -> _void)
(defxmms is-repeat? : _session -> _bool)
(defxmms is-shuffle? : _session -> _bool)
(defxmms get-eq : _session
(preamp : (_ptr o _float))
(bands : (_ptr o _pointer))
-> _void
-> (cons preamp (cblock->list bands _float eq-bands)))
(defxmms get-eq-preamp : _session -> _float)
(defxmms get-eq-band : _session (band : _int) -> _float)
(defxmms set-eq : (l) ::
_session
(preamp : _float = (car l))
(bands : (_list i _float) = (cdr l))
-> _void)
(defxmms set-eq-preamp : _session (preamp : _float) -> _void)
(defxmms set-eq-band : _session (band : _int) _float -> _void)
(defxmms quit : _session -> _void)
(defxmms play-pause : _session -> _void)
(defxmms playlist-ins-url-string : _session _string _pos -> _void)

104
collects/ffi/xosd.ss
View File

@ -1,104 +0,0 @@
#lang scheme/base
(require mzlib/foreign) (unsafe!)
(define libxosd (ffi-lib "libxosd"))
;; Use this type to properly destroy an xosd object
(define _xosd (make-ctype (_cpointer "xosd") #f
(lambda (p)
(if p
(register-finalizer p xosd-destroy)
(error '_xosd "got a NULL pointer"))
p)))
(define-syntax defxosd
(syntax-rules (:)
[(_ name : type ...)
(define name
(get-ffi-obj (regexp-replaces 'name '((#rx"-" "_") (#rx"[*?]$" "")))
libxosd (_fun type ...)))]))
(define-syntax defxosd*
(syntax-rules ()
[(_ name x ...) (begin (provide name) (defxosd name x ...))]))
(define _status
(make-ctype _int #f
(lambda (x)
(if (eq? -1 x)
(error 'xosd "~a"
(or (get-ffi-obj "xosd_error" libxosd _string)
"unknown xosd error"))
x))))
(define _sbool
(make-ctype _status #f
(lambda (x)
(case x [(1) #t] [(0) #f] [else (error "bad boolean value: ~e" x)]))))
;; ===== Initializing =========================================================
(defxosd* xosd-create : ; [num-lines = 1] -> xosd-obj
args :: (num-lines : _int = (if (pair? args) (car args) 1)) -> _xosd)
(defxosd xosd-destroy : _xosd -> _int)
(defxosd* xosd-is-onscreen? : _xosd -> _sbool)
;; ===== Displaying & Hiding ==================================================
(defxosd xosd-show* : _xosd -> _status)
(provide xosd-show)
(define (xosd-show xosd) (unless (xosd-is-onscreen? xosd) (xosd-show* xosd)))
(defxosd xosd-hide* : _xosd -> _status)
(provide xosd-hide)
(define (xosd-hide xosd) (when (xosd-is-onscreen? xosd) (xosd-hide* xosd)))
(defxosd* xosd-set-timeout : _xosd _int -> _status)
(defxosd* xosd-wait-until-no-display : _xosd -> _status)
;; ===== Attributed ===========================================================
(define _xosd-pos (_enum '(top bottom middle)))
(define _xosd-align (_enum '(left center right)))
(defxosd* xosd-set-pos : _xosd _xosd-pos -> _status)
(defxosd* xosd-set-align : _xosd _xosd-align -> _status)
(defxosd* xosd-set-horizontal-offset : _xosd _int -> _status)
(defxosd* xosd-set-vertical-offset : _xosd _int -> _status)
(defxosd* xosd-set-shadow-offset : _xosd _int -> _status)
(defxosd* xosd-set-outline-offset : _xosd _int -> _status)
(defxosd* xosd-set-colour : _xosd _string -> _status)
(defxosd* xosd-set-shadow-colour : _xosd _string -> _status)
(defxosd* xosd-set-outline-colour : _xosd _string -> _status)
(defxosd* xosd-set-font : _xosd _string -> _status)
(defxosd* xosd-get-colour :
_xosd (r : (_ptr o _int)) (g : (_ptr o _int)) (b : (_ptr o _int)) -> _status
-> (list r g b))
(defxosd* xosd-get-number-lines : _xosd -> _status)
;; ===== Content ==============================================================
(define _xosd-command (_enum '(percentage string printf slider)))
(define disp-int*
(get-ffi-obj "xosd_display" libxosd
(_fun _xosd _int _xosd-command _int -> _status)))
(define disp-string*
(get-ffi-obj "xosd_display" libxosd
(_fun _xosd _int _xosd-command _string -> _status)))
(provide xosd-display-percentage xosd-display-string xosd-display-slider)
;; xosd-obj percent [line-num] -> int
(define (xosd-display-percentage xosd percent . line)
(disp-int* xosd (if (pair? line) (car line) 0) 'percentage percent))
;; xosd-obj string [line-num] -> int
(define (xosd-display-string xosd str . line)
(disp-string* xosd (if (pair? line) (car line) 0) 'string str))
;; xosd-obj percent [line-num] -> int
(define (xosd-display-slider xosd int . line)
(disp-int* xosd (if (pair? line) (car line) 0) 'slider int))
(defxosd* xosd-set-bar-length : _xosd _int -> _status)
(defxosd* xosd-scroll : _xosd _int -> _status)

10
collects/scheme/foreign.rkt
View File

@ -1,16 +1,16 @@
#lang racket/base
(require (for-syntax scheme/base))
(define-syntax-rule (provide-except-unsafe lib u! id ...)
(define-syntax-rule (provide-except-unsafe (ulib ...) u! id ...)
(begin
(require lib)
(provide (except-out (all-from-out lib) id ...))
(require ulib ...)
(provide (except-out (all-from-out ulib ...) id ...))
(define-syntax (u! stx)
(syntax-case stx ()
[(_) (with-syntax ([lib+ids (datum->syntax stx '(lib id ...))])
[(_) (with-syntax ([lib+ids (datum->syntax stx `((,#'combine-in ulib ...) id ...))])
#'(require (only-in . lib+ids)))]))))
(provide-except-unsafe racket/unsafe/ffi unsafe!
(provide-except-unsafe (ffi/unsafe ffi/unsafe/cvector ffi/vector) unsafe!
free end-stubborn-change
ptr-ref ptr-set! cast

10
collects/scribblings/foreign/alloc.scrbl
View File

@ -1,13 +1,13 @@
#lang scribble/doc
@(require "utils.ss"
(for-label racket/unsafe/ffi/alloc
racket/unsafe/ffi/define
racket/unsafe/ffi/atomic))
(for-label ffi/unsafe/alloc
ffi/unsafe/define
ffi/unsafe/atomic))
@title{Allocation and Finalization}
@defmodule[racket/unsafe/ffi/alloc]{The
@schememodname[racket/unsafe/ffi/alloc] library provides utilities for
@defmodule[ffi/unsafe/alloc]{The
@schememodname[ffi/unsafe/alloc] library provides utilities for
ensuring that values allocated through foreign functions are reliably
deallocated.}

4
collects/scribblings/foreign/atomic.scrbl
View File

@ -1,10 +1,10 @@
#lang scribble/doc
@(require "utils.ss"
(for-label racket/unsafe/ffi/atomic))
(for-label ffi/unsafe/atomic))
@title{Atomic Execution}
@defmodule[racket/unsafe/ffi/atomic]
@defmodule[ffi/unsafe/atomic]
@deftogether[(
@defproc[(start-atomic) void?]

84
collects/scribblings/foreign/cpointer.scrbl Normal file
View File

@ -0,0 +1,84 @@
#lang scribble/doc
@(require "utils.ss")
@title[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types}
The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!]
operations manage tags to distinguish pointer types.
@defproc*[([(_cpointer [tag any/c]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype]
[(_cpointer/null [tag any/c]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype])]{
Construct a kind of a pointer that gets a specific tag when converted
to Scheme, and accept only such tagged pointers when going to C. An
optional @scheme[ptr-type] can be given to be used as the base pointer
type, instead of @scheme[_pointer].
Pointer tags are checked with @scheme[cpointer-has-tag?] and changed
with @scheme[cpointer-push-tag!] which means that other tags are
preserved. Specifically, if a base @scheme[ptr-type] is given and is
itself a @scheme[_cpointer], then the new type will handle pointers
that have the new tag in addition to @scheme[ptr-type]'s tag(s). When
the tag is a pair, its first value is used for printing, so the most
recently pushed tag which corresponds to the inheriting type will be
displayed.
Note that tags are compared with @scheme[eq?] (or @scheme[memq]), which means
an interface can hide its value from users (e.g., not provide the
@scheme[cpointer-tag] accessor), which makes such pointers un-fake-able.
@scheme[_cpointer/null] is similar to @scheme[_cpointer] except that
it tolerates @cpp{NULL} pointers both going to C and back. Note that
@cpp{NULL} pointers are represented as @scheme[#f] in Scheme, so they
are not tagged.}
@defform*[[(define-cpointer-type _id)
(define-cpointer-type _id scheme-to-c-expr)
(define-cpointer-type _id scheme-to-c-expr c-to-scheme-expr)]]{
A macro version of @scheme[_cpointer] and @scheme[_cpointer/null],
using the defined name for a tag string, and defining a predicate
too. The @scheme[_id] must start with @litchar{_}.
The optional expression produces optional arguments to @scheme[_cpointer].
In addition to defining @scheme[_id] to a type generated by
@scheme[_cpointer], @scheme[_id]@schemeidfont{/null} is bound to a
type produced by @scheme[_cpointer/null] type. Finally,
@schemevarfont{id}@schemeidfont{?} is defined as a predicate, and
@schemevarfont{id}@schemeidfont{-tag} is defined as an accessor to
obtain a tag. The tag is the string form of @schemevarfont{id}.}
@defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{
These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any
role, except for Scheme code that uses it to distinguish pointers;
these functions treat the tag value as a list of tags, which makes it
possible to construct pointer types that can be treated as other
pointer types, mainly for implementing inheritance via upcasts (when a
struct contains a super struct as its first element).
The @scheme[cpointer-has-tag?] function checks whether if the given
@scheme[cptr] has the @scheme[tag]. A pointer has a tag @scheme[tag]
when its tag is either @scheme[eq?] to @scheme[tag] or a list that
contains (in the sense of @scheme[memq]) @scheme[tag].
The @scheme[cpointer-push-tag!] function pushes the given @scheme[tag]
value on @scheme[cptr]'s tags. The main properties of this operation
are: (a) pushing any tag will make later calls to
@scheme[cpointer-has-tag?] succeed with this tag, and (b) the pushed tag
will be used when printing the pointer (until a new value is pushed).
Technically, pushing a tag will simply set it if there is no tag set,
otherwise push it on an existing list or an existing value (treated as
a single-element list).}

89
collects/scribblings/foreign/cvector.scrbl Normal file
View File

@ -0,0 +1,89 @@
#lang scribble/doc
@(require "utils.ss")
@title[#:tag "foreign:cvector"]{Safe C Vectors}
@defmodule*[(ffi/cvector ffi/unsafe/cvector)
#:use-sources (ffi/unsafe/cvector)]{The
@schememodname[ffi/unsafe/cvector] library exports the bindings of
this section. The @schememodname[ffi/cvector] library exports the same
bindings, except for the unsafe @scheme[make-cvector*] operation.}
The @scheme[cvector] form can be used as a type C vectors (i.e., a
pointer to a memory block).
@defform*[[(_cvector mode type maybe-len)
_cvector]]{
Like @scheme[_bytes], @scheme[_cvector] can be used as a simple type
that corresponds to a pointer that is managed as a safe C vector on
the Scheme side. The longer form behaves similarly to the
@scheme[_list] and @scheme[_vector] custom types, except that
@scheme[_cvector] is more efficient; no Scheme list or vector is
needed.}
@defproc[(make-cvector [type ctype?][length exact-nonnegative-integer?]) cvector?]{
Allocates a C vector using the given @scheme[type] and
@scheme[length].}
@defproc[(cvector [type ctype?][val any/c] ...) cvector?]{
Creates a C vector of the given @scheme[type], initialized to the
given list of @scheme[val]s.}
@defproc[(cvector? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a C vector, @scheme[#f] otherwise.}
@defproc[(cvector-length [cvec cvector?]) exact-nonnegative-integer?]{
Returns the length of a C vector.}
@defproc[(cvector-type [cvec cvector?]) ctype?]{
Returns the C type object of a C vector.}
@defproc[(cvector-ptr [cvec cvector?]) cpointer?]{
Returns the pointer that points at the beginning block of the given C vector.}
@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{
References the @scheme[k]th element of the @scheme[cvec] C vector.
The result has the type that the C vector uses.}
@defproc[(cvector-set! [cvec cvector?][k exact-nonnegative-integer?][val any]) void?]{
Sets the @scheme[k]th element of the @scheme[cvec] C vector to
@scheme[val]. The @scheme[val] argument should be a value that can be
used with the type that the C vector uses.}
@defproc[(cvector->list [cvec cvector?]) list?]{
Converts the @scheme[cvec] C vector object to a list of values.}
@defproc[(list->cvector [lst list?][type ctype?]) cvector?]{
Converts the list @scheme[lst] to a C vector of the given
@scheme[type].}
@defproc[(make-cvector* [cptr any/c] [type ctype?]
[length exact-nonnegative-integer?])
cvector?]{
Constructs a C vector using an existing pointer object. This
operation is not safe, so it is intended to be used in specific
situations where the @scheme[type] and @scheme[length] are known.}

6
collects/scribblings/foreign/define.scrbl
View File

@ -1,11 +1,11 @@
#lang scribble/doc
@(require "utils.ss"
(for-label racket/unsafe/ffi/define
racket/unsafe/ffi/alloc))
(for-label ffi/unsafe/define
ffi/unsafe/alloc))
@title{Defining Bindings}
@defmodule[racket/unsafe/ffi/define]
@defmodule[ffi/unsafe/define]
@defform/subs[(define-ffi-definer define-id ffi-lib-expr
option ...)

277
collects/scribblings/foreign/derived.scrbl
View File

@ -5,281 +5,10 @@
@local-table-of-contents[]
@; ------------------------------------------------------------
@include-section["vector.scrbl"]
@include-section["cvector.scrbl"]
@include-section["cpointer.scrbl"]
@include-section["define.scrbl"]
@; ------------------------------------------------------------
@section[#:tag "foreign:tagged-pointers"]{Tagged C Pointer Types}
The unsafe @scheme[cpointer-has-tag?] and @scheme[cpointer-push-tag!]
operations manage tags to distinguish pointer types.
@defproc*[([(_cpointer [tag any/c]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype]
[(_cpointer/null [tag any/c]
[ptr-type ctype? _xpointer]
[scheme-to-c (any/c . -> . any/c) values]
[c-to-scheme (any/c . -> . any/c) values])
ctype])]{
Construct a kind of a pointer that gets a specific tag when converted
to Scheme, and accept only such tagged pointers when going to C. An
optional @scheme[ptr-type] can be given to be used as the base pointer
type, instead of @scheme[_pointer].
Pointer tags are checked with @scheme[cpointer-has-tag?] and changed
with @scheme[cpointer-push-tag!] which means that other tags are
preserved. Specifically, if a base @scheme[ptr-type] is given and is
itself a @scheme[_cpointer], then the new type will handle pointers
that have the new tag in addition to @scheme[ptr-type]'s tag(s). When
the tag is a pair, its first value is used for printing, so the most
recently pushed tag which corresponds to the inheriting type will be
displayed.
Note that tags are compared with @scheme[eq?] (or @scheme[memq]), which means
an interface can hide its value from users (e.g., not provide the
@scheme[cpointer-tag] accessor), which makes such pointers un-fake-able.
@scheme[_cpointer/null] is similar to @scheme[_cpointer] except that
it tolerates @cpp{NULL} pointers both going to C and back. Note that
@cpp{NULL} pointers are represented as @scheme[#f] in Scheme, so they
are not tagged.}
@defform*[[(define-cpointer-type _id)
(define-cpointer-type _id scheme-to-c-expr)
(define-cpointer-type _id scheme-to-c-expr c-to-scheme-expr)]]{
A macro version of @scheme[_cpointer] and @scheme[_cpointer/null],
using the defined name for a tag string, and defining a predicate
too. The @scheme[_id] must start with @litchar{_}.
The optional expression produces optional arguments to @scheme[_cpointer].
In addition to defining @scheme[_id] to a type generated by
@scheme[_cpointer], @scheme[_id]@schemeidfont{/null} is bound to a
type produced by @scheme[_cpointer/null] type. Finally,
@schemevarfont{id}@schemeidfont{?} is defined as a predicate, and
@schemevarfont{id}@schemeidfont{-tag} is defined as an accessor to
obtain a tag. The tag is the string form of @schemevarfont{id}.}
@defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?]
[(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{
These two functions treat pointer tags as lists of tags. As described
in @secref["foreign:pointer-funcs"], a pointer tag does not have any
role, except for Scheme code that uses it to distinguish pointers;
these functions treat the tag value as a list of tags, which makes it
possible to construct pointer types that can be treated as other
pointer types, mainly for implementing inheritance via upcasts (when a
struct contains a super struct as its first element).
The @scheme[cpointer-has-tag?] function checks whether if the given
@scheme[cptr] has the @scheme[tag]. A pointer has a tag @scheme[tag]
when its tag is either @scheme[eq?] to @scheme[tag] or a list that
contains (in the sense of @scheme[memq]) @scheme[tag].
The @scheme[cpointer-push-tag!] function pushes the given @scheme[tag]
value on @scheme[cptr]'s tags. The main properties of this operation
are: (a) pushing any tag will make later calls to
@scheme[cpointer-has-tag?] succeed with this tag, and (b) the pushed tag
will be used when printing the pointer (until a new value is pushed).
Technically, pushing a tag will simply set it if there is no tag set,
otherwise push it on an existing list or an existing value (treated as
a single-element list).}
@; ------------------------------------------------------------
@section[#:tag "foreign:cvector"]{Safe C Vectors}
The @scheme[cvector] form can be used as a type C vectors (i.e., a
pointer to a memory block).
@defproc[(make-cvector [type ctype?][length exact-nonnegative-integer?]) cvector?]{
Allocates a C vector using the given @scheme[type] and
@scheme[length].}
@defproc[(cvector [type ctype?][val any/c] ...) cvector?]{
Creates a C vector of the given @scheme[type], initialized to the
given list of @scheme[val]s.}
@defproc[(cvector? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a C vector, @scheme[#f] otherwise.}
@defproc[(cvector-length [cvec cvector?]) exact-nonnegative-integer?]{
Returns the length of a C vector.}
@defproc[(cvector-type [cvec cvector?]) ctype?]{
Returns the C type object of a C vector.}
@defproc[(cvector-ptr [cvec cvector?]) cpointer?]{
Returns the pointer that points at the beginning block of the given C vector.}
@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{
References the @scheme[k]th element of the @scheme[cvec] C vector.
The result has the type that the C vector uses.}
@defproc[(cvector-set! [cvec cvector?][k exact-nonnegative-integer?][val any]) void?]{
Sets the @scheme[k]th element of the @scheme[cvec] C vector to
@scheme[val]. The @scheme[val] argument should be a value that can be
used with the type that the C vector uses.}
@defproc[(cvector->list [cvec cvector?]) list?]{
Converts the @scheme[cvec] C vector object to a list of values.}
@defproc[(list->cvector [lst list?][type ctype?]) cvector?]{
Converts the list @scheme[lst] to a C vector of the given
@scheme[type].}
@defproc[(make-cvector* [cptr any/c] [type ctype?]
[length exact-nonnegative-integer?])
cvector?]{
Constructs a C vector using an existing pointer object. This
operation is not safe, so it is intended to be used in specific
situations where the @scheme[type] and @scheme[length] are known.}
@; ------------------------------------------------------------
@section[#:tag "homogeneous-vectors"]{Homogenous Vectors}
Homogenous vectors are similar to C vectors (see
@secref["foreign:cvector"]), except that they define different types
of vectors, each with a hard-wired type.
An exception is the @schemeidfont{u8} family of bindings, which are
just aliases for byte-string bindings: @scheme[make-u8vector],
@scheme[u8vector]. @scheme[u8vector?], @scheme[u8vector-length],
@scheme[u8vector-ref], @scheme[u8vector-set!],
@scheme[list->u8vector], @scheme[u8vector->list].
@(begin
(require (for-syntax scheme/base))
(define-syntax (srfi-4-vector stx)
(syntax-case stx ()
[(_ id elem)
#'(srfi-4-vector/desc id elem
"Like " (scheme make-vector) ", etc., but for " (scheme elem) " elements.")]))
(define-syntax (srfi-4-vector/desc stx)
(syntax-case stx ()
[(_ id elem . desc)
(let ([mk
(lambda l
(datum->syntax
#'id
(string->symbol
(apply string-append
(map (lambda (i)
(if (identifier? i)
(symbol->string (syntax-e i))
i))
l)))
#'id))])
(with-syntax ([make (mk "make-" #'id "vector")]
[vecr (mk #'id "vector")]
[? (mk #'id "vector?")]
[length (mk #'id "vector-length")]
[ref (mk #'id "vector-ref")]
[! (mk #'id "vector-set!")]
[list-> (mk "list->" #'id "vector")]
[->list (mk #'id "vector->list")]
[->cpointer (mk #'id "vector->cpointer")]
[_vec (mk "_" #'id "vector")])
#`(begin
(defproc* ([(make [len exact-nonnegative-integer?]) ?]
[(vecr [val number?] (... ...)) ?]
[(? [v any/c]) boolean?]
[(length [vec ?]) exact-nonnegative-integer?]
[(ref [vec ?][k exact-nonnegative-integer?]) number?]
[(! [vec ?][k exact-nonnegative-integer?][val number?]) void?]
[(list-> [lst (listof number?)]) ?]
[(->list [vec ?]) (listof number?)]
[(->cpointer [vec ?]) cpointer?])
. desc)
;; Big pain: make up relatively-correct source locations
;; for pieces in the _vec definition:
(defform* [#,(datum->syntax
#'_vec
(cons #'_vec
(let loop ([l '(mode maybe-len)]
[col (+ (syntax-column #'_vec)
(syntax-span #'_vec)
1)]
[pos (+ (syntax-position #'_vec)
(syntax-span #'_vec)
1)])
(if (null? l)
null
(let ([span (string-length (symbol->string (car l)))])
(cons (datum->syntax
#'_vec
(car l)
(list (syntax-source #'_vec)
(syntax-line #'_vec)
col
pos
span))
(loop (cdr l)
(+ col 1 span)
(+ pos 1 span)))))))
(list (syntax-source #'_vec)
(syntax-line #'_vec)
(sub1 (syntax-column #'vec))
(sub1 (syntax-position #'vec))
10))
_vec]
"Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))])))
@srfi-4-vector/desc[u8 _uint8]{
Like @scheme[_cvector], but for vectors of @scheme[_byte] elements. These are
aliases for @schemeidfont{byte} operations.}
@srfi-4-vector[s8 _int8]
@srfi-4-vector[s16 _int16]
@srfi-4-vector[u16 _uint16]
@srfi-4-vector[s32 _int32]
@srfi-4-vector[u32 _uint32]
@srfi-4-vector[s64 _int64]
@srfi-4-vector[u64 _uint64]
@srfi-4-vector[f32 _float]
@srfi-4-vector[f64 _double*]
@; ------------------------------------------------------------
@include-section["alloc.scrbl"]
@; ------------------------------------------------------------
@include-section["atomic.scrbl"]
@; ------------------------------------------------------------
@include-section["objc.scrbl"]

6
collects/scribblings/foreign/foreign.scrbl
View File

@ -5,9 +5,9 @@
@author["Eli Barzilay"]
@defmodule[racket/unsafe/ffi #:use-sources ('#%foreign)]
@defmodule[ffi/unsafe #:use-sources ('#%foreign)]
The @schememodname[racket/unsafe/ffi] library enables the direct use of
The @schememodname[ffi/unsafe] library enables the direct use of
C-based APIs within Racket programs---without writing any new C
code. From the Racket perspective, functions and data with a C-based
API are @idefterm{foreign}, hence the term @defterm{foreign
@ -21,8 +21,8 @@ interface}, abbreviated @deftech{FFI}.
@include-section["libs.scrbl"]
@include-section["types.scrbl"]
@include-section["pointers.scrbl"]
@include-section["misc.scrbl"]
@include-section["derived.scrbl"]
@include-section["misc.scrbl"]
@include-section["unexported.scrbl"]
@index-section[]

14
collects/scribblings/foreign/objc.scrbl
View File

@ -3,8 +3,8 @@
scribble/eval
(for-label racket/base
racket/contract
racket/unsafe/ffi/objc
(except-in racket/unsafe/ffi ->)
ffi/unsafe/objc
(except-in ffi/unsafe ->)
(only-in ffi/objc objc-unsafe!)
(only-in scheme/foreign unsafe!)))
@ -16,9 +16,9 @@
@title{Objective-C FFI}
@defmodule[racket/unsafe/ffi/objc]{The
@racketmodname[racket/unsafe/ffi/objc] library builds on
@racketmodname[racket/unsafe/ffi] to support interaction with
@defmodule[ffi/unsafe/objc]{The
@racketmodname[ffi/unsafe/objc] library builds on
@racketmodname[ffi/unsafe] to support interaction with
@link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.}
The library supports Objective-C interaction in two layers. The upper
@ -333,12 +333,12 @@ Constructor and FFI C type use for super calls.}
@section{Legacy Library}
@defmodule[ffi/objc]{The @racketmodname[ffi/objc] library is a
deprecated entry point to @racketmodname[racket/unsafe/ffi/objc]. It
deprecated entry point to @racketmodname[ffi/unsafe/objc]. It
exports only safe operations directly, and unsafe operations are
imported using @racket[objc-unsafe!].}
@defform[(objc-unsafe!)]{
Analogous to @racket[(unsafe!)], makes unsafe bindings of
@racketmodname[racket/unsafe/ffi/objc] available in the importing
@racketmodname[ffi/unsafe/objc] available in the importing
module.}

11
collects/scribblings/foreign/types.scrbl
View File

@ -709,17 +709,6 @@ like @scheme[_bytes], since the string carries its size information
is present for consistency with the above macros).}
@defform*[[(_cvector mode type maybe-len)
_cvector]]{
Like @scheme[_bytes], @scheme[_cvector] can be used as a simple type
that corresponds to a pointer that is managed as a safe C vector on
the Scheme side; see @secref["foreign:cvector"]. The longer form
behaves similarly to the @scheme[_list] and @scheme[_vector] custom
types, except that @scheme[_cvector] is more efficient; no Scheme
list or vector is needed.}
@; ------------------------------------------------------------
@section{C Struct Types}

4
collects/scribblings/foreign/unexported.scrbl
View File

@ -9,8 +9,8 @@
@declare-exporting['#%foreign]
Parts of the @schememodname[scheme/foreign] library are implemented by
the MzScheme built-in @schememodname['#%foreign] module. The
Parts of the @schememodname[ffi/unsafe] library are implemented by
the Racket built-in @schememodname['#%foreign] module. The
@schememodname['#%foreign] module is not intended for direct use, but
it exports the following procedures. If you find any of these useful,
please let us know.

31
collects/scribblings/foreign/unsafe-foreign.ss
View File

@ -1,31 +0,0 @@
#lang scheme/base
(require scheme/foreign
(for-syntax scheme/base
scheme/provide-transform))
(error 'unsafe! "only `for-label' use in the documentation")
(unsafe!)
;; This is like `all-defined-out', but it ignores the 'not-provide-all-defined
;; property, so that the bindings introduced by `unsafe!' are exported.
(define-syntax all-unsafe-defined-out
(make-provide-transformer
(lambda (stx modes)
(syntax-case stx ()
[(_)
(let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)]
[(same-ctx?) (lambda (free-identifier=?)
(lambda (id)
(free-identifier=? id
(datum->syntax
stx
(syntax-e id)))))])
(map (lambda (id)
(make-export id (syntax-e id) 0 #f stx))
(filter (same-ctx? free-identifier=?)
ids)))]))))
(provide (protect-out (all-unsafe-defined-out))
(all-from-out scheme/foreign))

8
collects/scribblings/foreign/utils.ss
View File

@ -7,14 +7,18 @@
(for-syntax racket/base)
(for-label racket/base
racket/contract
(except-in racket/unsafe/ffi ->)))
(except-in ffi/unsafe ->)
ffi/unsafe/cvector
ffi/vector))
(provide cpp
InsideMzScheme
(all-from-out scribble/manual)
(for-label (all-from-out racket/base
racket/contract
racket/unsafe/ffi)))
ffi/unsafe
ffi/unsafe/cvector
ffi/vector)))
(define InsideMzScheme

110
collects/scribblings/foreign/vector.scrbl Normal file
View File

@ -0,0 +1,110 @@
#lang scribble/doc
@(require "utils.ss")
@title[#:tag "homogeneous-vectors"]{Safe Homogenous Vectors}
@defmodule[ffi/vector]
Homogenous vectors are similar to C vectors (see
@secref["foreign:cvector"]), except that they define different types
of vectors, each with a hard-wired type.
An exception is the @schemeidfont{u8} family of bindings, which are
just aliases for byte-string bindings: @scheme[make-u8vector],
@scheme[u8vector]. @scheme[u8vector?], @scheme[u8vector-length],
@scheme[u8vector-ref], @scheme[u8vector-set!],
@scheme[list->u8vector], @scheme[u8vector->list].
@(begin
(require (for-syntax scheme/base))
(define-syntax (srfi-4-vector stx)
(syntax-case stx ()
[(_ id elem)
#'(srfi-4-vector/desc id elem
"Like " (scheme make-vector) ", etc., but for " (scheme elem) " elements.")]))
(define-syntax (srfi-4-vector/desc stx)
(syntax-case stx ()
[(_ id elem . desc)
(let ([mk
(lambda l
(datum->syntax
#'id
(string->symbol
(apply string-append
(map (lambda (i)
(if (identifier? i)
(symbol->string (syntax-e i))
i))
l)))
#'id))])
(with-syntax ([make (mk "make-" #'id "vector")]
[vecr (mk #'id "vector")]
[? (mk #'id "vector?")]
[length (mk #'id "vector-length")]
[ref (mk #'id "vector-ref")]
[! (mk #'id "vector-set!")]
[list-> (mk "list->" #'id "vector")]
[->list (mk #'id "vector->list")]
[->cpointer (mk #'id "vector->cpointer")]
[_vec (mk "_" #'id "vector")])
#`(begin
(defproc* ([(make [len exact-nonnegative-integer?]) ?]
[(vecr [val number?] (... ...)) ?]
[(? [v any/c]) boolean?]
[(length [vec ?]) exact-nonnegative-integer?]
[(ref [vec ?][k exact-nonnegative-integer?]) number?]
[(! [vec ?][k exact-nonnegative-integer?][val number?]) void?]
[(list-> [lst (listof number?)]) ?]
[(->list [vec ?]) (listof number?)]
[(->cpointer [vec ?]) cpointer?])
. desc)
;; Big pain: make up relatively-correct source locations
;; for pieces in the _vec definition:
(defform* [#,(datum->syntax
#'_vec
(cons #'_vec
(let loop ([l '(mode maybe-len)]
[col (+ (syntax-column #'_vec)
(syntax-span #'_vec)
1)]
[pos (+ (syntax-position #'_vec)
(syntax-span #'_vec)
1)])
(if (null? l)
null
(let ([span (string-length (symbol->string (car l)))])
(cons (datum->syntax
#'_vec
(car l)
(list (syntax-source #'_vec)
(syntax-line #'_vec)
col
pos
span))
(loop (cdr l)
(+ col 1 span)
(+ pos 1 span)))))))
(list (syntax-source #'_vec)
(syntax-line #'_vec)
(sub1 (syntax-column #'vec))
(sub1 (syntax-position #'vec))
10))
_vec]
"Like " (scheme _cvector) ", but for vectors of " (scheme elem) " elements."))))])))
@srfi-4-vector/desc[u8 _uint8]{
Like @scheme[_cvector], but for vectors of @scheme[_byte] elements. These are
aliases for @schemeidfont{byte} operations.}
@srfi-4-vector[s8 _int8]
@srfi-4-vector[s16 _int16]
@srfi-4-vector[u16 _uint16]
@srfi-4-vector[s32 _int32]
@srfi-4-vector[u32 _uint32]
@srfi-4-vector[s64 _int64]
@srfi-4-vector[u64 _uint64]
@srfi-4-vector[f32 _float]
@srfi-4-vector[f64 _double*]

2
collects/scribblings/reference/numbers.scrbl
View File

@ -956,7 +956,7 @@ unsafe operations on @tech{flvector}s (see
@schememodname[racket/unsafe/ops]) can execute more efficiently than
unsafe operations on @tech{vectors} of inexact reals.
An f64vector as provided by @schememodname[racket/unsafe/ffi] stores the
An f64vector as provided by @schememodname[ffi/vector] stores the
same kinds of values as an @tech{flvector}, but with extra
indirections that make f64vectors more convenient for working with
foreign libraries. The lack of indirections make unsafe

2
collects/scribblings/reference/unsafe.scrbl
View File

@ -2,7 +2,7 @@
@(require "mz.ss"
(for-label racket/unsafe/ops
racket/flonum
(only-in racket/unsafe/ffi
(only-in ffi/vector
f64vector?
f64vector-ref
f64vector-set!)))