source: project/release/4/sdl/trunk/sdl.scm @ 27086

Last change on this file since 27086 was 27086, checked in by megane, 9 years ago
  • added img-init (as suggested by `iisjmii') and img-quit
File size: 52.8 KB
Line 
1;;;; sdl.scm - Simple SDL binding for Chicken
2; Copyright (C) 2002-2004 Tony Garnock-Jones <tonyg@kcbbs.gen.nz>
3;
4; This library is free software; you can redistribute it and/or modify
5; it under the terms of the GNU Library General Public License as
6; published by the Free Software Foundation; either version 2 of the
7; License, or (at your option) any later version.
8;
9; This library is distributed in the hope that it will be useful, but
10; WITHOUT ANY WARRANTY; without even the implied warranty of
11; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
12; Library General Public License for more details.
13;
14; You should have received a copy of the GNU Library General Public
15; License along with this library; if not, write to the Free
16; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
17; USA
18
19; ---------------------------------------------------------------------------
20
21(module sdl
22
23( *sdl-egg-version*
24
25  SDL_BUTTON
26  sdl-version-major
27  sdl-version-minor
28  sdl-version-patch
29  sdl-version-at-least
30  sdl-compiled-version
31  sdl-linked-version
32  ; sdl gfx
33  make-sdl-rect
34  sdl-rect?
35  sdl-rect-x
36  sdl-rect-y
37  sdl-rect-w
38  sdl-rect-h
39  make-sdl-pixel-format
40  sdl-pixel-format?
41  sdl-pixel-format-bytes-per-pixel
42  sdl-pixel-format-rmask
43  sdl-pixel-format-gmask
44  sdl-pixel-format-bmask
45  sdl-pixel-format-amask
46  sdl-surface-flags
47  sdl-surface-pixel-format
48  sdl-surface-width
49  sdl-surface-height
50  sdl-surface-pitch
51  sdl-surface-pixels
52  sdl-surface-pixels-length
53  sdl-get-video-info
54  sdl-video-info-hw-available
55  sdl-video-info-wm-available
56  sdl-video-info-blit-hw
57  sdl-video-info-blit-hw-cc
58  sdl-video-info-blit-hw-a
59  sdl-video-info-blit-sw
60  sdl-video-info-blit-sw-cc
61  sdl-video-info-blit-sw-a
62  sdl-video-info-blit-fill
63  sdl-video-info-video-mem
64  sdl-video-info-vfmt
65  sdl-video-info-current-w
66  sdl-video-info-current-h
67  sdl-get-clip-rect!
68  sdl-set-clip-rect!
69  sdl-set-color-key!
70  sdl-set-alpha!
71  sdl-display-format
72  sdl-display-format-alpha
73  sdl-convert-surface
74
75  ; sdl system stuff
76  sdl-init
77  sdl-init-sub-system
78  sdl-quit-sub-system
79  sdl-quit
80  sdl-was-init
81  sdl-get-error
82  sdl-clear-error!
83  sdl-wm-set-caption
84  sdl-wm-get-caption-title
85  sdl-wm-get-caption-icon
86  sdl-wm-get-caption
87  sdl-wm-set-icon
88  sdl-wm-iconify-window
89  sdl-wm-toggle-full-screen
90  sdl-wm-grab-input
91  sdl-get-ticks
92  sdl-delay
93  timer?
94  get-time-of-day
95  get-time-of-day
96  sdl-add-relative-timer!
97  make-sdl-event
98  sdl-event?
99  sdl-event-type
100  sdl-pump-events
101  sdl-poll-event!
102  sdl-wait-event!*
103  sdl-wait-event!
104  sdl-push-event
105  sdl-event-state!
106  sdl-get-mouse-state
107  sdl-warp-mouse
108  sdl-enable-unicode
109  sdl-get-video-surface
110  sdl-video-driver-name
111  sdl-set-video-mode
112  sdl-video-mode-ok
113  sdl-show-cursor
114  sdl-map-rgb
115  sdl-map-rgba
116  sdl-fill-rect
117  sdl-flip
118  sdl-surface?
119  sdl-create-rgb-surface
120  sdl-free-surface
121  sdl-blit-surface
122  sdl-with-clip-rect
123  make-sdl-color
124  sdl-color?
125  sdl-color-r
126  sdl-color-g
127  sdl-color-b
128
129  make-sdl-joystick
130  sdl-joystick?
131  sdl-joystick-event-state
132  sdl-joystick-update
133  sdl-num-joysticks
134  sdl-joystick-name
135  sdl-joystick-open
136  sdl-joystick-opened
137  sdl-joystick-index
138  sdl-joystick-num-axes
139  sdl-joystick-num-balls
140  sdl-joystick-num-hats
141  sdl-joystick-num-buttons
142  sdl-joystick-update
143  sdl-joystick-get-axis
144  sdl-joystick-get-hat
145  sdl-joystick-get-button
146  sdl-joystick-close
147  sdl-gl-swap-buffers
148  sdl-gl-set-attribute
149  sdl-gl-get-attribute
150
151  ; SDL ttf
152  ttf-init
153  ttf-was-init
154  ttf-quit
155  ttf-compiled-version
156  ttf-linked-version
157  ttf-font?
158  ttf-font-pointer
159  ttf-open-font
160  ttf-open-font-index
161  ttf-close-font
162  ttf-get-font-style
163  ttf-set-font-style
164  ttf-font-height
165  ttf-font-ascent
166  ttf-font-descent
167  ttf-font-line-skip
168  ttf-font-faces
169  ttf-font-face-is-fixed-width?
170  ttf-font-face-family-name
171  ttf-font-face-style-name
172  ttf-size-text!
173  ttf-size-utf8!
174  ttf-render-text-solid
175  ttf-render-utf8-solid
176  ttf-render-glyph-solid
177  ttf-render-text-shaded
178  ttf-render-utf8-shaded
179  ttf-render-glyph-shaded
180  ttf-render-text-blended
181  ttf-render-utf8-blended
182  ttf-render-glyph-blended
183
184  ; SDL image
185  img-init
186  img-quit
187  img-load
188  rotozoom-surface
189  zoom-surface
190
191  ;SDL net
192  make-sdl-ip-address
193  sdl-ip-address?
194  sdl-ip-address-a
195  sdl-ip-address-b
196  sdl-ip-address-c
197  sdl-ip-address-d
198  sdl-ip-address-port
199  sdl-net-init
200  sdl-net-quit
201  sdl-net-resolve-host!
202  sdl-net-resolve-ip
203  sdl-net-resolve-host
204  make-sdl-tcp-socket
205  sdl-tcp-socket?
206  sdl-net-tcp-open
207  sdl-net-tcp-accept
208  sdl-net-tcp-get-peer-address
209  sdl-net-tcp-send
210  sdl-net-tcp-recv
211  sdl-net-tcp-close
212  sdl-net-tcp-send-string
213  sdl-net-tcp-recv-string
214  sdl-net-tcp-add-socket!
215  sdl-net-tcp-del-socket!
216  sdl-net-check-sockets
217  sdl-net-socket-ready?
218  sdl-net-socket-set?
219  sdl-net-socket-set-pointer-set!
220  sdl-net-write-16
221  sdl-net-write-32
222  sdl-net-read-16
223  sdl-net-read-32
224
225  sdl-event?
226  sdl-event-gain
227  set-sdl-event-gain!
228  sdl-event-which
229  set-sdl-event-which!
230  sdl-event-state
231  set-sdl-event-state!
232  sdl-event-scancode
233  set-sdl-event-scancode!
234  sdl-event-sym
235  set-sdl-event-sym!
236  sdl-event-mod
237  set-sdl-event-mod!
238  sdl-event-unicode
239  set-sdl-event-unicode!
240  sdl-event-x
241  set-sdl-event-x!
242  sdl-event-y
243  set-sdl-event-y!
244  sdl-event-xrel
245  set-sdl-event-xrel!
246  sdl-event-yrel
247  set-sdl-event-yrel!
248  sdl-event-axis
249  set-sdl-event-axis!
250  sdl-event-ball
251  set-sdl-event-ball!
252  sdl-event-hat
253  set-sdl-event-hat!
254  sdl-event-value
255  set-sdl-event-value!
256  sdl-event-button
257  set-sdl-event-button!
258  sdl-event-w
259  set-sdl-event-w!
260  sdl-event-h
261  set-sdl-event-h!
262  sdl-event-buffer-set!
263  heap?
264 
265
266  ; constants
267
268  SDL_INIT_TIMER
269  SDL_INIT_AUDIO
270  SDL_INIT_VIDEO
271  SDL_INIT_CDROM
272  SDL_INIT_JOYSTICK
273  SDL_INIT_EVERYTHING
274  SDL_INIT_NOPARACHUTE
275
276  ;; For sdl-creatergbsurface or sdl-setvideomode
277  SDL_SWSURFACE
278  SDL_HWSURFACE
279  SDL_ASYNCBLIT
280  ;; For sdl-setvideomode
281  SDL_ANYFORMAT
282  SDL_HWPALETTE
283  SDL_DOUBLEBUF
284  SDL_FULLSCREEN
285  SDL_OPENGL
286  SDL_OPENGLBLIT
287  SDL_RESIZABLE
288  SDL_NOFRAME
289  ;; Read-only - internal
290  SDL_HWACCEL
291  SDL_SRCCOLORKEY
292  SDL_RLEACCELOK
293  SDL_RLEACCEL
294  SDL_SRCALPHA
295  SDL_PREALLOC
296
297  SDL_BYTEORDER
298  SDL_LIL_ENDIAN
299  SDL_BIG_ENDIAN
300
301  ;; For sdl-wm-grabinput
302  SDL_GRAB_QUERY
303  SDL_GRAB_OFF
304  SDL_GRAB_ON
305
306
307  SDL_NOEVENT                   ; Unused (do not remove)
308  SDL_ACTIVEEVENT               ; Application loses/gains visibility
309  SDL_APPMOUSEFOCUS             ; Mouse focus gained/lost
310  SDL_APPINPUTFOCUS             ; Input focus gained/lost
311  SDL_APPACTIVE                 ; Application iconified/restored
312  SDL_KEYDOWN                   ; Keys pressed
313  SDL_KEYUP                     ; Keys released
314  SDL_MOUSEMOTION               ; Mouse moved
315  SDL_MOUSEBUTTONDOWN           ; Mouse button pressed
316  SDL_MOUSEBUTTONUP             ; Mouse button released
317  SDL_JOYAXISMOTION             ; Joystick axis motion
318  SDL_JOYBALLMOTION             ; Joystick trackball motion
319  SDL_JOYHATMOTION              ; Joystick hat position change
320  SDL_JOYBUTTONDOWN             ; Joystick button pressed
321  SDL_JOYBUTTONUP               ; Joystick button released
322  SDL_QUIT                      ; User-requested quit
323  SDL_SYSWMEVENT                ; System specific event
324  SDL_EVENT_RESERVEDA           ; Reserved for future use..
325  SDL_EVENT_RESERVEDB           ; Reserved for future use..
326  SDL_VIDEORESIZE               ; User resized video mode
327  SDL_VIDEOEXPOSE               ; Screen needs to be redrawn
328  SDL_EVENT_RESERVED2           ; Reserved for future use..
329  SDL_EVENT_RESERVED3           ; Reserved for future use..
330  SDL_EVENT_RESERVED4           ; Reserved for future use..
331  SDL_EVENT_RESERVED5           ; Reserved for future use..
332  SDL_EVENT_RESERVED6           ; Reserved for future use..
333  SDL_EVENT_RESERVED7           ; Reserved for future use..
334  SDL_USEREVENT                 ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
335  SDL_NUMEVENTS
336
337  SDL_ACTIVEEVENTMASK
338  SDL_KEYDOWNMASK
339  SDL_KEYUPMASK
340  SDL_MOUSEMOTIONMASK
341  SDL_MOUSEBUTTONDOWNMASK
342  SDL_MOUSEBUTTONUPMASK
343  SDL_MOUSEEVENTMASK
344  SDL_JOYAXISMOTIONMASK
345  SDL_JOYBALLMOTIONMASK
346  SDL_JOYHATMOTIONMASK
347  SDL_JOYBUTTONDOWNMASK
348  SDL_JOYBUTTONUPMASK
349  SDL_JOYEVENTMASK
350  SDL_VIDEORESIZEMASK
351  SDL_VIDEOEXPOSEMASK
352  SDL_QUITMASK
353  SDL_SYSWMEVENTMASK
354  SDL_ALLEVENTS
355                                        ; General button/key states
356  SDL_PRESSED
357  SDL_RELEASED
358                                        ; Mouse button states
359  SDL_BUTTON_LEFT
360  SDL_BUTTON_MIDDLE
361  SDL_BUTTON_RIGHT
362  SDL_BUTTON_WHEELUP
363  SDL_BUTTON_WHEELDOWN
364  SDL_BUTTON_LMASK ; = SDL_BUTTON(SDL_BUTTON_LEFT)
365  SDL_BUTTON_MMASK ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
366  SDL_BUTTON_RMASK ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
367  SDL_QUERY
368  SDL_IGNORE
369  SDL_DISABLE
370  SDL_ENABLE
371
372  SDL_GL_RED_SIZE
373  SDL_GL_GREEN_SIZE
374  SDL_GL_BLUE_SIZE
375  SDL_GL_ALPHA_SIZE
376  SDL_GL_BUFFER_SIZE
377  SDL_GL_DOUBLEBUFFER
378  SDL_GL_DEPTH_SIZE
379  SDL_GL_STENCIL_SIZE
380  SDL_GL_ACCUM_RED_SIZE
381  SDL_GL_ACCUM_GREEN_SIZE
382  SDL_GL_ACCUM_BLUE_SIZE
383  SDL_GL_ACCUM_ALPHA_SIZE
384  SDL_GL_STEREO
385  SDL_GL_MULTISAMPLEBUFFERS
386  SDL_GL_MULTISAMPLESAMPLES
387  SDL_GL_SWAP_CONTROL
388  SDL_GL_ACCELERATED_VISUAL
389
390  TTF_STYLE_NORMAL
391  TTF_STYLE_BOLD
392  TTF_STYLE_ITALIC
393  TTF_STYLE_UNDERLINE
394
395  ;; SDL_image
396  IMG_INIT_JPG
397  IMG_INIT_PNG
398  IMG_INIT_TIF
399
400  ;; scancodes
401
402  SDLK_UNKNOWN
403  SDLK_FIRST
404  SDLK_BACKSPACE
405  SDLK_TAB
406  SDLK_CLEAR
407  SDLK_RETURN
408  SDLK_PAUSE
409  SDLK_ESCAPE
410  SDLK_SPACE
411  SDLK_EXCLAIM
412  SDLK_QUOTEDBL
413  SDLK_HASH
414  SDLK_DOLLAR
415  SDLK_AMPERSAND
416  SDLK_QUOTE
417  SDLK_LEFTPAREN
418  SDLK_RIGHTPAREN
419  SDLK_ASTERISK
420  SDLK_PLUS
421  SDLK_COMMA
422  SDLK_MINUS
423  SDLK_PERIOD
424  SDLK_SLASH
425  SDLK_0
426  SDLK_1
427  SDLK_2
428  SDLK_3
429  SDLK_4
430  SDLK_5
431  SDLK_6
432  SDLK_7
433  SDLK_8
434  SDLK_9
435  SDLK_COLON
436  SDLK_SEMICOLON
437  SDLK_LESS
438  SDLK_EQUALS
439  SDLK_GREATER
440  SDLK_QUESTION
441  SDLK_AT
442  SDLK_LEFTBRACKET
443  SDLK_BACKSLASH
444  SDLK_RIGHTBRACKET
445  SDLK_CARET
446  SDLK_UNDERSCORE
447  SDLK_BACKQUOTE
448  SDLK_a
449  SDLK_b
450  SDLK_c
451  SDLK_d
452  SDLK_e
453  SDLK_f
454  SDLK_g
455  SDLK_h
456  SDLK_i
457  SDLK_j
458  SDLK_k
459  SDLK_l
460  SDLK_m
461  SDLK_n
462  SDLK_o
463  SDLK_p
464  SDLK_q
465  SDLK_r
466  SDLK_s
467  SDLK_t
468  SDLK_u
469  SDLK_v
470  SDLK_w
471  SDLK_x
472  SDLK_y
473  SDLK_z
474  SDLK_DELETE
475  SDLK_WORLD_0
476  SDLK_WORLD_1
477  SDLK_WORLD_2
478  SDLK_WORLD_3
479  SDLK_WORLD_4
480  SDLK_WORLD_5
481  SDLK_WORLD_6
482  SDLK_WORLD_7
483  SDLK_WORLD_8
484  SDLK_WORLD_9
485  SDLK_WORLD_10
486  SDLK_WORLD_11
487  SDLK_WORLD_12
488  SDLK_WORLD_13
489  SDLK_WORLD_14
490  SDLK_WORLD_15
491  SDLK_WORLD_16
492  SDLK_WORLD_17
493  SDLK_WORLD_18
494  SDLK_WORLD_19
495  SDLK_WORLD_20
496  SDLK_WORLD_21
497  SDLK_WORLD_22
498  SDLK_WORLD_23
499  SDLK_WORLD_24
500  SDLK_WORLD_25
501  SDLK_WORLD_26
502  SDLK_WORLD_27
503  SDLK_WORLD_28
504  SDLK_WORLD_29
505  SDLK_WORLD_30
506  SDLK_WORLD_31
507  SDLK_WORLD_32
508  SDLK_WORLD_33
509  SDLK_WORLD_34
510  SDLK_WORLD_35
511  SDLK_WORLD_36
512  SDLK_WORLD_37
513  SDLK_WORLD_38
514  SDLK_WORLD_39
515  SDLK_WORLD_40
516  SDLK_WORLD_41
517  SDLK_WORLD_42
518  SDLK_WORLD_43
519  SDLK_WORLD_44
520  SDLK_WORLD_45
521  SDLK_WORLD_46
522  SDLK_WORLD_47
523  SDLK_WORLD_48
524  SDLK_WORLD_49
525  SDLK_WORLD_50
526  SDLK_WORLD_51
527  SDLK_WORLD_52
528  SDLK_WORLD_53
529  SDLK_WORLD_54
530  SDLK_WORLD_55
531  SDLK_WORLD_56
532  SDLK_WORLD_57
533  SDLK_WORLD_58
534  SDLK_WORLD_59
535  SDLK_WORLD_60
536  SDLK_WORLD_61
537  SDLK_WORLD_62
538  SDLK_WORLD_63
539  SDLK_WORLD_64
540  SDLK_WORLD_65
541  SDLK_WORLD_66
542  SDLK_WORLD_67
543  SDLK_WORLD_68
544  SDLK_WORLD_69
545  SDLK_WORLD_70
546  SDLK_WORLD_71
547  SDLK_WORLD_72
548  SDLK_WORLD_73
549  SDLK_WORLD_74
550  SDLK_WORLD_75
551  SDLK_WORLD_76
552  SDLK_WORLD_77
553  SDLK_WORLD_78
554  SDLK_WORLD_79
555  SDLK_WORLD_80
556  SDLK_WORLD_81
557  SDLK_WORLD_82
558  SDLK_WORLD_83
559  SDLK_WORLD_84
560  SDLK_WORLD_85
561  SDLK_WORLD_86
562  SDLK_WORLD_87
563  SDLK_WORLD_88
564  SDLK_WORLD_89
565  SDLK_WORLD_90
566  SDLK_WORLD_91
567  SDLK_WORLD_92
568  SDLK_WORLD_93
569  SDLK_WORLD_94
570  SDLK_WORLD_95
571  SDLK_KP0
572  SDLK_KP1
573  SDLK_KP2
574  SDLK_KP3
575  SDLK_KP4
576  SDLK_KP5
577  SDLK_KP6
578  SDLK_KP7
579  SDLK_KP8
580  SDLK_KP9
581  SDLK_KP_PERIOD
582  SDLK_KP_DIVIDE
583  SDLK_KP_MULTIPLY
584  SDLK_KP_MINUS
585  SDLK_KP_PLUS
586  SDLK_KP_ENTER
587  SDLK_KP_EQUALS
588  SDLK_UP
589  SDLK_DOWN
590  SDLK_RIGHT
591  SDLK_LEFT
592  SDLK_INSERT
593  SDLK_HOME
594  SDLK_END
595  SDLK_PAGEUP
596  SDLK_PAGEDOWN
597  SDLK_F1
598  SDLK_F2
599  SDLK_F3
600  SDLK_F4
601  SDLK_F5
602  SDLK_F6
603  SDLK_F7
604  SDLK_F8
605  SDLK_F9
606  SDLK_F10
607  SDLK_F11
608  SDLK_F12
609  SDLK_F13
610  SDLK_F14
611  SDLK_F15
612  SDLK_NUMLOCK
613  SDLK_CAPSLOCK
614  SDLK_SCROLLOCK
615  SDLK_RSHIFT
616  SDLK_LSHIFT
617  SDLK_RCTRL
618  SDLK_LCTRL
619  SDLK_RALT
620  SDLK_LALT
621  SDLK_RMETA
622  SDLK_LMETA
623  SDLK_LSUPER
624  SDLK_RSUPER
625  SDLK_MODE
626  SDLK_COMPOSE
627  SDLK_HELP
628  SDLK_PRINT
629  SDLK_SYSREQ
630  SDLK_BREAK
631  SDLK_MENU
632  SDLK_POWER
633  SDLK_EURO
634  SDLK_UNDO
635
636)
637
638;---------------------------------------------------------------------------
639
640(import chicken scheme foreign)
641(use srfi-1)
642(use srfi-4)
643(use srfi-13)
644(use srfi-18)
645(use lolevel)
646
647(foreign-declare #<<EOF
648
649#ifdef _WIN32
650# if _MSC_VER > 1300
651#  include <winsock2.h>
652#  include <ws2tcpip.h>
653# else
654#  include <winsock.h>
655# endif
656#else
657# include <netinet/in.h>
658#endif
659
660#include <sys/time.h>
661
662#include "SDL.h"
663#include "SDL_ttf.h"
664#include "SDL_image.h"
665#include "SDL_rotozoom.h"
666#include "SDL_keysym.h"
667#include "SDL_endian.h"
668
669#include <string.h>
670#include "SDL_net.h"
671
672EOF
673)
674
675(include "heap.scm")
676(include "timer.scm")
677
678;---------------------------------------------------------------------------
679
680;; The first two components are arbitrary - the main version of the library.
681;; The third is the date (YYMMDD, with leading zeros removed).
682;; The fourth is a counter just in case we release more than one version in
683;; one day.
684(define *sdl-egg-version* '(0 5 91025 0))
685
686;---------------------------------------------------------------------------
687
688(define-syntax --sdl-flags
689  (lambda (e r c)
690      `(,(r 'begin)
691     ,@(append-map (lambda (str)
692                     (let* ((sym (string->symbol str))
693                            (psym (string->symbol (string-append "-" str))))
694                       `((,(r 'define-foreign-variable) ,psym unsigned-integer ,str)
695                         (,(r 'define) ,sym ,psym))))
696                   (cdr e)))))
697
698(define-syntax pointer-to-record-lambda
699  (ir-macro-transformer
700   (lambda (e i c)
701     (let ((record-name (cadr e)))
702       `(lambda (pointer)
703          (and pointer
704               (,(i (string->symbol
705                     (string-append "make-"(symbol->string (i record-name))))) pointer)))))))
706
707(include "keysym.scm")
708
709; Subsystem definitions, for sdl-init etc.
710(--sdl-flags "SDL_INIT_TIMER"
711             "SDL_INIT_AUDIO"
712             "SDL_INIT_VIDEO"
713             "SDL_INIT_CDROM"
714             "SDL_INIT_JOYSTICK"
715             "SDL_INIT_EVERYTHING"
716             "SDL_INIT_NOPARACHUTE")
717
718(--sdl-flags
719        ;; For sdl-creatergbsurface or sdl-setvideomode
720        "SDL_SWSURFACE"
721        "SDL_HWSURFACE"
722        "SDL_ASYNCBLIT"
723        ;; For sdl-setvideomode
724        "SDL_ANYFORMAT"
725        "SDL_HWPALETTE"
726        "SDL_DOUBLEBUF"
727        "SDL_FULLSCREEN"
728        "SDL_OPENGL"
729        "SDL_OPENGLBLIT"
730        "SDL_RESIZABLE"
731        "SDL_NOFRAME"
732        ;; Read-only - internal
733        "SDL_HWACCEL"
734        "SDL_SRCCOLORKEY"
735        "SDL_RLEACCELOK"
736        "SDL_RLEACCEL"
737        "SDL_SRCALPHA"
738        "SDL_PREALLOC"
739)
740
741(--sdl-flags
742 "SDL_BYTEORDER"
743 "SDL_LIL_ENDIAN"
744 "SDL_BIG_ENDIAN")
745
746; For sdl-wm-grabinput
747(--sdl-flags "SDL_GRAB_QUERY"
748             "SDL_GRAB_OFF"
749             "SDL_GRAB_ON")
750
751(--sdl-flags
752        "SDL_NOEVENT"                   ; Unused (do not remove)
753        "SDL_ACTIVEEVENT"               ; Application loses/gains visibility
754        "SDL_APPMOUSEFOCUS"             ; Mouse focus gained/lost
755        "SDL_APPINPUTFOCUS"             ; Input focus gained/lost
756        "SDL_APPACTIVE"                 ; Application iconified/restored
757        "SDL_KEYDOWN"                   ; Keys pressed
758        "SDL_KEYUP"                     ; Keys released
759        "SDL_MOUSEMOTION"               ; Mouse moved
760        "SDL_MOUSEBUTTONDOWN"           ; Mouse button pressed
761        "SDL_MOUSEBUTTONUP"             ; Mouse button released
762        "SDL_JOYAXISMOTION"             ; Joystick axis motion
763        "SDL_JOYBALLMOTION"             ; Joystick trackball motion
764        "SDL_JOYHATMOTION"              ; Joystick hat position change
765        "SDL_JOYBUTTONDOWN"             ; Joystick button pressed
766        "SDL_JOYBUTTONUP"               ; Joystick button released
767        "SDL_QUIT"                      ; User-requested quit
768        "SDL_SYSWMEVENT"                ; System specific event
769        "SDL_EVENT_RESERVEDA"           ; Reserved for future use..
770        "SDL_EVENT_RESERVEDB"           ; Reserved for future use..
771        "SDL_VIDEORESIZE"               ; User resized video mode
772        "SDL_VIDEOEXPOSE"               ; Screen needs to be redrawn
773        "SDL_EVENT_RESERVED2"           ; Reserved for future use..
774        "SDL_EVENT_RESERVED3"           ; Reserved for future use..
775        "SDL_EVENT_RESERVED4"           ; Reserved for future use..
776        "SDL_EVENT_RESERVED5"           ; Reserved for future use..
777        "SDL_EVENT_RESERVED6"           ; Reserved for future use..
778        "SDL_EVENT_RESERVED7"           ; Reserved for future use..
779        "SDL_USEREVENT"                 ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
780        "SDL_NUMEVENTS"
781)
782
783(--sdl-flags
784        "SDL_ACTIVEEVENTMASK"
785        "SDL_KEYDOWNMASK"
786        "SDL_KEYUPMASK"
787        "SDL_MOUSEMOTIONMASK"
788        "SDL_MOUSEBUTTONDOWNMASK"
789        "SDL_MOUSEBUTTONUPMASK"
790        "SDL_MOUSEEVENTMASK"
791        "SDL_JOYAXISMOTIONMASK"
792        "SDL_JOYBALLMOTIONMASK"
793        "SDL_JOYHATMOTIONMASK"
794        "SDL_JOYBUTTONDOWNMASK"
795        "SDL_JOYBUTTONUPMASK"
796        "SDL_JOYEVENTMASK"
797        "SDL_VIDEORESIZEMASK"
798        "SDL_VIDEOEXPOSEMASK"
799        "SDL_QUITMASK"
800        "SDL_SYSWMEVENTMASK"
801        "SDL_ALLEVENTS"
802)
803
804; General button/key states
805(--sdl-flags
806 "SDL_PRESSED"
807 "SDL_RELEASED")
808
809;; SDL_image constants
810(--sdl-flags
811 "IMG_INIT_JPG"
812 "IMG_INIT_PNG"
813 "IMG_INIT_TIF")
814
815; Mouse button states
816
817; The macro SDL_BUTTON is parameterised, so we have to recreate it as
818; a function
819
820(define (SDL_BUTTON x)
821  (arithmetic-shift SDL_PRESSED (- x 1)))
822
823(--sdl-flags
824        "SDL_BUTTON_LEFT"
825        "SDL_BUTTON_MIDDLE"
826        "SDL_BUTTON_RIGHT"
827        "SDL_BUTTON_WHEELUP"
828        "SDL_BUTTON_WHEELDOWN"
829        "SDL_BUTTON_LMASK" ; = SDL_BUTTON(SDL_BUTTON_LEFT)
830        "SDL_BUTTON_MMASK" ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
831        "SDL_BUTTON_RMASK" ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
832)
833
834; For sdl-eventstate
835(--sdl-flags "SDL_QUERY"
836             "SDL_IGNORE"
837             "SDL_DISABLE"
838             "SDL_ENABLE")
839
840;---------------------------------------------------------------------------
841
842(define-record sdl-version pointer)
843
844(define-record-printer (sdl-version o out)
845  (for-each (lambda (x) (display x out))
846            (list "#<sdl-version "
847                  (sdl-version-major o) " "
848                  (sdl-version-minor o) " "
849                  (sdl-version-patch o) 
850                  ">")))
851
852(define-foreign-type SDL_version (c-pointer "SDL_version")
853  sdl-version-pointer
854  (pointer-to-record-lambda sdl-version))
855
856(define sdl-version-major
857  (foreign-lambda* unsigned-byte ((SDL_version v))
858                   "C_return(v->major);"))
859
860(define sdl-version-minor
861  (foreign-lambda* unsigned-byte ((SDL_version v))
862                   "C_return(v->minor);"))
863
864(define sdl-version-patch
865  (foreign-lambda* unsigned-byte ((SDL_version v))
866                   "C_return(v->patch);"))
867
868;; Returns #t if the first argument is at least what the rest of the
869;; arguments indicate.
870(define (sdl-version-at-least sdl-version major minor patch)
871  (cond
872   ((> (sdl-version-major sdl-version) major) #t)
873   ((< (sdl-version-major sdl-version) major) #f)
874   ((> (sdl-version-minor sdl-version) minor) #t)
875   ((< (sdl-version-minor sdl-version) minor) #f)
876   ((>= (sdl-version-patch sdl-version) patch) #t)
877   (#t #f)))
878
879(define sdl-compiled-version
880  (foreign-lambda* SDL_version ()
881                   "SDL_version v; SDL_VERSION(&v); C_return(&v);"))
882
883(define sdl-linked-version
884  (foreign-lambda SDL_version "SDL_Linked_Version"))
885
886;---------------------------------------------------------------------------
887
888(define-foreign-variable sizeof-sdl-rect int "sizeof(SDL_Rect)")
889
890(define-record sdl-rect buffer)
891
892(let ((maker make-sdl-rect))
893  (set! make-sdl-rect
894        (lambda (x y w h)
895          (let ((r (maker (make-blob sizeof-sdl-rect))))
896            (sdl-rect-x-set! r x)
897            (sdl-rect-y-set! r y)
898            (sdl-rect-w-set! r w)
899            (sdl-rect-h-set! r h)
900            r))))
901
902(define-record-printer (sdl-rect s out)
903  (for-each (lambda (x) (display x out))
904            (list "#<sdl-rect "
905                  (sdl-rect-x s)" "
906                  (sdl-rect-y s)" "
907                  (sdl-rect-w s)" "
908                  (sdl-rect-h s)">")))
909
910(define (-sdl-unbox-rect e)
911  (let ((p (##sys#make-pointer)))
912    (if e (##core#inline "C_pointer_to_block" p (sdl-rect-buffer e)))
913    p))
914
915(define-foreign-type SDL_Rect (c-pointer "SDL_Rect")
916  -sdl-unbox-rect)
917
918(define sdl-rect-x (foreign-lambda* short ((SDL_Rect c)) "C_return(c->x);"))
919(define sdl-rect-y (foreign-lambda* short ((SDL_Rect c)) "C_return(c->y);"))
920(define sdl-rect-w (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->w);"))
921(define sdl-rect-h (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->h);"))
922
923(define sdl-rect-x-set! (foreign-lambda* void ((SDL_Rect c) (short x)) "c->x = x;"))
924(define sdl-rect-y-set! (foreign-lambda* void ((SDL_Rect c) (short y)) "c->y = y;"))
925(define sdl-rect-w-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short w)) "c->w = w;"))
926(define sdl-rect-h-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short h)) "c->h = h;"))
927
928;---------------------------------------------------------------------------
929
930(define-record sdl-pixel-format pointer)
931
932(define-record-printer (sdl-pixel-format p out)
933  (for-each (lambda (x) (display x out))
934            (list "#<sdl-pixel-format "(sdl-pixel-format-pointer p)">")))
935
936(define-foreign-type SDL_PixelFormat (c-pointer "SDL_PixelFormat")
937  sdl-pixel-format-pointer
938  (pointer-to-record-lambda sdl-pixel-format))
939
940(define sdl-pixel-format-bytes-per-pixel
941  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
942                   "C_return(pf->BytesPerPixel);"))
943
944(define sdl-pixel-format-rmask
945  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
946                   "C_return(pf->Rmask);"))
947(define sdl-pixel-format-gmask
948  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
949                   "C_return(pf->Gmask);"))
950(define sdl-pixel-format-bmask
951  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
952                   "C_return(pf->Bmask);"))
953(define sdl-pixel-format-amask
954  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
955                   "C_return(pf->Amask);"))
956
957;---------------------------------------------------------------------------
958
959(define-record sdl-surface pointer)
960
961(define-record-printer (sdl-surface s out)
962  (for-each (lambda (x) (display x out))
963            (list "#<sdl-surface "(sdl-surface-pointer s)">")))
964
965(define-foreign-type SDL_Surface (c-pointer "SDL_Surface")
966  sdl-surface-pointer
967  (lambda (p) (set-finalizer!
968               ((pointer-to-record-lambda sdl-surface) p)
969               sdl-free-surface)))
970
971(define (sdl-surface-flags s)
972  ((foreign-lambda* unsigned-integer ((SDL_Surface s))
973                    "C_return(s->flags);") s))
974
975(define (sdl-surface-pixel-format s)
976  ((foreign-lambda* SDL_PixelFormat ((SDL_Surface s))
977                    "C_return(s->format);") s))
978
979(define (sdl-surface-width s)
980  ((foreign-lambda* integer ((SDL_Surface s))
981                    "C_return(s->w);") s))
982
983(define (sdl-surface-height s)
984  ((foreign-lambda* integer ((SDL_Surface s))
985                    "C_return(s->h);") s))
986
987(define (sdl-surface-pitch s)
988  ((foreign-lambda* unsigned-short ((SDL_Surface s))
989                    "C_return(s->pitch);") s))
990
991(define (sdl-surface-pixels s)
992  ((foreign-lambda* (c-pointer byte) ((SDL_Surface s))
993                    "C_return(s->pixels);") s))
994
995;; Computes the number of bytes of storage pointed to by
996;; sdl-surface-pixels.
997(define (sdl-surface-pixels-length s)
998  (* (sdl-surface-height s)
999     (sdl-surface-pitch s)))
1000
1001;;
1002;; SDL_VideoInfo
1003;;
1004
1005(define-record sdl-video-info pointer)
1006
1007(define-record-printer (sdl-video-info o out)
1008  (for-each (lambda (x) (display x out))
1009            (list "#<sdl-video-info "
1010                  (sdl-video-info-hw-available o) " "
1011                  (sdl-video-info-wm-available o) " "
1012                  (sdl-video-info-blit-hw o) " "
1013                  (sdl-video-info-blit-hw-cc o) " "
1014                  (sdl-video-info-blit-hw-a o) " "
1015                  (sdl-video-info-blit-sw o) " "
1016                  (sdl-video-info-blit-sw-cc o) " "
1017                  (sdl-video-info-blit-sw-a o) " "
1018                  (sdl-video-info-blit-fill o) " "
1019                  (sdl-video-info-video-mem o) " "
1020                  (sdl-video-info-vfmt o) " "
1021                  (sdl-video-info-current-w o) " "
1022                  (sdl-video-info-current-h o)
1023                  ">")))
1024
1025(define-foreign-type SDL_VideoInfo (c-pointer "SDL_VideoInfo")
1026  sdl-video-info-pointer
1027  (pointer-to-record-lambda sdl-video-info))
1028
1029(define sdl-video-info-hw-available
1030  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1031                   "C_return(vi->hw_available);"))
1032(define sdl-video-info-wm-available
1033  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1034                   "C_return(vi->wm_available);"))
1035(define sdl-video-info-blit-hw
1036  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1037                   "C_return(vi->blit_hw);"))
1038(define sdl-video-info-blit-hw-cc
1039  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1040                   "C_return(vi->blit_hw_CC);"))
1041(define sdl-video-info-blit-hw-a
1042  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1043                   "C_return(vi->blit_hw_A);"))
1044(define sdl-video-info-blit-sw
1045  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1046                   "C_return(vi->blit_sw);"))
1047(define sdl-video-info-blit-sw-cc
1048  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1049                   "C_return(vi->blit_sw_CC);"))
1050(define sdl-video-info-blit-sw-a
1051  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1052                   "C_return(vi->blit_sw_A);"))
1053(define sdl-video-info-blit-fill
1054  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1055                   "C_return(vi->blit_fill);"))
1056(define sdl-video-info-video-mem
1057  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1058                   "C_return(vi->video_mem);"))
1059(define sdl-video-info-vfmt
1060  (foreign-lambda* SDL_PixelFormat ((SDL_VideoInfo vi))
1061                   "C_return(vi->vfmt);"))
1062(define sdl-video-info-current-w
1063  (foreign-lambda* integer ((SDL_VideoInfo vi))
1064                   "C_return(vi->current_w);"))
1065(define sdl-video-info-current-h
1066  (foreign-lambda* integer ((SDL_VideoInfo vi))
1067                   "C_return(vi->current_h);"))
1068
1069(define sdl-get-video-info
1070  (foreign-lambda* SDL_VideoInfo ()
1071                   "C_return(SDL_GetVideoInfo());"))
1072
1073
1074;---------------------------------------------------------------------------
1075
1076;; Modifies its second argument.
1077(define sdl-get-clip-rect! (foreign-lambda void "SDL_GetClipRect" SDL_Surface SDL_Rect))
1078
1079;; Modifies its first argument.
1080(define sdl-set-clip-rect! (foreign-lambda bool "SDL_SetClipRect" SDL_Surface SDL_Rect))
1081
1082;; Modifies its first argument.
1083(define sdl-set-color-key!
1084  (foreign-lambda int "SDL_SetColorKey" SDL_Surface unsigned-integer unsigned-integer))
1085
1086;; Modifies its first argument.
1087(define sdl-set-alpha!
1088  (foreign-lambda int "SDL_SetAlpha" SDL_Surface unsigned-integer unsigned-byte))
1089
1090(define sdl-display-format
1091  (foreign-lambda SDL_Surface "SDL_DisplayFormat" SDL_Surface))
1092(define sdl-display-format-alpha
1093  (foreign-lambda SDL_Surface "SDL_DisplayFormatAlpha" SDL_Surface))
1094(define sdl-convert-surface
1095  (foreign-lambda SDL_Surface "SDL_ConvertSurface" SDL_Surface SDL_PixelFormat unsigned-integer))
1096
1097;---------------------------------------------------------------------------
1098
1099;; NOTE: sdl-init does not work on MacOS X when called from a
1100;; dynamically-loaded extension. Something internal to Quartz seems to
1101;; get confused. You must call SDL_Init *directly* from your main
1102;; program - if your main program is written in Scheme, you need to
1103;; say something like:
1104;;
1105;; (declare (foreign-declare "#include <SDL.h>\n"))
1106;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);")
1107;;
1108(define (sdl-init flags)
1109  (zero? ((foreign-lambda int "SDL_Init" unsigned-integer) flags)))
1110
1111;; Note: guile-sdl names these 'sdl-init-subsystem' and
1112;; 'sdl-quit-subsystem', respectively.
1113
1114(define (sdl-init-sub-system flags)
1115  (zero? ((foreign-lambda int "SDL_InitSubSystem" unsigned-integer) flags)))
1116
1117(define (sdl-quit-sub-system flags)
1118  ((foreign-lambda void "SDL_QuitSubSystem" unsigned-integer) flags))
1119
1120(define (sdl-quit)
1121  ((foreign-lambda void "SDL_Quit")))
1122
1123(define (sdl-was-init flags)
1124  ((foreign-lambda unsigned-integer "SDL_WasInit" unsigned-integer) flags))
1125
1126(define sdl-set-error! (foreign-lambda* void ((c-string str)) "SDL_SetError(\"%s\", str);"))
1127(define sdl-get-error (foreign-lambda c-string "SDL_GetError"))
1128(define sdl-clear-error! (foreign-lambda void "SDL_ClearError"))
1129
1130;---------------------------------------------------------------------------
1131
1132(define (sdl-wm-set-caption title icon)
1133  ((foreign-lambda void "SDL_WM_SetCaption" c-string c-string) title icon))
1134
1135(define (sdl-wm-get-caption-title)
1136  ((foreign-lambda* c-string ()
1137                    "char *t, *i;"
1138                    "SDL_WM_GetCaption(&t, &i);"
1139                    "C_return(t);")))
1140
1141(define (sdl-wm-get-caption-icon)
1142  ((foreign-lambda* c-string ()
1143                    "char *t, *i;"
1144                    "SDL_WM_GetCaption(&t, &i);"
1145                    "C_return(i);")))
1146
1147(define (sdl-wm-get-caption)
1148  (values (sdl-wm-get-caption-title)
1149          (sdl-wm-get-caption-icon)))
1150
1151(define (sdl-wm-set-icon icon mask)
1152  ((foreign-lambda void "SDL_WM_SetIcon" SDL_Surface blob) icon mask))
1153
1154(define (sdl-wm-iconify-window)
1155  (not (zero? ((foreign-lambda integer "SDL_WM_IconifyWindow")))))
1156
1157(define (sdl-wm-toggle-full-screen surf)
1158  (not (zero? ((foreign-lambda integer "SDL_WM_ToggleFullScreen" SDL_Surface) surf))))
1159
1160(define (sdl-wm-grab-input m)
1161  ((foreign-lambda integer "SDL_WM_GrabInput" integer) m))
1162
1163;---------------------------------------------------------------------------
1164
1165; Milliseconds.
1166(define sdl-get-ticks (foreign-lambda unsigned-integer "SDL_GetTicks"))
1167(define sdl-delay (foreign-lambda void "SDL_Delay" unsigned-integer))
1168
1169(cond-expand
1170 (mingw32
1171  (define get-time-of-day current-seconds))
1172 (else
1173  (define get-time-of-day
1174    (foreign-lambda* double ()
1175      "struct timeval tv;"
1176      "gettimeofday(&tv, NULL);"
1177      "C_return((double) tv.tv_sec + ((double) tv.tv_usec / 1000000.0));"))))
1178
1179(define-values (sdl-add-absolute-timer!
1180                sdl-process-timer-queue!)
1181  (make-timer-queue get-time-of-day))
1182
1183(define (sdl-add-relative-timer! time callback)
1184  (sdl-add-absolute-timer! (+ time (get-time-of-day)) callback))
1185
1186;---------------------------------------------------------------------------
1187
1188(define-foreign-variable sizeof-sdl-event int "sizeof(SDL_Event)")
1189
1190(define-record sdl-event buffer)
1191
1192(let ((maker make-sdl-event))
1193  (set! make-sdl-event
1194        (lambda ()
1195          (let ((bv (blob->u8vector (make-blob sizeof-sdl-event))))
1196            (u8vector-set! bv 0 SDL_NOEVENT)
1197            (maker (u8vector->blob bv))))))
1198
1199(define-record-printer (sdl-event s out)
1200  (for-each (lambda (x) (display x out))
1201            (list "#<sdl-event "(sdl-event-type s)">")))
1202
1203(define (-sdl-unbox-event e)
1204  (let ((p (##sys#make-pointer)))
1205    (##core#inline "C_pointer_to_block" p (sdl-event-buffer e))
1206    p))
1207
1208(define-foreign-type SDL_Event (c-pointer "SDL_Event")
1209  -sdl-unbox-event)
1210
1211(define sdl-event-type (foreign-lambda* unsigned-byte ((SDL_Event e)) "C_return(e->type);"))
1212(define sdl-event-type-set! (foreign-lambda* void ((SDL_Event e) (unsigned-byte t)) "e->type = t;"))
1213
1214(define-syntax --sdl-event-getter-setter
1215  (lambda (f r c)
1216    (let ((name (cadr f))
1217          (rest (cddr f)))
1218      (let* ((strapp (lambda s (apply string-append
1219                                  (map (lambda (x) (cond
1220                                                    ((symbol? x) (symbol->string x))
1221                                                    (else x)))
1222                                       s))))
1223         (symapp (lambda s (string->symbol (apply strapp s)))))
1224  `(,(r 'begin)
1225     (,(r 'define) (,(symapp "sdl-event-" name) e)
1226       (,(r 'let) ((,(r 't) (,(r 'sdl-event-type) e)))
1227         (,(r 'cond)
1228          ,@(map (lambda (clause)
1229                   (apply (lambda (etype mem1 kind)
1230                            `((,(r '=) ,(r 't) ,etype) ((,(r 'foreign-lambda*)
1231                                             ,kind ((SDL_Event e))
1232                                             ,(strapp "C_return(e->"mem1"."name");")) e)))
1233                          clause))
1234                 rest)
1235          (,(r 'else) (,(r 'error) ,(string-append "sdl-event-" (symbol->string name)
1236                                       ": cannot extract value from this type of event")
1237                       (,(r 'sdl-event-type) e))))))
1238     (,(r 'define) (,(symapp "set-sdl-event-" name "!") e v)
1239       (,(r 'let) ((t (,(r 'sdl-event-type) e)))
1240         (,(r 'cond)
1241          ,@(map (lambda (clause)
1242                   (apply (lambda (etype mem1 kind)
1243                            `((,(r '=) t ,etype) ((,(r 'foreign-lambda*)
1244                                             void ((SDL_Event e)
1245                                                   (,kind v))
1246                                             ,(strapp "e->"mem1"."name"=v;")) e v)))
1247                          clause))
1248                 rest)
1249          (,(r 'else) (,(r 'error) ,(string-append "set-sdl-event-" (symbol->string name) "!"
1250                                       ": cannot update value for this type of event")
1251                       (,(r 'sdl-event-type) e)))))))))))
1252
1253(--sdl-event-getter-setter gain         (SDL_ACTIVEEVENT active bool))
1254(--sdl-event-getter-setter which        (SDL_KEYDOWN key unsigned-byte)
1255                                        (SDL_KEYUP key unsigned-byte)
1256                                        (SDL_MOUSEMOTION motion unsigned-byte)
1257                                        (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1258                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1259                                        (SDL_JOYAXISMOTION jaxis unsigned-byte)
1260                                        (SDL_JOYBALLMOTION jball unsigned-byte)
1261                                        (SDL_JOYHATMOTION jhat unsigned-byte)
1262                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1263                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1264(--sdl-event-getter-setter state        (SDL_ACTIVEEVENT active unsigned-byte)
1265                                        (SDL_KEYDOWN key unsigned-byte)
1266                                        (SDL_KEYUP key unsigned-byte)
1267                                        (SDL_MOUSEMOTION motion unsigned-byte)
1268                                        (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1269                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1270                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1271                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1272(--sdl-event-getter-setter scancode     (SDL_KEYDOWN key.keysym unsigned-byte)
1273                                        (SDL_KEYUP   key.keysym unsigned-byte))
1274(--sdl-event-getter-setter sym          (SDL_KEYDOWN key.keysym integer)
1275                                        (SDL_KEYUP   key.keysym integer))
1276(--sdl-event-getter-setter mod          (SDL_KEYDOWN key.keysym integer)
1277                                        (SDL_KEYUP   key.keysym integer))
1278(--sdl-event-getter-setter unicode      (SDL_KEYDOWN key.keysym short)
1279                                        (SDL_KEYUP   key.keysym short))
1280(--sdl-event-getter-setter x            (SDL_MOUSEMOTION motion unsigned-short)
1281                                        (SDL_MOUSEBUTTONDOWN button unsigned-short)
1282                                        (SDL_MOUSEBUTTONUP button unsigned-short))
1283(--sdl-event-getter-setter y            (SDL_MOUSEMOTION motion unsigned-short)
1284                                        (SDL_MOUSEBUTTONDOWN button unsigned-short)
1285                                        (SDL_MOUSEBUTTONUP button unsigned-short))
1286(--sdl-event-getter-setter xrel         (SDL_MOUSEMOTION motion short)
1287                                        (SDL_JOYBALLMOTION jball short))
1288(--sdl-event-getter-setter yrel         (SDL_MOUSEMOTION motion short)
1289                                        (SDL_JOYBALLMOTION jball short))
1290(--sdl-event-getter-setter axis         (SDL_JOYAXISMOTION jaxis unsigned-byte))
1291(--sdl-event-getter-setter ball         (SDL_JOYBALLMOTION jball unsigned-byte))
1292(--sdl-event-getter-setter hat          (SDL_JOYHATMOTION jhat unsigned-byte))
1293(--sdl-event-getter-setter value        (SDL_JOYAXISMOTION jaxis short)
1294                                        (SDL_JOYHATMOTION jhat unsigned-byte))
1295(--sdl-event-getter-setter button       (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1296                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1297                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1298                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1299(--sdl-event-getter-setter w            (SDL_VIDEORESIZE resize integer))
1300(--sdl-event-getter-setter h            (SDL_VIDEORESIZE resize integer))
1301
1302(define sdl-pump-events (foreign-lambda void "SDL_PumpEvents"))
1303
1304(define (sdl-poll-event! . e)
1305  (if (null? e)
1306      (not (zero? ((foreign-lambda int "SDL_PollEvent" c-pointer) #f)))
1307      (not (zero? ((foreign-lambda int "SDL_PollEvent" SDL_Event) (car e))))))
1308
1309;; Now, (sdl-wait-event!) is implemented internally to SDL_event.c as:
1310;;
1311;;  while (1) {
1312;;    SDL_PumpEvents();
1313;;    switch(SDL_PeepEvents(event, 1, SDL_GETEVENT, SDL_ALLEVENTS)) {
1314;;      case -1: return 0;
1315;;      case 1: return 1;
1316;;      case 0: SDL_Delay(10);
1317;;    }
1318;;  }
1319;;
1320;; Since the SDL implementation of timers uses setitimer(2), and we
1321;; have trouble with setitimer and chicken - see the README - we
1322;; reimplement (sdl-wait-event!) here calling out to our timer queue
1323;; processing function.
1324
1325(define (sdl-wait-event!* delay-function . e)
1326  (let loop ()
1327    (sdl-pump-events)
1328    (let ((peep-result ((foreign-lambda*
1329                         int ((SDL_Event eptr))
1330                         "C_return(SDL_PeepEvents(eptr, 1, SDL_GETEVENT, SDL_ALLEVENTS));")
1331                        (if (null? e) #f (car e)))))
1332      (case peep-result
1333        ((-1) #f) ;; error.
1334        ((1) #t)  ;; present event.
1335        ((0)
1336         ;; No event, yet. Check our timer queue, wait, and retry.
1337         (let* ((delay-seconds (or (sdl-process-timer-queue!) 0.01))
1338                (sleep-time (min delay-seconds 0.01))
1339                (fix-sleep-time (inexact->exact (truncate (* 1000 sleep-time)))))
1340           (delay-function fix-sleep-time)
1341           (loop)))
1342        (else (error "sdl-wait-event!: unexpected result from SDL_PeepEvents" peep-result))))))
1343
1344(define (sdl-wait-event! . e)
1345  (apply sdl-wait-event!* sdl-delay e))
1346
1347;; Here's the implementation of (sdl-wait-event!) that calls the
1348;; SDL-provided routine:
1349;;
1350;; (define (sdl-wait-event! . e)
1351;;   (if (null? e)
1352;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" c-pointer) #f)))
1353;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" SDL_Event) (car e))))))
1354
1355(define (sdl-push-event e)
1356  (zero? ((foreign-lambda int "SDL_PushEvent" SDL_Event) e)))
1357
1358(define sdl-event-state! (foreign-lambda int "SDL_EventState" unsigned-int integer))
1359
1360; You can pass NULL for the args if you just want the button state
1361(define sdl-get-mouse-state (foreign-lambda int "SDL_GetMouseState" s32vector s32vector))
1362
1363(define sdl-warp-mouse (foreign-lambda void "SDL_WarpMouse" int int))
1364 
1365(define sdl-enable-unicode (foreign-lambda bool "SDL_EnableUNICODE" bool))
1366
1367;---------------------------------------------------------------------------
1368
1369(define sdl-get-video-surface (foreign-lambda SDL_Surface "SDL_GetVideoSurface"))
1370
1371(define (sdl-video-driver-name)
1372  (let ((bv (make-blob 128)))
1373    (and ((foreign-lambda bool "SDL_VideoDriverName" blob integer)
1374          bv
1375          (blob-size bv))
1376         (string-trim-right (blob->string bv)
1377                            (integer->char 0)))))
1378
1379(define sdl-set-video-mode (foreign-lambda SDL_Surface "SDL_SetVideoMode"
1380                                           integer ; width
1381                                           integer ; height
1382                                           integer ; bpp
1383                                           unsigned-integer ; flags
1384                                           ))
1385
1386(define (sdl-video-mode-ok w h bpp flags)
1387  (let ((result ((foreign-lambda integer "SDL_VideoModeOK"
1388                                 integer integer
1389                                 integer unsigned-integer)
1390                 w h bpp flags)))
1391    (and (not (zero? result))
1392         result)))
1393
1394(define (sdl-show-cursor . toggle)
1395  (if (null? toggle)
1396      ((foreign-lambda int "SDL_ShowCursor" int) -1)
1397      ((foreign-lambda int "SDL_ShowCursor" int) (if (car toggle) 1 0))))
1398
1399(define sdl-map-rgb (foreign-lambda unsigned-integer "SDL_MapRGB"
1400                                    SDL_PixelFormat
1401                                    unsigned-byte
1402                                    unsigned-byte
1403                                    unsigned-byte))
1404
1405(define sdl-map-rgba (foreign-lambda unsigned-integer "SDL_MapRGBA"
1406                                     SDL_PixelFormat
1407                                     unsigned-byte
1408                                     unsigned-byte
1409                                     unsigned-byte
1410                                     unsigned-byte))
1411
1412;---------------------------------------------------------------------------
1413
1414(define (sdl-fill-rect s r c)
1415  (if (sdl-color? c)
1416      ((foreign-lambda* int ((SDL_Surface s)
1417                             (SDL_Rect r)
1418                             (scheme-pointer cbuf))
1419                        "SDL_Color *c = (SDL_Color *) cbuf;"
1420                        "unsigned int c2 = SDL_MapRGB(s->format, c->r, c->g, c->b);"
1421                        "C_return(SDL_FillRect(s, r, c2));")
1422       s r (sdl-color-buffer c))
1423      ((foreign-lambda int "SDL_FillRect" SDL_Surface SDL_Rect unsigned-integer)
1424       s r c)))
1425
1426(define sdl-flip (foreign-lambda int "SDL_Flip" SDL_Surface))
1427
1428(define sdl-create-rgb-surface (foreign-lambda SDL_Surface "SDL_CreateRGBSurface"
1429                                               unsigned-integer ; flags
1430                                               integer ; width
1431                                               integer ; height
1432                                               integer ; depth
1433                                               unsigned-integer ; rmask
1434                                               unsigned-integer ; gmask
1435                                               unsigned-integer ; bmask
1436                                               unsigned-integer)) ; amask
1437(define sdl-free-surface (foreign-lambda void "SDL_FreeSurface" SDL_Surface))
1438
1439(define sdl-blit-surface (foreign-lambda integer "SDL_BlitSurface"
1440                                         SDL_Surface SDL_Rect ; src, srcrect
1441                                         SDL_Surface SDL_Rect)) ; dst, dstrect
1442
1443(define (sdl-with-clip-rect s r thunk)
1444  (let ((orig-clip-rect (make-sdl-rect 0 0 0 0)))
1445    (dynamic-wind
1446        (lambda ()
1447          (sdl-get-clip-rect! s orig-clip-rect)
1448          (sdl-set-clip-rect! s r))
1449        thunk
1450        (lambda ()
1451          (sdl-set-clip-rect! s orig-clip-rect)))))
1452
1453;---------------------------------------------------------------------------
1454
1455(define-foreign-variable sizeof-sdl-color int "sizeof(SDL_Color)")
1456
1457(define-record sdl-color buffer)
1458
1459(let ((maker make-sdl-color))
1460  (set! make-sdl-color
1461        (lambda (r g b)
1462          (let ((bv (make-blob sizeof-sdl-color)))
1463            (fill-sdl-color! (maker bv) r g b)))))
1464
1465(define-record-printer (sdl-color s out)
1466  (for-each (lambda (x) (display x out))
1467            (list "#<sdl-color "
1468                  (sdl-color-r s)" "
1469                  (sdl-color-g s)" "
1470                  (sdl-color-b s)">")))
1471
1472(define (-sdl-unbox-color e)
1473  (let ((p (##sys#make-pointer)))
1474    (##core#inline "C_pointer_to_block" p (sdl-color-buffer e))
1475    p))
1476
1477(define-foreign-type SDL_Color (c-pointer "SDL_Color")
1478  -sdl-unbox-color)
1479
1480(define (fill-sdl-color! c r g b)
1481  ((foreign-lambda* void ((SDL_Color c) (unsigned-byte r) (unsigned-byte g) (unsigned-byte b))
1482                    "c->r = r; c->g = g; c->b = b;")
1483   c r g b)
1484  c)
1485
1486(define sdl-color-r (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->r);"))
1487(define sdl-color-g (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->g);"))
1488(define sdl-color-b (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->b);"))
1489
1490;---------------------------------------------------------------------------
1491(define-record sdl-joystick pointer)
1492
1493(define-record-printer (sdl-joystick p out)
1494  (for-each (lambda (x) (display x out))
1495            (list "#<sdl-joystick "(sdl-joystick-pointer p)">")))
1496
1497(define-foreign-type SDL_Joystick (c-pointer "SDL_Joystick")
1498  sdl-joystick-pointer
1499  (pointer-to-record-lambda sdl-joystick))
1500
1501(define sdl-joystick-event-state (foreign-lambda int "SDL_JoystickEventState"
1502                                                 int))
1503(define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
1504(define sdl-num-joysticks (foreign-lambda int "SDL_NumJoysticks"))
1505(define sdl-joystick-name (foreign-lambda c-string "SDL_JoystickName" int))
1506(define sdl-joystick-open (foreign-lambda SDL_Joystick "SDL_JoystickOpen" int))
1507(define sdl-joystick-opened (foreign-lambda int "SDL_JoystickOpened" int))
1508(define sdl-joystick-index (foreign-lambda int "SDL_JoystickIndex"
1509                                           SDL_Joystick))
1510(define sdl-joystick-num-axes (foreign-lambda int "SDL_JoystickNumAxes"
1511                                              SDL_Joystick))
1512(define sdl-joystick-num-balls (foreign-lambda int "SDL_JoystickNumBalls"
1513                                               SDL_Joystick))
1514(define sdl-joystick-num-hats (foreign-lambda int "SDL_JoystickNumHats"
1515                                              SDL_Joystick))
1516(define sdl-joystick-num-buttons (foreign-lambda int "SDL_JoystickNumButtons"
1517                                                 SDL_Joystick))
1518(define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
1519(define sdl-joystick-get-axis (foreign-lambda short "SDL_JoystickGetAxis"
1520                                              SDL_Joystick int))
1521(define sdl-joystick-get-hat (foreign-lambda unsigned-char "SDL_JoystickGetHat"
1522                                             SDL_Joystick int))
1523(define sdl-joystick-get-button (foreign-lambda unsigned-char
1524                                                "SDL_JoystickGetButton"
1525                                                SDL_Joystick int))
1526;TODO: sdl-joystick-get-ball
1527(define sdl-joystick-close (foreign-lambda void "SDL_JoystickClose"
1528                                           SDL_Joystick))
1529
1530;---------------------------------------------------------------------------
1531;
1532; OpenGL stuff:
1533
1534(--sdl-flags "SDL_GL_RED_SIZE"
1535             "SDL_GL_GREEN_SIZE"
1536             "SDL_GL_BLUE_SIZE"
1537             "SDL_GL_ALPHA_SIZE"
1538             "SDL_GL_BUFFER_SIZE"
1539             "SDL_GL_DOUBLEBUFFER"
1540             "SDL_GL_DEPTH_SIZE"
1541             "SDL_GL_STENCIL_SIZE"
1542             "SDL_GL_ACCUM_RED_SIZE"
1543             "SDL_GL_ACCUM_GREEN_SIZE"
1544             "SDL_GL_ACCUM_BLUE_SIZE"
1545             "SDL_GL_ACCUM_ALPHA_SIZE"
1546             "SDL_GL_STEREO"
1547             "SDL_GL_MULTISAMPLEBUFFERS"
1548             "SDL_GL_MULTISAMPLESAMPLES"
1549             "SDL_GL_SWAP_CONTROL"
1550             "SDL_GL_ACCELERATED_VISUAL")
1551
1552(define sdl-gl-swap-buffers (foreign-lambda void "SDL_GL_SwapBuffers"))
1553(define sdl-gl-set-attribute (foreign-lambda int "SDL_GL_SetAttribute" unsigned-int int))
1554
1555(define sdl-gl-get-attribute
1556  (let ((get (foreign-lambda int "SDL_GL_GetAttribute" unsigned-int (c-pointer int))))
1557    (lambda (attr)
1558      (let-location ((ptr int))
1559        (let ((r (get attr (location ptr))))
1560          (and (zero? r) ptr))))))
1561
1562;---------------------------------------------------------------------------
1563
1564(define-record ttf-font pointer)
1565
1566(define-record-printer (ttf-font f out)
1567  (for-each (lambda (x) (display x out))
1568            (list "#<ttf-font "(ttf-font-pointer f)">")))
1569
1570(define-foreign-type TTF_Font (c-pointer "TTF_Font")
1571  ttf-font-pointer
1572  (lambda (p)
1573   (set-finalizer! ((pointer-to-record-lambda ttf-font) p)
1574                   ttf-close-font)))
1575
1576(define ttf-init (foreign-lambda integer "TTF_Init"))
1577(define ttf-was-init (foreign-lambda integer "TTF_WasInit"))
1578(define ttf-quit (foreign-lambda void "TTF_Quit"))
1579
1580(define ttf-compiled-version
1581  (foreign-lambda* SDL_version ()
1582                   "SDL_version v; SDL_TTF_VERSION(&v); C_return(&v);"))
1583(define ttf-linked-version
1584  (foreign-lambda SDL_version "TTF_Linked_Version"))
1585
1586(define ttf-open-font (foreign-lambda TTF_Font "TTF_OpenFont" c-string integer))
1587(define ttf-open-font-index (foreign-lambda TTF_Font "TTF_OpenFontIndex" c-string integer long))
1588(define (ttf-close-font f)
1589  (if (ttf-font-pointer f)
1590   (begin
1591     ((foreign-lambda void "TTF_CloseFont" TTF_Font) f)
1592     (ttf-font-pointer-set! f #f))))
1593
1594(--sdl-flags "TTF_STYLE_NORMAL"
1595             "TTF_STYLE_BOLD"
1596             "TTF_STYLE_ITALIC"
1597             "TTF_STYLE_UNDERLINE")
1598
1599(define ttf-get-font-style (foreign-lambda integer "TTF_GetFontStyle" TTF_Font))
1600(define ttf-set-font-style (foreign-lambda void "TTF_SetFontStyle" TTF_Font integer))
1601
1602(define ttf-font-height (foreign-lambda integer "TTF_FontHeight" TTF_Font))
1603(define ttf-font-ascent (foreign-lambda integer "TTF_FontAscent" TTF_Font))
1604(define ttf-font-descent (foreign-lambda integer "TTF_FontDescent" TTF_Font))
1605(define ttf-font-line-skip (foreign-lambda integer "TTF_FontLineSkip" TTF_Font))
1606(define ttf-font-faces (foreign-lambda long "TTF_FontFaces" TTF_Font))
1607
1608(define ttf-font-face-is-fixed-width? (foreign-lambda bool "TTF_FontFaceIsFixedWidth" TTF_Font))
1609(define ttf-font-face-family-name (foreign-lambda c-string "TTF_FontFaceFamilyName" TTF_Font))
1610(define ttf-font-face-style-name (foreign-lambda c-string "TTF_FontFaceStyleName" TTF_Font))
1611
1612(define ttf-size-text! (foreign-lambda* bool ((TTF_Font font)
1613                                              (c-string text)
1614                                              (SDL_Rect rect))
1615                                        "int ww, hh;"
1616                                        "int status = TTF_SizeText(font, text, &ww, &hh);"
1617                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
1618                                        "C_return((status == 0));"))
1619(define ttf-size-utf8! (foreign-lambda* bool ((TTF_Font font)
1620                                              (c-string text)
1621                                              (SDL_Rect rect))
1622                                        "int ww, hh;"
1623                                        "int status = TTF_SizeUTF8(font, text, &ww, &hh);"
1624                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
1625                                        "C_return((status == 0));"))
1626
1627(define ttf-render-text-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1628                                                            (c-string text)
1629                                                            (SDL_Color fg))
1630                                               "C_return(TTF_RenderText_Solid(font,text,*fg));"))
1631(define ttf-render-utf8-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1632                                                            (c-string text)
1633                                                            (SDL_Color fg))
1634                                               "C_return(TTF_RenderUTF8_Solid(font,text,*fg));"))
1635(define ttf-render-glyph-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1636                                                             (unsigned-int ch)
1637                                                             (SDL_Color fg))
1638                                                "C_return(TTF_RenderGlyph_Solid(font,ch,*fg));"))
1639
1640(define ttf-render-text-shaded
1641  (foreign-lambda* SDL_Surface ((TTF_Font font)
1642                                (c-string text)
1643                                (SDL_Color fg)
1644                                (SDL_Color bg))
1645                   "C_return(TTF_RenderText_Shaded(font,text,*fg,*bg));"))
1646(define ttf-render-utf8-shaded
1647  (foreign-lambda* SDL_Surface ((TTF_Font font)
1648                                (c-string text)
1649                                (SDL_Color fg)
1650                                (SDL_Color bg))
1651                   "C_return(TTF_RenderUTF8_Shaded(font,text,*fg,*bg));"))
1652(define ttf-render-glyph-shaded
1653  (foreign-lambda* SDL_Surface ((TTF_Font font)
1654                                (unsigned-int ch)
1655                                (SDL_Color fg)
1656                                (SDL_Color bg))
1657                   "C_return(TTF_RenderGlyph_Shaded(font,ch,*fg, *bg));"))
1658
1659(define ttf-render-text-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1660                                                              (c-string text)
1661                                                              (SDL_Color fg))
1662                                                 "C_return(TTF_RenderText_Blended(font,text,*fg));"))
1663(define ttf-render-utf8-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1664                                                              (c-string text)
1665                                                              (SDL_Color fg))
1666                                                 "C_return(TTF_RenderUTF8_Blended(font,text,*fg));"))
1667(define ttf-render-glyph-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1668                                                              (unsigned-int ch)
1669                                                              (SDL_Color fg))
1670                                                 "C_return(TTF_RenderGlyph_Blended(font,ch,*fg));"))
1671
1672;---------------------------------------------------------------------------
1673
1674(define img-init (foreign-lambda unsigned-int "IMG_Init" unsigned-int))
1675(define img-quit (foreign-lambda void "IMG_Quit"))
1676(define img-load (foreign-lambda SDL_Surface "IMG_Load" c-string))
1677
1678;---------------------------------------------------------------------------
1679
1680(define rotozoom-surface (foreign-lambda SDL_Surface "rotozoomSurface"
1681                                         SDL_Surface ; src
1682                                         double ; angle
1683                                         double ; zoom
1684                                         bool)) ; smooth
1685
1686(define zoom-surface (foreign-lambda SDL_Surface "zoomSurface"
1687                                     SDL_Surface ; src
1688                                     double ; zoomx
1689                                     double ; zoomy
1690                                     bool)) ; smooth
1691
1692;---------------------------------------------------------------------------
1693
1694(define-foreign-variable sizeof-sdl-ip-address int "sizeof(IPaddress)")
1695(define-record sdl-ip-address buffer)
1696
1697(let ((maker make-sdl-ip-address))
1698  (set! make-sdl-ip-address
1699        (lambda (a b c d p)
1700          (let* ((bv (make-blob sizeof-sdl-ip-address))
1701                 (addr (maker bv)))
1702            ((foreign-lambda* void ((blob bv)
1703                                    (unsigned-integer host)
1704                                    (unsigned-short port))
1705                              "IPaddress *ipa = (IPaddress *) bv;"
1706                              "ipa->host = host;"
1707                              "ipa->port = htons(port);")
1708             bv
1709             (+ (* a 16777216)
1710                (* b 65536)
1711                (* c 256)
1712                d)
1713             p)
1714            addr))))
1715
1716(define-record-printer (sdl-ip-address s out)
1717  (for-each (lambda (x) (display x out))
1718            (list "#<IPaddress "
1719                  (sdl-ip-address-a s)"."
1720                  (sdl-ip-address-b s)"."
1721                  (sdl-ip-address-c s)"."
1722                  (sdl-ip-address-d s)" "
1723                  (sdl-ip-address-port s)">")))
1724
1725(define (-sdl-unbox-ip-address e)
1726  (let ((p (##sys#make-pointer)))
1727    (if e (##core#inline "C_pointer_to_block" p (sdl-ip-address-buffer e)))
1728    p))
1729
1730(define-foreign-type IPaddress (c-pointer "IPaddress")
1731  -sdl-unbox-ip-address)
1732
1733(define sdl-ip-address-a
1734  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[0]);"))
1735(define sdl-ip-address-b
1736  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[1]);"))
1737(define sdl-ip-address-c
1738  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[2]);"))
1739(define sdl-ip-address-d
1740  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[3]);"))
1741
1742(define sdl-ip-address-port
1743  (foreign-lambda* unsigned-short ((IPaddress a)) "C_return(ntohs(a->port));"))
1744
1745(define sdl-ip-address-port-set!
1746  (foreign-lambda* void ((IPaddress a)
1747                         (unsigned-short p))
1748                   "a->port = htons(p);"))
1749
1750;---------------------------------------------------------------------------
1751
1752(define-record sdl-tcp-socket pointer)
1753
1754(define-record-printer (sdl-tcp-socket s out)
1755  (for-each (lambda (x) (display x out))
1756            (list "#<sdl-tcp-socket "(sdl-tcp-socket-pointer s)">")))
1757
1758(define-foreign-type TCPsocket (c-pointer (struct "_TCPsocket"))
1759  sdl-tcp-socket-pointer
1760  (pointer-to-record-lambda sdl-tcp-socket))
1761
1762;---------------------------------------------------------------------------
1763
1764(define sdl-net-init (foreign-lambda int "SDLNet_Init"))
1765(define sdl-net-quit (foreign-lambda void "SDLNet_Quit"))
1766
1767(define sdl-net-resolve-host!
1768  (foreign-lambda int "SDLNet_ResolveHost" IPaddress c-string unsigned-short))
1769
1770(define sdl-net-resolve-ip (foreign-lambda c-string "SDLNet_ResolveIP" IPaddress))
1771
1772(define (sdl-net-resolve-host hostname port)
1773  (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
1774    (and (zero? (sdl-net-resolve-host! ipa hostname port))
1775         ipa)))
1776
1777(define (-sdl-register-socket sock)
1778  (and sock
1779       (begin
1780         (set-finalizer! sock sdl-net-tcp-close)
1781         sock)))
1782
1783(define (sdl-net-tcp-open ipa)
1784  (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Open" IPaddress) ipa)))
1785
1786(define (sdl-net-tcp-accept serv)
1787  (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Accept" TCPsocket) serv)))
1788
1789(define (sdl-net-tcp-get-peer-address sock)
1790  (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
1791    (if ((foreign-lambda* bool ((TCPsocket sock)
1792                                (IPaddress ipa))
1793                          "IPaddress *result = SDLNet_TCP_GetPeerAddress(sock);"
1794                          "if (result != NULL) {"
1795                          "  *ipa = *result;"
1796                          "  C_return(1);"
1797                          "} else {"
1798                          "  C_return(0);"
1799                          "}")
1800         sock ipa)
1801        ipa
1802        #f)))
1803
1804(define (sdl-net-tcp-send sock bv)
1805  ((foreign-lambda int "SDLNet_TCP_Send" TCPsocket blob integer)
1806   sock bv (blob-size bv)))
1807
1808(define sdl-net-tcp-recv (foreign-lambda int "SDLNet_TCP_Recv" TCPsocket blob integer))
1809
1810(define (sdl-net-tcp-close sock)
1811  (if (sdl-tcp-socket-pointer sock)
1812      (begin
1813        ((foreign-lambda void "SDLNet_TCP_Close" TCPsocket) sock)
1814        (sdl-tcp-socket-pointer-set! sock #f))))
1815
1816(define (sdl-net-tcp-send-string sock str)
1817  (sdl-net-tcp-send sock (string->blob str)))
1818
1819(define (sdl-net-tcp-recv-string sock buflen)
1820  (let* ((bv (make-blob buflen))
1821         (result (sdl-net-tcp-recv sock bv buflen)))
1822    (if (positive? result)
1823        (substring (blob->string bv) 0 result)
1824        result)))
1825
1826;---------------------------------------------------------------------------
1827
1828(define-record sdl-net-socket-set pointer)
1829
1830(define-record-printer (sdl-net-socket-set s out)
1831  (for-each (lambda (x) (display x out))
1832            (list "#<sdl-net-socket-set "(sdl-net-socket-set-pointer s)">")))
1833
1834(define-foreign-type SDLNet_SocketSet (c-pointer (struct "_SDLNet_SocketSet"))
1835  sdl-net-socket-set-pointer
1836  (pointer-to-record-lambda sdl-net-socket-set))
1837
1838;---------------------------------------------------------------------------
1839
1840(define sdl-net-alloc-socket-set (foreign-lambda SDLNet_SocketSet "SDLNet_AllocSocketSet" int))
1841(define sdl-net-free-socket-set (foreign-lambda void "SDLNet_FreeSocketSet" SDLNet_SocketSet))
1842
1843(define sdl-net-tcp-add-socket!
1844  (foreign-lambda int "SDLNet_TCP_AddSocket" SDLNet_SocketSet TCPsocket))
1845
1846(define sdl-net-tcp-del-socket!
1847  (foreign-lambda int "SDLNet_TCP_DelSocket" SDLNet_SocketSet TCPsocket))
1848
1849(define (sdl-net-check-sockets socket-set timeout) ;; timeout in milliseconds
1850  (let ((result ((foreign-lambda int "SDLNet_CheckSockets" SDLNet_SocketSet unsigned-integer)
1851                 socket-set timeout)))
1852    (if (= result -1)
1853        #f
1854        result)))
1855
1856(define sdl-net-socket-ready? (foreign-lambda bool "SDLNet_SocketReady" TCPsocket))
1857
1858;---------------------------------------------------------------------------
1859
1860(define sdl-net-write-16
1861  (foreign-lambda* void ((blob bv)
1862                         (int offset)
1863                         (unsigned-short value))
1864                   "SDLNet_Write16(value, &bv[offset]);"))
1865
1866(define sdl-net-write-32
1867  (foreign-lambda* void ((blob bv)
1868                         (int offset)
1869                         (unsigned-integer value))
1870                   "SDLNet_Write32(value, &bv[offset]);"))
1871
1872(define sdl-net-read-16
1873  (foreign-lambda* unsigned-short ((blob bv)
1874                                   (int offset))
1875                   "C_return(SDLNet_Read16(&bv[offset]));"))
1876
1877(define sdl-net-read-32
1878  (foreign-lambda* unsigned-integer ((blob bv)
1879                                     (int offset))
1880                   "C_return(SDLNet_Read32(&bv[offset]));"))
1881
1882)
Note: See TracBrowser for help on using the repository browser.