source: project/release/4/sdl-ttf/trunk/sdl-ttf.scm @ 27336

Last change on this file since 27336 was 27336, checked in by megane, 9 years ago

sdl-img,sdl-ttf: - copied initial sauces from sdl egg

File size: 51.4 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-record sdl-version pointer)
699(define-record sdl-rect buffer)
700(define-record sdl-pixel-format pointer)
701(define-record sdl-surface pointer)
702(define-record sdl-video-info pointer)
703(define-record sdl-event buffer)
704(define-record sdl-color buffer)
705(define-record sdl-joystick pointer)
706
707(include "sdl-foreign-types-include.scm")
708(include "keysym.scm")
709
710; Subsystem definitions, for sdl-init etc.
711(--sdl-flags "SDL_INIT_TIMER"
712             "SDL_INIT_AUDIO"
713             "SDL_INIT_VIDEO"
714             "SDL_INIT_CDROM"
715             "SDL_INIT_JOYSTICK"
716             "SDL_INIT_EVERYTHING"
717             "SDL_INIT_NOPARACHUTE")
718
719(--sdl-flags
720        ;; For sdl-creatergbsurface or sdl-setvideomode
721        "SDL_SWSURFACE"
722        "SDL_HWSURFACE"
723        "SDL_ASYNCBLIT"
724        ;; For sdl-setvideomode
725        "SDL_ANYFORMAT"
726        "SDL_HWPALETTE"
727        "SDL_DOUBLEBUF"
728        "SDL_FULLSCREEN"
729        "SDL_OPENGL"
730        "SDL_OPENGLBLIT"
731        "SDL_RESIZABLE"
732        "SDL_NOFRAME"
733        ;; Read-only - internal
734        "SDL_HWACCEL"
735        "SDL_SRCCOLORKEY"
736        "SDL_RLEACCELOK"
737        "SDL_RLEACCEL"
738        "SDL_SRCALPHA"
739        "SDL_PREALLOC"
740)
741
742(--sdl-flags
743 "SDL_BYTEORDER"
744 "SDL_LIL_ENDIAN"
745 "SDL_BIG_ENDIAN")
746
747; For sdl-wm-grabinput
748(--sdl-flags "SDL_GRAB_QUERY"
749             "SDL_GRAB_OFF"
750             "SDL_GRAB_ON")
751
752(--sdl-flags
753        "SDL_NOEVENT"                   ; Unused (do not remove)
754        "SDL_ACTIVEEVENT"               ; Application loses/gains visibility
755        "SDL_APPMOUSEFOCUS"             ; Mouse focus gained/lost
756        "SDL_APPINPUTFOCUS"             ; Input focus gained/lost
757        "SDL_APPACTIVE"                 ; Application iconified/restored
758        "SDL_KEYDOWN"                   ; Keys pressed
759        "SDL_KEYUP"                     ; Keys released
760        "SDL_MOUSEMOTION"               ; Mouse moved
761        "SDL_MOUSEBUTTONDOWN"           ; Mouse button pressed
762        "SDL_MOUSEBUTTONUP"             ; Mouse button released
763        "SDL_JOYAXISMOTION"             ; Joystick axis motion
764        "SDL_JOYBALLMOTION"             ; Joystick trackball motion
765        "SDL_JOYHATMOTION"              ; Joystick hat position change
766        "SDL_JOYBUTTONDOWN"             ; Joystick button pressed
767        "SDL_JOYBUTTONUP"               ; Joystick button released
768        "SDL_QUIT"                      ; User-requested quit
769        "SDL_SYSWMEVENT"                ; System specific event
770        "SDL_EVENT_RESERVEDA"           ; Reserved for future use..
771        "SDL_EVENT_RESERVEDB"           ; Reserved for future use..
772        "SDL_VIDEORESIZE"               ; User resized video mode
773        "SDL_VIDEOEXPOSE"               ; Screen needs to be redrawn
774        "SDL_EVENT_RESERVED2"           ; Reserved for future use..
775        "SDL_EVENT_RESERVED3"           ; Reserved for future use..
776        "SDL_EVENT_RESERVED4"           ; Reserved for future use..
777        "SDL_EVENT_RESERVED5"           ; Reserved for future use..
778        "SDL_EVENT_RESERVED6"           ; Reserved for future use..
779        "SDL_EVENT_RESERVED7"           ; Reserved for future use..
780        "SDL_USEREVENT"                 ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
781        "SDL_NUMEVENTS"
782)
783
784(--sdl-flags
785        "SDL_ACTIVEEVENTMASK"
786        "SDL_KEYDOWNMASK"
787        "SDL_KEYUPMASK"
788        "SDL_MOUSEMOTIONMASK"
789        "SDL_MOUSEBUTTONDOWNMASK"
790        "SDL_MOUSEBUTTONUPMASK"
791        "SDL_MOUSEEVENTMASK"
792        "SDL_JOYAXISMOTIONMASK"
793        "SDL_JOYBALLMOTIONMASK"
794        "SDL_JOYHATMOTIONMASK"
795        "SDL_JOYBUTTONDOWNMASK"
796        "SDL_JOYBUTTONUPMASK"
797        "SDL_JOYEVENTMASK"
798        "SDL_VIDEORESIZEMASK"
799        "SDL_VIDEOEXPOSEMASK"
800        "SDL_QUITMASK"
801        "SDL_SYSWMEVENTMASK"
802        "SDL_ALLEVENTS"
803)
804
805; General button/key states
806(--sdl-flags
807 "SDL_PRESSED"
808 "SDL_RELEASED")
809
810;; SDL_image constants
811(--sdl-flags
812 "IMG_INIT_JPG"
813 "IMG_INIT_PNG"
814 "IMG_INIT_TIF")
815
816; Mouse button states
817
818; The macro SDL_BUTTON is parameterised, so we have to recreate it as
819; a function
820
821(define (SDL_BUTTON x)
822  (arithmetic-shift SDL_PRESSED (- x 1)))
823
824(--sdl-flags
825        "SDL_BUTTON_LEFT"
826        "SDL_BUTTON_MIDDLE"
827        "SDL_BUTTON_RIGHT"
828        "SDL_BUTTON_WHEELUP"
829        "SDL_BUTTON_WHEELDOWN"
830        "SDL_BUTTON_LMASK" ; = SDL_BUTTON(SDL_BUTTON_LEFT)
831        "SDL_BUTTON_MMASK" ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
832        "SDL_BUTTON_RMASK" ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
833)
834
835; For sdl-eventstate
836(--sdl-flags "SDL_QUERY"
837             "SDL_IGNORE"
838             "SDL_DISABLE"
839             "SDL_ENABLE")
840
841;---------------------------------------------------------------------------
842
843(define-record-printer (sdl-version o out)
844  (for-each (lambda (x) (display x out))
845            (list "#<sdl-version "
846                  (sdl-version-major o) " "
847                  (sdl-version-minor o) " "
848                  (sdl-version-patch o) 
849                  ">")))
850
851(define sdl-version-major
852  (foreign-lambda* unsigned-byte ((SDL_version v))
853                   "C_return(v->major);"))
854
855(define sdl-version-minor
856  (foreign-lambda* unsigned-byte ((SDL_version v))
857                   "C_return(v->minor);"))
858
859(define sdl-version-patch
860  (foreign-lambda* unsigned-byte ((SDL_version v))
861                   "C_return(v->patch);"))
862
863;; Returns #t if the first argument is at least what the rest of the
864;; arguments indicate.
865(define (sdl-version-at-least sdl-version major minor patch)
866  (cond
867   ((> (sdl-version-major sdl-version) major) #t)
868   ((< (sdl-version-major sdl-version) major) #f)
869   ((> (sdl-version-minor sdl-version) minor) #t)
870   ((< (sdl-version-minor sdl-version) minor) #f)
871   ((>= (sdl-version-patch sdl-version) patch) #t)
872   (#t #f)))
873
874(define sdl-compiled-version
875  (foreign-lambda* SDL_version ()
876                   "SDL_version v; SDL_VERSION(&v); C_return(&v);"))
877
878(define sdl-linked-version
879  (foreign-lambda SDL_version "SDL_Linked_Version"))
880
881;---------------------------------------------------------------------------
882
883(define-foreign-variable sizeof-sdl-rect int "sizeof(SDL_Rect)")
884
885(let ((maker make-sdl-rect))
886  (set! make-sdl-rect
887        (lambda (x y w h)
888          (let ((r (maker (make-blob sizeof-sdl-rect))))
889            (sdl-rect-x-set! r x)
890            (sdl-rect-y-set! r y)
891            (sdl-rect-w-set! r w)
892            (sdl-rect-h-set! r h)
893            r))))
894
895(define-record-printer (sdl-rect s out)
896  (for-each (lambda (x) (display x out))
897            (list "#<sdl-rect "
898                  (sdl-rect-x s)" "
899                  (sdl-rect-y s)" "
900                  (sdl-rect-w s)" "
901                  (sdl-rect-h s)">")))
902
903(define sdl-rect-x (foreign-lambda* short ((SDL_Rect c)) "C_return(c->x);"))
904(define sdl-rect-y (foreign-lambda* short ((SDL_Rect c)) "C_return(c->y);"))
905(define sdl-rect-w (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->w);"))
906(define sdl-rect-h (foreign-lambda* unsigned-short ((SDL_Rect c)) "C_return(c->h);"))
907
908(define sdl-rect-x-set! (foreign-lambda* void ((SDL_Rect c) (short x)) "c->x = x;"))
909(define sdl-rect-y-set! (foreign-lambda* void ((SDL_Rect c) (short y)) "c->y = y;"))
910(define sdl-rect-w-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short w)) "c->w = w;"))
911(define sdl-rect-h-set! (foreign-lambda* void ((SDL_Rect c) (unsigned-short h)) "c->h = h;"))
912
913;---------------------------------------------------------------------------
914
915(define-record-printer (sdl-pixel-format p out)
916  (for-each (lambda (x) (display x out))
917            (list "#<sdl-pixel-format "(sdl-pixel-format-pointer p)">")))
918
919(define sdl-pixel-format-bytes-per-pixel
920  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
921                   "C_return(pf->BytesPerPixel);"))
922
923(define sdl-pixel-format-rmask
924  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
925                   "C_return(pf->Rmask);"))
926(define sdl-pixel-format-gmask
927  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
928                   "C_return(pf->Gmask);"))
929(define sdl-pixel-format-bmask
930  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
931                   "C_return(pf->Bmask);"))
932(define sdl-pixel-format-amask
933  (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))
934                   "C_return(pf->Amask);"))
935
936;---------------------------------------------------------------------------
937
938(define-record-printer (sdl-surface s out)
939  (for-each (lambda (x) (display x out))
940            (list "#<sdl-surface "(sdl-surface-pointer s)">")))
941
942(define (sdl-surface-flags s)
943  ((foreign-lambda* unsigned-integer ((SDL_Surface s))
944                    "C_return(s->flags);") s))
945
946(define (sdl-surface-pixel-format s)
947  ((foreign-lambda* SDL_PixelFormat ((SDL_Surface s))
948                    "C_return(s->format);") s))
949
950(define (sdl-surface-width s)
951  ((foreign-lambda* integer ((SDL_Surface s))
952                    "C_return(s->w);") s))
953
954(define (sdl-surface-height s)
955  ((foreign-lambda* integer ((SDL_Surface s))
956                    "C_return(s->h);") s))
957
958(define (sdl-surface-pitch s)
959  ((foreign-lambda* unsigned-short ((SDL_Surface s))
960                    "C_return(s->pitch);") s))
961
962(define (sdl-surface-pixels s)
963  ((foreign-lambda* (c-pointer byte) ((SDL_Surface s))
964                    "C_return(s->pixels);") s))
965
966;; Computes the number of bytes of storage pointed to by
967;; sdl-surface-pixels.
968(define (sdl-surface-pixels-length s)
969  (* (sdl-surface-height s)
970     (sdl-surface-pitch s)))
971
972;;
973;; SDL_VideoInfo
974;;
975
976(define-record-printer (sdl-video-info o out)
977  (for-each (lambda (x) (display x out))
978            (list "#<sdl-video-info "
979                  (sdl-video-info-hw-available o) " "
980                  (sdl-video-info-wm-available o) " "
981                  (sdl-video-info-blit-hw o) " "
982                  (sdl-video-info-blit-hw-cc o) " "
983                  (sdl-video-info-blit-hw-a o) " "
984                  (sdl-video-info-blit-sw o) " "
985                  (sdl-video-info-blit-sw-cc o) " "
986                  (sdl-video-info-blit-sw-a o) " "
987                  (sdl-video-info-blit-fill o) " "
988                  (sdl-video-info-video-mem o) " "
989                  (sdl-video-info-vfmt o) " "
990                  (sdl-video-info-current-w o) " "
991                  (sdl-video-info-current-h o)
992                  ">")))
993
994(define sdl-video-info-hw-available
995  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
996                   "C_return(vi->hw_available);"))
997(define sdl-video-info-wm-available
998  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
999                   "C_return(vi->wm_available);"))
1000(define sdl-video-info-blit-hw
1001  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1002                   "C_return(vi->blit_hw);"))
1003(define sdl-video-info-blit-hw-cc
1004  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1005                   "C_return(vi->blit_hw_CC);"))
1006(define sdl-video-info-blit-hw-a
1007  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1008                   "C_return(vi->blit_hw_A);"))
1009(define sdl-video-info-blit-sw
1010  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1011                   "C_return(vi->blit_sw);"))
1012(define sdl-video-info-blit-sw-cc
1013  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1014                   "C_return(vi->blit_sw_CC);"))
1015(define sdl-video-info-blit-sw-a
1016  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1017                   "C_return(vi->blit_sw_A);"))
1018(define sdl-video-info-blit-fill
1019  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1020                   "C_return(vi->blit_fill);"))
1021(define sdl-video-info-video-mem
1022  (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))
1023                   "C_return(vi->video_mem);"))
1024(define sdl-video-info-vfmt
1025  (foreign-lambda* SDL_PixelFormat ((SDL_VideoInfo vi))
1026                   "C_return(vi->vfmt);"))
1027(define sdl-video-info-current-w
1028  (foreign-lambda* integer ((SDL_VideoInfo vi))
1029                   "C_return(vi->current_w);"))
1030(define sdl-video-info-current-h
1031  (foreign-lambda* integer ((SDL_VideoInfo vi))
1032                   "C_return(vi->current_h);"))
1033
1034(define sdl-get-video-info
1035  (foreign-lambda* SDL_VideoInfo ()
1036                   "C_return(SDL_GetVideoInfo());"))
1037
1038
1039;---------------------------------------------------------------------------
1040
1041;; Modifies its second argument.
1042(define sdl-get-clip-rect! (foreign-lambda void "SDL_GetClipRect" SDL_Surface SDL_Rect))
1043
1044;; Modifies its first argument.
1045(define sdl-set-clip-rect! (foreign-lambda bool "SDL_SetClipRect" SDL_Surface SDL_Rect))
1046
1047;; Modifies its first argument.
1048(define sdl-set-color-key!
1049  (foreign-lambda int "SDL_SetColorKey" SDL_Surface unsigned-integer unsigned-integer))
1050
1051;; Modifies its first argument.
1052(define sdl-set-alpha!
1053  (foreign-lambda int "SDL_SetAlpha" SDL_Surface unsigned-integer unsigned-byte))
1054
1055(define sdl-display-format
1056  (foreign-lambda SDL_Surface "SDL_DisplayFormat" SDL_Surface))
1057(define sdl-display-format-alpha
1058  (foreign-lambda SDL_Surface "SDL_DisplayFormatAlpha" SDL_Surface))
1059(define sdl-convert-surface
1060  (foreign-lambda SDL_Surface "SDL_ConvertSurface" SDL_Surface SDL_PixelFormat unsigned-integer))
1061
1062;---------------------------------------------------------------------------
1063
1064;; NOTE: sdl-init does not work on MacOS X when called from a
1065;; dynamically-loaded extension. Something internal to Quartz seems to
1066;; get confused. You must call SDL_Init *directly* from your main
1067;; program - if your main program is written in Scheme, you need to
1068;; say something like:
1069;;
1070;; (declare (foreign-declare "#include <SDL.h>\n"))
1071;; (foreign-code "SDL_Init(SDL_INIT_EVERYTHING);")
1072;;
1073(define (sdl-init flags)
1074  (zero? ((foreign-lambda int "SDL_Init" unsigned-integer) flags)))
1075
1076;; Note: guile-sdl names these 'sdl-init-subsystem' and
1077;; 'sdl-quit-subsystem', respectively.
1078
1079(define (sdl-init-sub-system flags)
1080  (zero? ((foreign-lambda int "SDL_InitSubSystem" unsigned-integer) flags)))
1081
1082(define (sdl-quit-sub-system flags)
1083  ((foreign-lambda void "SDL_QuitSubSystem" unsigned-integer) flags))
1084
1085(define (sdl-quit)
1086  ((foreign-lambda void "SDL_Quit")))
1087
1088(define (sdl-was-init flags)
1089  ((foreign-lambda unsigned-integer "SDL_WasInit" unsigned-integer) flags))
1090
1091(define sdl-set-error! (foreign-lambda* void ((c-string str)) "SDL_SetError(\"%s\", str);"))
1092(define sdl-get-error (foreign-lambda c-string "SDL_GetError"))
1093(define sdl-clear-error! (foreign-lambda void "SDL_ClearError"))
1094
1095;---------------------------------------------------------------------------
1096
1097(define (sdl-wm-set-caption title icon)
1098  ((foreign-lambda void "SDL_WM_SetCaption" c-string c-string) title icon))
1099
1100(define (sdl-wm-get-caption-title)
1101  ((foreign-lambda* c-string ()
1102                    "char *t, *i;"
1103                    "SDL_WM_GetCaption(&t, &i);"
1104                    "C_return(t);")))
1105
1106(define (sdl-wm-get-caption-icon)
1107  ((foreign-lambda* c-string ()
1108                    "char *t, *i;"
1109                    "SDL_WM_GetCaption(&t, &i);"
1110                    "C_return(i);")))
1111
1112(define (sdl-wm-get-caption)
1113  (values (sdl-wm-get-caption-title)
1114          (sdl-wm-get-caption-icon)))
1115
1116(define (sdl-wm-set-icon icon mask)
1117  ((foreign-lambda void "SDL_WM_SetIcon" SDL_Surface blob) icon mask))
1118
1119(define (sdl-wm-iconify-window)
1120  (not (zero? ((foreign-lambda integer "SDL_WM_IconifyWindow")))))
1121
1122(define (sdl-wm-toggle-full-screen surf)
1123  (not (zero? ((foreign-lambda integer "SDL_WM_ToggleFullScreen" SDL_Surface) surf))))
1124
1125(define (sdl-wm-grab-input m)
1126  ((foreign-lambda integer "SDL_WM_GrabInput" integer) m))
1127
1128;---------------------------------------------------------------------------
1129
1130; Milliseconds.
1131(define sdl-get-ticks (foreign-lambda unsigned-integer "SDL_GetTicks"))
1132(define sdl-delay (foreign-lambda void "SDL_Delay" unsigned-integer))
1133
1134(cond-expand
1135 (mingw32
1136  (define get-time-of-day current-seconds))
1137 (else
1138  (define get-time-of-day
1139    (foreign-lambda* double ()
1140      "struct timeval tv;"
1141      "gettimeofday(&tv, NULL);"
1142      "C_return((double) tv.tv_sec + ((double) tv.tv_usec / 1000000.0));"))))
1143
1144(define-values (sdl-add-absolute-timer!
1145                sdl-process-timer-queue!)
1146  (make-timer-queue get-time-of-day))
1147
1148(define (sdl-add-relative-timer! time callback)
1149  (sdl-add-absolute-timer! (+ time (get-time-of-day)) callback))
1150
1151;---------------------------------------------------------------------------
1152
1153(define-foreign-variable sizeof-sdl-event int "sizeof(SDL_Event)")
1154
1155(let ((maker make-sdl-event))
1156  (set! make-sdl-event
1157        (lambda ()
1158          (let ((bv (blob->u8vector (make-blob sizeof-sdl-event))))
1159            (u8vector-set! bv 0 SDL_NOEVENT)
1160            (maker (u8vector->blob bv))))))
1161
1162(define-record-printer (sdl-event s out)
1163  (for-each (lambda (x) (display x out))
1164            (list "#<sdl-event "(sdl-event-type s)">")))
1165
1166(define sdl-event-type (foreign-lambda* unsigned-byte ((SDL_Event e)) "C_return(e->type);"))
1167(define sdl-event-type-set! (foreign-lambda* void ((SDL_Event e) (unsigned-byte t)) "e->type = t;"))
1168
1169(define-syntax --sdl-event-getter-setter
1170  (lambda (f r c)
1171    (let ((name (cadr f))
1172          (rest (cddr f)))
1173      (let* ((strapp (lambda s (apply string-append
1174                                  (map (lambda (x) (cond
1175                                                    ((symbol? x) (symbol->string x))
1176                                                    (else x)))
1177                                       s))))
1178         (symapp (lambda s (string->symbol (apply strapp s)))))
1179  `(,(r 'begin)
1180     (,(r 'define) (,(symapp "sdl-event-" name) e)
1181       (,(r 'let) ((,(r 't) (,(r 'sdl-event-type) e)))
1182         (,(r 'cond)
1183          ,@(map (lambda (clause)
1184                   (apply (lambda (etype mem1 kind)
1185                            `((,(r '=) ,(r 't) ,etype) ((,(r 'foreign-lambda*)
1186                                             ,kind ((SDL_Event e))
1187                                             ,(strapp "C_return(e->"mem1"."name");")) e)))
1188                          clause))
1189                 rest)
1190          (,(r 'else) (,(r 'error) ,(string-append "sdl-event-" (symbol->string name)
1191                                       ": cannot extract value from this type of event")
1192                       (,(r 'sdl-event-type) e))))))
1193     (,(r 'define) (,(symapp "set-sdl-event-" name "!") e v)
1194       (,(r 'let) ((t (,(r 'sdl-event-type) e)))
1195         (,(r 'cond)
1196          ,@(map (lambda (clause)
1197                   (apply (lambda (etype mem1 kind)
1198                            `((,(r '=) t ,etype) ((,(r 'foreign-lambda*)
1199                                             void ((SDL_Event e)
1200                                                   (,kind v))
1201                                             ,(strapp "e->"mem1"."name"=v;")) e v)))
1202                          clause))
1203                 rest)
1204          (,(r 'else) (,(r 'error) ,(string-append "set-sdl-event-" (symbol->string name) "!"
1205                                       ": cannot update value for this type of event")
1206                       (,(r 'sdl-event-type) e)))))))))))
1207
1208(--sdl-event-getter-setter gain         (SDL_ACTIVEEVENT active bool))
1209(--sdl-event-getter-setter which        (SDL_KEYDOWN key unsigned-byte)
1210                                        (SDL_KEYUP key unsigned-byte)
1211                                        (SDL_MOUSEMOTION motion unsigned-byte)
1212                                        (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1213                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1214                                        (SDL_JOYAXISMOTION jaxis unsigned-byte)
1215                                        (SDL_JOYBALLMOTION jball unsigned-byte)
1216                                        (SDL_JOYHATMOTION jhat unsigned-byte)
1217                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1218                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1219(--sdl-event-getter-setter state        (SDL_ACTIVEEVENT active unsigned-byte)
1220                                        (SDL_KEYDOWN key unsigned-byte)
1221                                        (SDL_KEYUP key unsigned-byte)
1222                                        (SDL_MOUSEMOTION motion unsigned-byte)
1223                                        (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1224                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1225                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1226                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1227(--sdl-event-getter-setter scancode     (SDL_KEYDOWN key.keysym unsigned-byte)
1228                                        (SDL_KEYUP   key.keysym unsigned-byte))
1229(--sdl-event-getter-setter sym          (SDL_KEYDOWN key.keysym integer)
1230                                        (SDL_KEYUP   key.keysym integer))
1231(--sdl-event-getter-setter mod          (SDL_KEYDOWN key.keysym integer)
1232                                        (SDL_KEYUP   key.keysym integer))
1233(--sdl-event-getter-setter unicode      (SDL_KEYDOWN key.keysym short)
1234                                        (SDL_KEYUP   key.keysym short))
1235(--sdl-event-getter-setter x            (SDL_MOUSEMOTION motion unsigned-short)
1236                                        (SDL_MOUSEBUTTONDOWN button unsigned-short)
1237                                        (SDL_MOUSEBUTTONUP button unsigned-short))
1238(--sdl-event-getter-setter y            (SDL_MOUSEMOTION motion unsigned-short)
1239                                        (SDL_MOUSEBUTTONDOWN button unsigned-short)
1240                                        (SDL_MOUSEBUTTONUP button unsigned-short))
1241(--sdl-event-getter-setter xrel         (SDL_MOUSEMOTION motion short)
1242                                        (SDL_JOYBALLMOTION jball short))
1243(--sdl-event-getter-setter yrel         (SDL_MOUSEMOTION motion short)
1244                                        (SDL_JOYBALLMOTION jball short))
1245(--sdl-event-getter-setter axis         (SDL_JOYAXISMOTION jaxis unsigned-byte))
1246(--sdl-event-getter-setter ball         (SDL_JOYBALLMOTION jball unsigned-byte))
1247(--sdl-event-getter-setter hat          (SDL_JOYHATMOTION jhat unsigned-byte))
1248(--sdl-event-getter-setter value        (SDL_JOYAXISMOTION jaxis short)
1249                                        (SDL_JOYHATMOTION jhat unsigned-byte))
1250(--sdl-event-getter-setter button       (SDL_MOUSEBUTTONDOWN button unsigned-byte)
1251                                        (SDL_MOUSEBUTTONUP button unsigned-byte)
1252                                        (SDL_JOYBUTTONDOWN jbutton unsigned-byte)
1253                                        (SDL_JOYBUTTONUP jbutton unsigned-byte))
1254(--sdl-event-getter-setter w            (SDL_VIDEORESIZE resize integer))
1255(--sdl-event-getter-setter h            (SDL_VIDEORESIZE resize integer))
1256
1257(define sdl-pump-events (foreign-lambda void "SDL_PumpEvents"))
1258
1259(define (sdl-poll-event! . e)
1260  (if (null? e)
1261      (not (zero? ((foreign-lambda int "SDL_PollEvent" c-pointer) #f)))
1262      (not (zero? ((foreign-lambda int "SDL_PollEvent" SDL_Event) (car e))))))
1263
1264;; Now, (sdl-wait-event!) is implemented internally to SDL_event.c as:
1265;;
1266;;  while (1) {
1267;;    SDL_PumpEvents();
1268;;    switch(SDL_PeepEvents(event, 1, SDL_GETEVENT, SDL_ALLEVENTS)) {
1269;;      case -1: return 0;
1270;;      case 1: return 1;
1271;;      case 0: SDL_Delay(10);
1272;;    }
1273;;  }
1274;;
1275;; Since the SDL implementation of timers uses setitimer(2), and we
1276;; have trouble with setitimer and chicken - see the README - we
1277;; reimplement (sdl-wait-event!) here calling out to our timer queue
1278;; processing function.
1279
1280(define (sdl-wait-event!* delay-function . e)
1281  (let loop ()
1282    (sdl-pump-events)
1283    (let ((peep-result ((foreign-lambda*
1284                         int ((SDL_Event eptr))
1285                         "C_return(SDL_PeepEvents(eptr, 1, SDL_GETEVENT, SDL_ALLEVENTS));")
1286                        (if (null? e) #f (car e)))))
1287      (case peep-result
1288        ((-1) #f) ;; error.
1289        ((1) #t)  ;; present event.
1290        ((0)
1291         ;; No event, yet. Check our timer queue, wait, and retry.
1292         (let* ((delay-seconds (or (sdl-process-timer-queue!) 0.01))
1293                (sleep-time (min delay-seconds 0.01))
1294                (fix-sleep-time (inexact->exact (truncate (* 1000 sleep-time)))))
1295           (delay-function fix-sleep-time)
1296           (loop)))
1297        (else (error "sdl-wait-event!: unexpected result from SDL_PeepEvents" peep-result))))))
1298
1299(define (sdl-wait-event! . e)
1300  (apply sdl-wait-event!* sdl-delay e))
1301
1302;; Here's the implementation of (sdl-wait-event!) that calls the
1303;; SDL-provided routine:
1304;;
1305;; (define (sdl-wait-event! . e)
1306;;   (if (null? e)
1307;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" c-pointer) #f)))
1308;;       (not (zero? ((foreign-lambda int "SDL_WaitEvent" SDL_Event) (car e))))))
1309
1310(define (sdl-push-event e)
1311  (zero? ((foreign-lambda int "SDL_PushEvent" SDL_Event) e)))
1312
1313(define sdl-event-state! (foreign-lambda int "SDL_EventState" unsigned-int integer))
1314
1315; You can pass NULL for the args if you just want the button state
1316(define sdl-get-mouse-state (foreign-lambda int "SDL_GetMouseState" s32vector s32vector))
1317
1318(define sdl-warp-mouse (foreign-lambda void "SDL_WarpMouse" int int))
1319 
1320(define sdl-enable-unicode (foreign-lambda bool "SDL_EnableUNICODE" bool))
1321
1322;---------------------------------------------------------------------------
1323
1324(define sdl-get-video-surface (foreign-lambda SDL_Surface "SDL_GetVideoSurface"))
1325
1326(define (sdl-video-driver-name)
1327  (let ((bv (make-blob 128)))
1328    (and ((foreign-lambda bool "SDL_VideoDriverName" (c-pointer char) integer)
1329          (make-locative bv)
1330          (blob-size bv))
1331         (substring (blob->string bv)
1332                    0
1333                    (string-index (blob->string bv)
1334                                  (integer->char 0))))))
1335
1336(define sdl-set-video-mode (foreign-lambda SDL_Surface "SDL_SetVideoMode"
1337                                           integer ; width
1338                                           integer ; height
1339                                           integer ; bpp
1340                                           unsigned-integer ; flags
1341                                           ))
1342
1343(define (sdl-video-mode-ok w h bpp flags)
1344  (let ((result ((foreign-lambda integer "SDL_VideoModeOK"
1345                                 integer integer
1346                                 integer unsigned-integer)
1347                 w h bpp flags)))
1348    (and (not (zero? result))
1349         result)))
1350
1351(define (sdl-show-cursor . toggle)
1352  (if (null? toggle)
1353      ((foreign-lambda int "SDL_ShowCursor" int) -1)
1354      ((foreign-lambda int "SDL_ShowCursor" int) (if (car toggle) 1 0))))
1355
1356(define sdl-map-rgb (foreign-lambda unsigned-integer "SDL_MapRGB"
1357                                    SDL_PixelFormat
1358                                    unsigned-byte
1359                                    unsigned-byte
1360                                    unsigned-byte))
1361
1362(define sdl-map-rgba (foreign-lambda unsigned-integer "SDL_MapRGBA"
1363                                     SDL_PixelFormat
1364                                     unsigned-byte
1365                                     unsigned-byte
1366                                     unsigned-byte
1367                                     unsigned-byte))
1368
1369;---------------------------------------------------------------------------
1370
1371(define (sdl-fill-rect s r c)
1372  (if (sdl-color? c)
1373      ((foreign-lambda* int ((SDL_Surface s)
1374                             (SDL_Rect r)
1375                             (scheme-pointer cbuf))
1376                        "SDL_Color *c = (SDL_Color *) cbuf;"
1377                        "unsigned int c2 = SDL_MapRGB(s->format, c->r, c->g, c->b);"
1378                        "C_return(SDL_FillRect(s, r, c2));")
1379       s r (sdl-color-buffer c))
1380      ((foreign-lambda int "SDL_FillRect" SDL_Surface SDL_Rect unsigned-integer)
1381       s r c)))
1382
1383(define sdl-flip (foreign-lambda int "SDL_Flip" SDL_Surface))
1384
1385(define sdl-create-rgb-surface (foreign-lambda SDL_Surface "SDL_CreateRGBSurface"
1386                                               unsigned-integer ; flags
1387                                               integer ; width
1388                                               integer ; height
1389                                               integer ; depth
1390                                               unsigned-integer ; rmask
1391                                               unsigned-integer ; gmask
1392                                               unsigned-integer ; bmask
1393                                               unsigned-integer)) ; amask
1394(define (sdl-free-surface surf)
1395  ((foreign-lambda void "SDL_FreeSurface" SDL_Surface) surf)
1396  (sdl-surface-pointer-set! surf (address->pointer 0)))
1397
1398(define sdl-blit-surface (foreign-lambda integer "SDL_BlitSurface"
1399                                         SDL_Surface SDL_Rect ; src, srcrect
1400                                         SDL_Surface SDL_Rect)) ; dst, dstrect
1401
1402(define (sdl-with-clip-rect s r thunk)
1403  (let ((orig-clip-rect (make-sdl-rect 0 0 0 0)))
1404    (dynamic-wind
1405        (lambda ()
1406          (sdl-get-clip-rect! s orig-clip-rect)
1407          (sdl-set-clip-rect! s r))
1408        thunk
1409        (lambda ()
1410          (sdl-set-clip-rect! s orig-clip-rect)))))
1411
1412;---------------------------------------------------------------------------
1413
1414(define-foreign-variable sizeof-sdl-color int "sizeof(SDL_Color)")
1415
1416(let ((maker make-sdl-color))
1417  (set! make-sdl-color
1418        (lambda (r g b)
1419          (let ((bv (make-blob sizeof-sdl-color)))
1420            (fill-sdl-color! (maker bv) r g b)))))
1421
1422(define-record-printer (sdl-color s out)
1423  (for-each (lambda (x) (display x out))
1424            (list "#<sdl-color "
1425                  (sdl-color-r s)" "
1426                  (sdl-color-g s)" "
1427                  (sdl-color-b s)">")))
1428
1429(define (fill-sdl-color! c r g b)
1430  ((foreign-lambda* void ((SDL_Color c) (unsigned-byte r) (unsigned-byte g) (unsigned-byte b))
1431                    "c->r = r; c->g = g; c->b = b;")
1432   c r g b)
1433  c)
1434
1435(define sdl-color-r (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->r);"))
1436(define sdl-color-g (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->g);"))
1437(define sdl-color-b (foreign-lambda* unsigned-byte ((SDL_Color c)) "C_return(c->b);"))
1438
1439;---------------------------------------------------------------------------
1440(define-record-printer (sdl-joystick p out)
1441  (for-each (lambda (x) (display x out))
1442            (list "#<sdl-joystick "(sdl-joystick-pointer p)">")))
1443
1444(define sdl-joystick-event-state (foreign-lambda int "SDL_JoystickEventState"
1445                                                 int))
1446(define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
1447(define sdl-num-joysticks (foreign-lambda int "SDL_NumJoysticks"))
1448(define sdl-joystick-name (foreign-lambda c-string "SDL_JoystickName" int))
1449(define sdl-joystick-open (foreign-lambda SDL_Joystick "SDL_JoystickOpen" int))
1450(define sdl-joystick-opened (foreign-lambda int "SDL_JoystickOpened" int))
1451(define sdl-joystick-index (foreign-lambda int "SDL_JoystickIndex"
1452                                           SDL_Joystick))
1453(define sdl-joystick-num-axes (foreign-lambda int "SDL_JoystickNumAxes"
1454                                              SDL_Joystick))
1455(define sdl-joystick-num-balls (foreign-lambda int "SDL_JoystickNumBalls"
1456                                               SDL_Joystick))
1457(define sdl-joystick-num-hats (foreign-lambda int "SDL_JoystickNumHats"
1458                                              SDL_Joystick))
1459(define sdl-joystick-num-buttons (foreign-lambda int "SDL_JoystickNumButtons"
1460                                                 SDL_Joystick))
1461(define sdl-joystick-update (foreign-lambda void "SDL_JoystickUpdate"))
1462(define sdl-joystick-get-axis (foreign-lambda short "SDL_JoystickGetAxis"
1463                                              SDL_Joystick int))
1464(define sdl-joystick-get-hat (foreign-lambda unsigned-char "SDL_JoystickGetHat"
1465                                             SDL_Joystick int))
1466(define sdl-joystick-get-button (foreign-lambda unsigned-char
1467                                                "SDL_JoystickGetButton"
1468                                                SDL_Joystick int))
1469;TODO: sdl-joystick-get-ball
1470(define sdl-joystick-close (foreign-lambda void "SDL_JoystickClose"
1471                                           SDL_Joystick))
1472
1473;---------------------------------------------------------------------------
1474;
1475; OpenGL stuff:
1476
1477(--sdl-flags "SDL_GL_RED_SIZE"
1478             "SDL_GL_GREEN_SIZE"
1479             "SDL_GL_BLUE_SIZE"
1480             "SDL_GL_ALPHA_SIZE"
1481             "SDL_GL_BUFFER_SIZE"
1482             "SDL_GL_DOUBLEBUFFER"
1483             "SDL_GL_DEPTH_SIZE"
1484             "SDL_GL_STENCIL_SIZE"
1485             "SDL_GL_ACCUM_RED_SIZE"
1486             "SDL_GL_ACCUM_GREEN_SIZE"
1487             "SDL_GL_ACCUM_BLUE_SIZE"
1488             "SDL_GL_ACCUM_ALPHA_SIZE"
1489             "SDL_GL_STEREO"
1490             "SDL_GL_MULTISAMPLEBUFFERS"
1491             "SDL_GL_MULTISAMPLESAMPLES"
1492             "SDL_GL_SWAP_CONTROL"
1493             "SDL_GL_ACCELERATED_VISUAL")
1494
1495(define sdl-gl-swap-buffers (foreign-lambda void "SDL_GL_SwapBuffers"))
1496(define sdl-gl-set-attribute (foreign-lambda int "SDL_GL_SetAttribute" unsigned-int int))
1497
1498(define sdl-gl-get-attribute
1499  (let ((get (foreign-lambda int "SDL_GL_GetAttribute" unsigned-int (c-pointer int))))
1500    (lambda (attr)
1501      (let-location ((ptr int))
1502        (let ((r (get attr (location ptr))))
1503          (and (zero? r) ptr))))))
1504
1505;---------------------------------------------------------------------------
1506
1507(define-record ttf-font pointer)
1508
1509(define-record-printer (ttf-font f out)
1510  (for-each (lambda (x) (display x out))
1511            (list "#<ttf-font "(ttf-font-pointer f)">")))
1512
1513(define-foreign-type TTF_Font (c-pointer "TTF_Font")
1514  ttf-font-pointer
1515  (lambda (p)
1516   (set-finalizer! ((pointer-to-record-lambda ttf-font) p)
1517                   ttf-close-font)))
1518
1519(define ttf-init (foreign-lambda integer "TTF_Init"))
1520(define ttf-was-init (foreign-lambda integer "TTF_WasInit"))
1521(define ttf-quit (foreign-lambda void "TTF_Quit"))
1522
1523(define ttf-compiled-version
1524  (foreign-lambda* SDL_version ()
1525                   "SDL_version v; SDL_TTF_VERSION(&v); C_return(&v);"))
1526(define ttf-linked-version
1527  (foreign-lambda SDL_version "TTF_Linked_Version"))
1528
1529(define ttf-open-font (foreign-lambda TTF_Font "TTF_OpenFont" c-string integer))
1530(define ttf-open-font-index (foreign-lambda TTF_Font "TTF_OpenFontIndex" c-string integer long))
1531(define (ttf-close-font f)
1532  (if (ttf-font-pointer f)
1533   (begin
1534     ((foreign-lambda void "TTF_CloseFont" TTF_Font) f)
1535     (ttf-font-pointer-set! f #f))))
1536
1537(--sdl-flags "TTF_STYLE_NORMAL"
1538             "TTF_STYLE_BOLD"
1539             "TTF_STYLE_ITALIC"
1540             "TTF_STYLE_UNDERLINE")
1541
1542(define ttf-get-font-style (foreign-lambda integer "TTF_GetFontStyle" TTF_Font))
1543(define ttf-set-font-style (foreign-lambda void "TTF_SetFontStyle" TTF_Font integer))
1544
1545(define ttf-font-height (foreign-lambda integer "TTF_FontHeight" TTF_Font))
1546(define ttf-font-ascent (foreign-lambda integer "TTF_FontAscent" TTF_Font))
1547(define ttf-font-descent (foreign-lambda integer "TTF_FontDescent" TTF_Font))
1548(define ttf-font-line-skip (foreign-lambda integer "TTF_FontLineSkip" TTF_Font))
1549(define ttf-font-faces (foreign-lambda long "TTF_FontFaces" TTF_Font))
1550
1551(define ttf-font-face-is-fixed-width? (foreign-lambda bool "TTF_FontFaceIsFixedWidth" TTF_Font))
1552(define ttf-font-face-family-name (foreign-lambda c-string "TTF_FontFaceFamilyName" TTF_Font))
1553(define ttf-font-face-style-name (foreign-lambda c-string "TTF_FontFaceStyleName" TTF_Font))
1554
1555(define ttf-size-text! (foreign-lambda* bool ((TTF_Font font)
1556                                              (c-string text)
1557                                              (SDL_Rect rect))
1558                                        "int ww, hh;"
1559                                        "int status = TTF_SizeText(font, text, &ww, &hh);"
1560                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
1561                                        "C_return((status == 0));"))
1562(define ttf-size-utf8! (foreign-lambda* bool ((TTF_Font font)
1563                                              (c-string text)
1564                                              (SDL_Rect rect))
1565                                        "int ww, hh;"
1566                                        "int status = TTF_SizeUTF8(font, text, &ww, &hh);"
1567                                        "if (status == 0) { rect->w = ww; rect->h = hh; }"
1568                                        "C_return((status == 0));"))
1569
1570(define ttf-render-text-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1571                                                            (c-string text)
1572                                                            (SDL_Color fg))
1573                                               "C_return(TTF_RenderText_Solid(font,text,*fg));"))
1574(define ttf-render-utf8-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1575                                                            (c-string text)
1576                                                            (SDL_Color fg))
1577                                               "C_return(TTF_RenderUTF8_Solid(font,text,*fg));"))
1578(define ttf-render-glyph-solid (foreign-lambda* SDL_Surface ((TTF_Font font)
1579                                                             (unsigned-int ch)
1580                                                             (SDL_Color fg))
1581                                                "C_return(TTF_RenderGlyph_Solid(font,ch,*fg));"))
1582
1583(define ttf-render-text-shaded
1584  (foreign-lambda* SDL_Surface ((TTF_Font font)
1585                                (c-string text)
1586                                (SDL_Color fg)
1587                                (SDL_Color bg))
1588                   "C_return(TTF_RenderText_Shaded(font,text,*fg,*bg));"))
1589(define ttf-render-utf8-shaded
1590  (foreign-lambda* SDL_Surface ((TTF_Font font)
1591                                (c-string text)
1592                                (SDL_Color fg)
1593                                (SDL_Color bg))
1594                   "C_return(TTF_RenderUTF8_Shaded(font,text,*fg,*bg));"))
1595(define ttf-render-glyph-shaded
1596  (foreign-lambda* SDL_Surface ((TTF_Font font)
1597                                (unsigned-int ch)
1598                                (SDL_Color fg)
1599                                (SDL_Color bg))
1600                   "C_return(TTF_RenderGlyph_Shaded(font,ch,*fg, *bg));"))
1601
1602(define ttf-render-text-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1603                                                              (c-string text)
1604                                                              (SDL_Color fg))
1605                                                 "C_return(TTF_RenderText_Blended(font,text,*fg));"))
1606(define ttf-render-utf8-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1607                                                              (c-string text)
1608                                                              (SDL_Color fg))
1609                                                 "C_return(TTF_RenderUTF8_Blended(font,text,*fg));"))
1610(define ttf-render-glyph-blended (foreign-lambda* SDL_Surface ((TTF_Font font)
1611                                                              (unsigned-int ch)
1612                                                              (SDL_Color fg))
1613                                                 "C_return(TTF_RenderGlyph_Blended(font,ch,*fg));"))
1614
1615;---------------------------------------------------------------------------
1616
1617(define img-init (foreign-lambda unsigned-int "IMG_Init" unsigned-int))
1618(define img-quit (foreign-lambda void "IMG_Quit"))
1619(define img-load (foreign-lambda SDL_Surface "IMG_Load" c-string))
1620
1621;---------------------------------------------------------------------------
1622
1623(define rotozoom-surface (foreign-lambda SDL_Surface "rotozoomSurface"
1624                                         SDL_Surface ; src
1625                                         double ; angle
1626                                         double ; zoom
1627                                         bool)) ; smooth
1628
1629(define zoom-surface (foreign-lambda SDL_Surface "zoomSurface"
1630                                     SDL_Surface ; src
1631                                     double ; zoomx
1632                                     double ; zoomy
1633                                     bool)) ; smooth
1634
1635;---------------------------------------------------------------------------
1636
1637(define-foreign-variable sizeof-sdl-ip-address int "sizeof(IPaddress)")
1638(define-record sdl-ip-address buffer)
1639
1640(let ((maker make-sdl-ip-address))
1641  (set! make-sdl-ip-address
1642        (lambda (a b c d p)
1643          (let* ((bv (make-blob sizeof-sdl-ip-address))
1644                 (addr (maker bv)))
1645            ((foreign-lambda* void ((blob bv)
1646                                    (unsigned-integer host)
1647                                    (unsigned-short port))
1648                              "IPaddress *ipa = (IPaddress *) bv;"
1649                              "ipa->host = host;"
1650                              "ipa->port = htons(port);")
1651             bv
1652             (+ (* a 16777216)
1653                (* b 65536)
1654                (* c 256)
1655                d)
1656             p)
1657            addr))))
1658
1659(define-record-printer (sdl-ip-address s out)
1660  (for-each (lambda (x) (display x out))
1661            (list "#<IPaddress "
1662                  (sdl-ip-address-a s)"."
1663                  (sdl-ip-address-b s)"."
1664                  (sdl-ip-address-c s)"."
1665                  (sdl-ip-address-d s)" "
1666                  (sdl-ip-address-port s)">")))
1667
1668(define (-sdl-unbox-ip-address e)
1669  (let ((p (##sys#make-pointer)))
1670    (if e (##core#inline "C_pointer_to_block" p (sdl-ip-address-buffer e)))
1671    p))
1672
1673(define-foreign-type IPaddress (c-pointer "IPaddress")
1674  -sdl-unbox-ip-address)
1675
1676(define sdl-ip-address-a
1677  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[0]);"))
1678(define sdl-ip-address-b
1679  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[1]);"))
1680(define sdl-ip-address-c
1681  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[2]);"))
1682(define sdl-ip-address-d
1683  (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[3]);"))
1684
1685(define sdl-ip-address-port
1686  (foreign-lambda* unsigned-short ((IPaddress a)) "C_return(ntohs(a->port));"))
1687
1688(define sdl-ip-address-port-set!
1689  (foreign-lambda* void ((IPaddress a)
1690                         (unsigned-short p))
1691                   "a->port = htons(p);"))
1692
1693;---------------------------------------------------------------------------
1694
1695(define-record sdl-tcp-socket pointer)
1696
1697(define-record-printer (sdl-tcp-socket s out)
1698  (for-each (lambda (x) (display x out))
1699            (list "#<sdl-tcp-socket "(sdl-tcp-socket-pointer s)">")))
1700
1701(define-foreign-type TCPsocket (c-pointer (struct "_TCPsocket"))
1702  sdl-tcp-socket-pointer
1703  (pointer-to-record-lambda sdl-tcp-socket))
1704
1705;---------------------------------------------------------------------------
1706
1707(define sdl-net-init (foreign-lambda int "SDLNet_Init"))
1708(define sdl-net-quit (foreign-lambda void "SDLNet_Quit"))
1709
1710(define sdl-net-resolve-host!
1711  (foreign-lambda int "SDLNet_ResolveHost" IPaddress c-string unsigned-short))
1712
1713(define sdl-net-resolve-ip (foreign-lambda c-string "SDLNet_ResolveIP" IPaddress))
1714
1715(define (sdl-net-resolve-host hostname port)
1716  (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
1717    (and (zero? (sdl-net-resolve-host! ipa hostname port))
1718         ipa)))
1719
1720(define (-sdl-register-socket sock)
1721  (and sock
1722       (begin
1723         (set-finalizer! sock sdl-net-tcp-close)
1724         sock)))
1725
1726(define (sdl-net-tcp-open ipa)
1727  (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Open" IPaddress) ipa)))
1728
1729(define (sdl-net-tcp-accept serv)
1730  (-sdl-register-socket ((foreign-lambda TCPsocket "SDLNet_TCP_Accept" TCPsocket) serv)))
1731
1732(define (sdl-net-tcp-get-peer-address sock)
1733  (let ((ipa (make-sdl-ip-address 0 0 0 0 0)))
1734    (if ((foreign-lambda* bool ((TCPsocket sock)
1735                                (IPaddress ipa))
1736                          "IPaddress *result = SDLNet_TCP_GetPeerAddress(sock);"
1737                          "if (result != NULL) {"
1738                          "  *ipa = *result;"
1739                          "  C_return(1);"
1740                          "} else {"
1741                          "  C_return(0);"
1742                          "}")
1743         sock ipa)
1744        ipa
1745        #f)))
1746
1747(define (sdl-net-tcp-send sock bv)
1748  ((foreign-lambda int "SDLNet_TCP_Send" TCPsocket blob integer)
1749   sock bv (blob-size bv)))
1750
1751(define sdl-net-tcp-recv (foreign-lambda int "SDLNet_TCP_Recv" TCPsocket blob integer))
1752
1753(define (sdl-net-tcp-close sock)
1754  (if (sdl-tcp-socket-pointer sock)
1755      (begin
1756        ((foreign-lambda void "SDLNet_TCP_Close" TCPsocket) sock)
1757        (sdl-tcp-socket-pointer-set! sock #f))))
1758
1759(define (sdl-net-tcp-send-string sock str)
1760  (sdl-net-tcp-send sock (string->blob str)))
1761
1762(define (sdl-net-tcp-recv-string sock buflen)
1763  (let* ((bv (make-blob buflen))
1764         (result (sdl-net-tcp-recv sock bv buflen)))
1765    (if (positive? result)
1766        (substring (blob->string bv) 0 result)
1767        result)))
1768
1769;---------------------------------------------------------------------------
1770
1771(define-record sdl-net-socket-set pointer)
1772
1773(define-record-printer (sdl-net-socket-set s out)
1774  (for-each (lambda (x) (display x out))
1775            (list "#<sdl-net-socket-set "(sdl-net-socket-set-pointer s)">")))
1776
1777(define-foreign-type SDLNet_SocketSet (c-pointer (struct "_SDLNet_SocketSet"))
1778  sdl-net-socket-set-pointer
1779  (pointer-to-record-lambda sdl-net-socket-set))
1780
1781;---------------------------------------------------------------------------
1782
1783(define sdl-net-alloc-socket-set (foreign-lambda SDLNet_SocketSet "SDLNet_AllocSocketSet" int))
1784(define sdl-net-free-socket-set (foreign-lambda void "SDLNet_FreeSocketSet" SDLNet_SocketSet))
1785
1786(define sdl-net-tcp-add-socket!
1787  (foreign-lambda int "SDLNet_TCP_AddSocket" SDLNet_SocketSet TCPsocket))
1788
1789(define sdl-net-tcp-del-socket!
1790  (foreign-lambda int "SDLNet_TCP_DelSocket" SDLNet_SocketSet TCPsocket))
1791
1792(define (sdl-net-check-sockets socket-set timeout) ;; timeout in milliseconds
1793  (let ((result ((foreign-lambda int "SDLNet_CheckSockets" SDLNet_SocketSet unsigned-integer)
1794                 socket-set timeout)))
1795    (if (= result -1)
1796        #f
1797        result)))
1798
1799(define sdl-net-socket-ready? (foreign-lambda bool "SDLNet_SocketReady" TCPsocket))
1800
1801;---------------------------------------------------------------------------
1802
1803(define sdl-net-write-16
1804  (foreign-lambda* void ((blob bv)
1805                         (int offset)
1806                         (unsigned-short value))
1807                   "SDLNet_Write16(value, &bv[offset]);"))
1808
1809(define sdl-net-write-32
1810  (foreign-lambda* void ((blob bv)
1811                         (int offset)
1812                         (unsigned-integer value))
1813                   "SDLNet_Write32(value, &bv[offset]);"))
1814
1815(define sdl-net-read-16
1816  (foreign-lambda* unsigned-short ((blob bv)
1817                                   (int offset))
1818                   "C_return(SDLNet_Read16(&bv[offset]));"))
1819
1820(define sdl-net-read-32
1821  (foreign-lambda* unsigned-integer ((blob bv)
1822                                     (int offset))
1823                   "C_return(SDLNet_Read32(&bv[offset]));"))
1824
1825)
Note: See TracBrowser for help on using the repository browser.