source: project/release/4/openal/tags/0.91/openal.scm @ 32831

Last change on this file since 32831 was 32831, checked in by felix winkelmann, 4 years ago

openal 0.91: make buf argument to openal:make-source truly optional (patch by Alex Charlton)

File size: 2.5 KB
Line 
1;;;; openal.scm
2
3
4(module openal (openal:device-list
5                openal:make-buffer
6                openal:make-source)
7  (import scheme chicken foreign)
8  (use al alc srfi-4 lolevel data-structures)
9
10(define (openal:device-list)
11  (string-split
12   ((foreign-lambda* c-string* ((int id)) #<<EOF
13     extern char *alcGetString(void *, int);
14     int i;
15     char *lst = alcGetString(NULL, id);
16     char *dst = (char *)malloc(strlen(lst) + 2);
17     if(dst == NULL) return(NULL);
18     if(lst == NULL) return("\0");
19     for(i = 0; lst[ i ] != '\0' || lst[ i + 1 ] != '\0'; ++i)
20       if(lst[ i ] == '\0') dst[ i ] = '/';
21       dst[ i ] = lst[ i ];
22     return(lst);
23EOF
24)
25    alc:DEVICE_SPECIFIER)
26   "/") )
27
28(declare (hide check))
29
30(define (check thunk #!optional (msg "OpenAL operation failed") . args)
31  (al:GetError)
32  (call-with-values thunk
33    (lambda results
34      (let ((err (al:GetError)))
35        (unless (= err al:NO_ERROR)
36          (abort
37           (make-composite-condition
38            (make-property-condition 'exn 'message msg 'arguments (if (pair? args) args (list err)))
39            (make-property-condition 'openal 'class 'AL 'code err) ) ) ) )
40        (apply values results) ) ) )
41
42(define (check/device thunk device #!optional (msg "OpenAL operation failed") . args)
43  (alc:GetError device)
44  (call-with-values (lambda () (apply check thunk msg args))
45    (lambda results
46      (let ((err (alc:GetError device)))
47        (unless (= err alc:NO_ERROR)
48          (abort
49           (make-composite-condition
50            (make-property-condition 'exn 'message msg 'arguments (if (pair? args) args (list err)))
51            (make-property-condition 'openal 'class 'ALC 'code err) ) ) ) )
52        (apply values results) ) ) )
53
54(define (openal:make-buffer data stereo freq)
55  (let ((buf (check
56              (lambda ()
57                (let ((v (make-u32vector 1)))
58                  (al:GenBuffers 1 v)
59                  (u32vector-ref v 0) ) ) 
60              "can not generate buffer") ) )
61    (check
62     (lambda () 
63       (al:BufferData 
64        buf 
65        (cond ((u8vector? data) (if stereo al:FORMAT_STEREO8 al:FORMAT_MONO8))
66              ((s16vector? data) (if stereo al:FORMAT_STEREO16 al:FORMAT_MONO16))
67              (else (error 'make-openal-buffer "invalid data format" data)) )
68        (make-locative data)
69        (if (u8vector? data) (u8vector-length data) (fx* 2 (s16vector-length data)))
70        freq)
71       buf)
72     "can not set buffer data" buf data) ) )
73
74(define (openal:make-source #!optional buf)
75  (let ((src (check
76              (lambda ()
77                (let ((v (make-u32vector 1)))
78                  (al:GenSources 1 v)
79                  (u32vector-ref v 0) ) )
80              "can not generate source") ) )
81    (when buf
82      (check
83       (lambda ()
84         (al:Sourcei src al:BUFFER buf) ) ) )
85    src) )
86
87)
Note: See TracBrowser for help on using the repository browser.