Changeset 27338 in project
- Timestamp:
- 08/30/12 12:26:35 (9 years ago)
- Location:
- release/4/sdl-img/trunk
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/sdl-img/trunk/sdl-img.meta
r27336 r27338 1 ;;; sdl.meta -*- Hen-*-1 ;;; sdl.meta -*- scheme -*- 2 2 3 3 ((category graphics) 4 4 (author "Tony Garnock-Jones") 5 (synopsis " Basic SDLsupport")5 (synopsis "SDL_Img support") 6 6 (license "LGPL-2.1") 7 7 (doc-from-wiki) 8 (egg "sdl.egg") 9 (files "COPYING" "Makefile" "timer.scm" "sdl.release-info" "test-sdl-body.scm" "sdl-csi.scm" "test-heap.scm" "sdl.meta" "sdl.scm" "heap.scm" "test-net.scm" "sdl.setup" "unknown2-scale8.jpg" "test-sdl.scm")) 8 (egg "sdl-img.egg") 9 (files "sdl-img.meta" 10 "sdl-img.scm" 11 "sdl-img.setup")) -
release/4/sdl-img/trunk/sdl-img.scm
r27336 r27338 19 19 ; --------------------------------------------------------------------------- 20 20 21 (module sdl 21 (module sdl-img 22 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 23 ( ; SDL image 185 24 img-init 186 25 img-quit 187 26 img-load 188 rotozoom-surface189 zoom-surface190 27 191 ;SDL net192 make-sdl-ip-address193 sdl-ip-address?194 sdl-ip-address-a195 sdl-ip-address-b196 sdl-ip-address-c197 sdl-ip-address-d198 sdl-ip-address-port199 sdl-net-init200 sdl-net-quit201 sdl-net-resolve-host!202 sdl-net-resolve-ip203 sdl-net-resolve-host204 make-sdl-tcp-socket205 sdl-tcp-socket?206 sdl-net-tcp-open207 sdl-net-tcp-accept208 sdl-net-tcp-get-peer-address209 sdl-net-tcp-send210 sdl-net-tcp-recv211 sdl-net-tcp-close212 sdl-net-tcp-send-string213 sdl-net-tcp-recv-string214 sdl-net-tcp-add-socket!215 sdl-net-tcp-del-socket!216 sdl-net-check-sockets217 sdl-net-socket-ready?218 sdl-net-socket-set?219 sdl-net-socket-set-pointer-set!220 sdl-net-write-16221 sdl-net-write-32222 sdl-net-read-16223 sdl-net-read-32224 225 sdl-event?226 sdl-event-gain227 set-sdl-event-gain!228 sdl-event-which229 set-sdl-event-which!230 sdl-event-state231 set-sdl-event-state!232 sdl-event-scancode233 set-sdl-event-scancode!234 sdl-event-sym235 set-sdl-event-sym!236 sdl-event-mod237 set-sdl-event-mod!238 sdl-event-unicode239 set-sdl-event-unicode!240 sdl-event-x241 set-sdl-event-x!242 sdl-event-y243 set-sdl-event-y!244 sdl-event-xrel245 set-sdl-event-xrel!246 sdl-event-yrel247 set-sdl-event-yrel!248 sdl-event-axis249 set-sdl-event-axis!250 sdl-event-ball251 set-sdl-event-ball!252 sdl-event-hat253 set-sdl-event-hat!254 sdl-event-value255 set-sdl-event-value!256 sdl-event-button257 set-sdl-event-button!258 sdl-event-w259 set-sdl-event-w!260 sdl-event-h261 set-sdl-event-h!262 sdl-event-buffer-set!263 heap?264 265 266 ; constants267 268 SDL_INIT_TIMER269 SDL_INIT_AUDIO270 SDL_INIT_VIDEO271 SDL_INIT_CDROM272 SDL_INIT_JOYSTICK273 SDL_INIT_EVERYTHING274 SDL_INIT_NOPARACHUTE275 276 ;; For sdl-creatergbsurface or sdl-setvideomode277 SDL_SWSURFACE278 SDL_HWSURFACE279 SDL_ASYNCBLIT280 ;; For sdl-setvideomode281 SDL_ANYFORMAT282 SDL_HWPALETTE283 SDL_DOUBLEBUF284 SDL_FULLSCREEN285 SDL_OPENGL286 SDL_OPENGLBLIT287 SDL_RESIZABLE288 SDL_NOFRAME289 ;; Read-only - internal290 SDL_HWACCEL291 SDL_SRCCOLORKEY292 SDL_RLEACCELOK293 SDL_RLEACCEL294 SDL_SRCALPHA295 SDL_PREALLOC296 297 SDL_BYTEORDER298 SDL_LIL_ENDIAN299 SDL_BIG_ENDIAN300 301 ;; For sdl-wm-grabinput302 SDL_GRAB_QUERY303 SDL_GRAB_OFF304 SDL_GRAB_ON305 306 307 SDL_NOEVENT ; Unused (do not remove)308 SDL_ACTIVEEVENT ; Application loses/gains visibility309 SDL_APPMOUSEFOCUS ; Mouse focus gained/lost310 SDL_APPINPUTFOCUS ; Input focus gained/lost311 SDL_APPACTIVE ; Application iconified/restored312 SDL_KEYDOWN ; Keys pressed313 SDL_KEYUP ; Keys released314 SDL_MOUSEMOTION ; Mouse moved315 SDL_MOUSEBUTTONDOWN ; Mouse button pressed316 SDL_MOUSEBUTTONUP ; Mouse button released317 SDL_JOYAXISMOTION ; Joystick axis motion318 SDL_JOYBALLMOTION ; Joystick trackball motion319 SDL_JOYHATMOTION ; Joystick hat position change320 SDL_JOYBUTTONDOWN ; Joystick button pressed321 SDL_JOYBUTTONUP ; Joystick button released322 SDL_QUIT ; User-requested quit323 SDL_SYSWMEVENT ; System specific event324 SDL_EVENT_RESERVEDA ; Reserved for future use..325 SDL_EVENT_RESERVEDB ; Reserved for future use..326 SDL_VIDEORESIZE ; User resized video mode327 SDL_VIDEOEXPOSE ; Screen needs to be redrawn328 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 use335 SDL_NUMEVENTS336 337 SDL_ACTIVEEVENTMASK338 SDL_KEYDOWNMASK339 SDL_KEYUPMASK340 SDL_MOUSEMOTIONMASK341 SDL_MOUSEBUTTONDOWNMASK342 SDL_MOUSEBUTTONUPMASK343 SDL_MOUSEEVENTMASK344 SDL_JOYAXISMOTIONMASK345 SDL_JOYBALLMOTIONMASK346 SDL_JOYHATMOTIONMASK347 SDL_JOYBUTTONDOWNMASK348 SDL_JOYBUTTONUPMASK349 SDL_JOYEVENTMASK350 SDL_VIDEORESIZEMASK351 SDL_VIDEOEXPOSEMASK352 SDL_QUITMASK353 SDL_SYSWMEVENTMASK354 SDL_ALLEVENTS355 ; General button/key states356 SDL_PRESSED357 SDL_RELEASED358 ; Mouse button states359 SDL_BUTTON_LEFT360 SDL_BUTTON_MIDDLE361 SDL_BUTTON_RIGHT362 SDL_BUTTON_WHEELUP363 SDL_BUTTON_WHEELDOWN364 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_QUERY368 SDL_IGNORE369 SDL_DISABLE370 SDL_ENABLE371 372 SDL_GL_RED_SIZE373 SDL_GL_GREEN_SIZE374 SDL_GL_BLUE_SIZE375 SDL_GL_ALPHA_SIZE376 SDL_GL_BUFFER_SIZE377 SDL_GL_DOUBLEBUFFER378 SDL_GL_DEPTH_SIZE379 SDL_GL_STENCIL_SIZE380 SDL_GL_ACCUM_RED_SIZE381 SDL_GL_ACCUM_GREEN_SIZE382 SDL_GL_ACCUM_BLUE_SIZE383 SDL_GL_ACCUM_ALPHA_SIZE384 SDL_GL_STEREO385 SDL_GL_MULTISAMPLEBUFFERS386 SDL_GL_MULTISAMPLESAMPLES387 SDL_GL_SWAP_CONTROL388 SDL_GL_ACCELERATED_VISUAL389 390 TTF_STYLE_NORMAL391 TTF_STYLE_BOLD392 TTF_STYLE_ITALIC393 TTF_STYLE_UNDERLINE394 395 ;; SDL_image396 28 IMG_INIT_JPG 397 29 IMG_INIT_PNG 398 30 IMG_INIT_TIF 399 400 ;; scancodes401 402 SDLK_UNKNOWN403 SDLK_FIRST404 SDLK_BACKSPACE405 SDLK_TAB406 SDLK_CLEAR407 SDLK_RETURN408 SDLK_PAUSE409 SDLK_ESCAPE410 SDLK_SPACE411 SDLK_EXCLAIM412 SDLK_QUOTEDBL413 SDLK_HASH414 SDLK_DOLLAR415 SDLK_AMPERSAND416 SDLK_QUOTE417 SDLK_LEFTPAREN418 SDLK_RIGHTPAREN419 SDLK_ASTERISK420 SDLK_PLUS421 SDLK_COMMA422 SDLK_MINUS423 SDLK_PERIOD424 SDLK_SLASH425 SDLK_0426 SDLK_1427 SDLK_2428 SDLK_3429 SDLK_4430 SDLK_5431 SDLK_6432 SDLK_7433 SDLK_8434 SDLK_9435 SDLK_COLON436 SDLK_SEMICOLON437 SDLK_LESS438 SDLK_EQUALS439 SDLK_GREATER440 SDLK_QUESTION441 SDLK_AT442 SDLK_LEFTBRACKET443 SDLK_BACKSLASH444 SDLK_RIGHTBRACKET445 SDLK_CARET446 SDLK_UNDERSCORE447 SDLK_BACKQUOTE448 SDLK_a449 SDLK_b450 SDLK_c451 SDLK_d452 SDLK_e453 SDLK_f454 SDLK_g455 SDLK_h456 SDLK_i457 SDLK_j458 SDLK_k459 SDLK_l460 SDLK_m461 SDLK_n462 SDLK_o463 SDLK_p464 SDLK_q465 SDLK_r466 SDLK_s467 SDLK_t468 SDLK_u469 SDLK_v470 SDLK_w471 SDLK_x472 SDLK_y473 SDLK_z474 SDLK_DELETE475 SDLK_WORLD_0476 SDLK_WORLD_1477 SDLK_WORLD_2478 SDLK_WORLD_3479 SDLK_WORLD_4480 SDLK_WORLD_5481 SDLK_WORLD_6482 SDLK_WORLD_7483 SDLK_WORLD_8484 SDLK_WORLD_9485 SDLK_WORLD_10486 SDLK_WORLD_11487 SDLK_WORLD_12488 SDLK_WORLD_13489 SDLK_WORLD_14490 SDLK_WORLD_15491 SDLK_WORLD_16492 SDLK_WORLD_17493 SDLK_WORLD_18494 SDLK_WORLD_19495 SDLK_WORLD_20496 SDLK_WORLD_21497 SDLK_WORLD_22498 SDLK_WORLD_23499 SDLK_WORLD_24500 SDLK_WORLD_25501 SDLK_WORLD_26502 SDLK_WORLD_27503 SDLK_WORLD_28504 SDLK_WORLD_29505 SDLK_WORLD_30506 SDLK_WORLD_31507 SDLK_WORLD_32508 SDLK_WORLD_33509 SDLK_WORLD_34510 SDLK_WORLD_35511 SDLK_WORLD_36512 SDLK_WORLD_37513 SDLK_WORLD_38514 SDLK_WORLD_39515 SDLK_WORLD_40516 SDLK_WORLD_41517 SDLK_WORLD_42518 SDLK_WORLD_43519 SDLK_WORLD_44520 SDLK_WORLD_45521 SDLK_WORLD_46522 SDLK_WORLD_47523 SDLK_WORLD_48524 SDLK_WORLD_49525 SDLK_WORLD_50526 SDLK_WORLD_51527 SDLK_WORLD_52528 SDLK_WORLD_53529 SDLK_WORLD_54530 SDLK_WORLD_55531 SDLK_WORLD_56532 SDLK_WORLD_57533 SDLK_WORLD_58534 SDLK_WORLD_59535 SDLK_WORLD_60536 SDLK_WORLD_61537 SDLK_WORLD_62538 SDLK_WORLD_63539 SDLK_WORLD_64540 SDLK_WORLD_65541 SDLK_WORLD_66542 SDLK_WORLD_67543 SDLK_WORLD_68544 SDLK_WORLD_69545 SDLK_WORLD_70546 SDLK_WORLD_71547 SDLK_WORLD_72548 SDLK_WORLD_73549 SDLK_WORLD_74550 SDLK_WORLD_75551 SDLK_WORLD_76552 SDLK_WORLD_77553 SDLK_WORLD_78554 SDLK_WORLD_79555 SDLK_WORLD_80556 SDLK_WORLD_81557 SDLK_WORLD_82558 SDLK_WORLD_83559 SDLK_WORLD_84560 SDLK_WORLD_85561 SDLK_WORLD_86562 SDLK_WORLD_87563 SDLK_WORLD_88564 SDLK_WORLD_89565 SDLK_WORLD_90566 SDLK_WORLD_91567 SDLK_WORLD_92568 SDLK_WORLD_93569 SDLK_WORLD_94570 SDLK_WORLD_95571 SDLK_KP0572 SDLK_KP1573 SDLK_KP2574 SDLK_KP3575 SDLK_KP4576 SDLK_KP5577 SDLK_KP6578 SDLK_KP7579 SDLK_KP8580 SDLK_KP9581 SDLK_KP_PERIOD582 SDLK_KP_DIVIDE583 SDLK_KP_MULTIPLY584 SDLK_KP_MINUS585 SDLK_KP_PLUS586 SDLK_KP_ENTER587 SDLK_KP_EQUALS588 SDLK_UP589 SDLK_DOWN590 SDLK_RIGHT591 SDLK_LEFT592 SDLK_INSERT593 SDLK_HOME594 SDLK_END595 SDLK_PAGEUP596 SDLK_PAGEDOWN597 SDLK_F1598 SDLK_F2599 SDLK_F3600 SDLK_F4601 SDLK_F5602 SDLK_F6603 SDLK_F7604 SDLK_F8605 SDLK_F9606 SDLK_F10607 SDLK_F11608 SDLK_F12609 SDLK_F13610 SDLK_F14611 SDLK_F15612 SDLK_NUMLOCK613 SDLK_CAPSLOCK614 SDLK_SCROLLOCK615 SDLK_RSHIFT616 SDLK_LSHIFT617 SDLK_RCTRL618 SDLK_LCTRL619 SDLK_RALT620 SDLK_LALT621 SDLK_RMETA622 SDLK_LMETA623 SDLK_LSUPER624 SDLK_RSUPER625 SDLK_MODE626 SDLK_COMPOSE627 SDLK_HELP628 SDLK_PRINT629 SDLK_SYSREQ630 SDLK_BREAK631 SDLK_MENU632 SDLK_POWER633 SDLK_EURO634 SDLK_UNDO635 636 31 ) 637 32 … … 639 34 640 35 (import chicken scheme foreign) 641 (use srfi-1)642 (use srfi-4)643 (use srfi-13)644 (use srfi-18)645 36 (use lolevel) 37 (use sdl-base) 646 38 647 39 (foreign-declare #<<EOF 648 40 649 #ifdef _WIN32650 # if _MSC_VER > 1300651 # include <winsock2.h>652 # include <ws2tcpip.h>653 # else654 # include <winsock.h>655 # endif656 #else657 # include <netinet/in.h>658 #endif659 660 #include <sys/time.h>661 662 #include "SDL.h"663 #include "SDL_ttf.h"664 41 #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 42 672 43 EOF 673 44 ) 674 45 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 in683 ;; one day.684 (define *sdl-egg-version* '(0 5 91025 0))685 46 686 47 ;--------------------------------------------------------------------------- … … 696 57 (cdr e))))) 697 58 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) 59 (include "sdl-base-foreign-types-include.scm") 706 60 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-flags720 ;; For sdl-creatergbsurface or sdl-setvideomode721 "SDL_SWSURFACE"722 "SDL_HWSURFACE"723 "SDL_ASYNCBLIT"724 ;; For sdl-setvideomode725 "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 - internal734 "SDL_HWACCEL"735 "SDL_SRCCOLORKEY"736 "SDL_RLEACCELOK"737 "SDL_RLEACCEL"738 "SDL_SRCALPHA"739 "SDL_PREALLOC"740 )741 742 (--sdl-flags743 "SDL_BYTEORDER"744 "SDL_LIL_ENDIAN"745 "SDL_BIG_ENDIAN")746 747 ; For sdl-wm-grabinput748 (--sdl-flags "SDL_GRAB_QUERY"749 "SDL_GRAB_OFF"750 "SDL_GRAB_ON")751 752 (--sdl-flags753 "SDL_NOEVENT" ; Unused (do not remove)754 "SDL_ACTIVEEVENT" ; Application loses/gains visibility755 "SDL_APPMOUSEFOCUS" ; Mouse focus gained/lost756 "SDL_APPINPUTFOCUS" ; Input focus gained/lost757 "SDL_APPACTIVE" ; Application iconified/restored758 "SDL_KEYDOWN" ; Keys pressed759 "SDL_KEYUP" ; Keys released760 "SDL_MOUSEMOTION" ; Mouse moved761 "SDL_MOUSEBUTTONDOWN" ; Mouse button pressed762 "SDL_MOUSEBUTTONUP" ; Mouse button released763 "SDL_JOYAXISMOTION" ; Joystick axis motion764 "SDL_JOYBALLMOTION" ; Joystick trackball motion765 "SDL_JOYHATMOTION" ; Joystick hat position change766 "SDL_JOYBUTTONDOWN" ; Joystick button pressed767 "SDL_JOYBUTTONUP" ; Joystick button released768 "SDL_QUIT" ; User-requested quit769 "SDL_SYSWMEVENT" ; System specific event770 "SDL_EVENT_RESERVEDA" ; Reserved for future use..771 "SDL_EVENT_RESERVEDB" ; Reserved for future use..772 "SDL_VIDEORESIZE" ; User resized video mode773 "SDL_VIDEOEXPOSE" ; Screen needs to be redrawn774 "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 use781 "SDL_NUMEVENTS"782 )783 784 (--sdl-flags785 "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 states806 (--sdl-flags807 "SDL_PRESSED"808 "SDL_RELEASED")809 810 ;; SDL_image constants811 61 (--sdl-flags 812 62 "IMG_INIT_JPG" 813 63 "IMG_INIT_PNG" 814 64 "IMG_INIT_TIF") 815 816 ; Mouse button states817 818 ; The macro SDL_BUTTON is parameterised, so we have to recreate it as819 ; a function820 821 (define (SDL_BUTTON x)822 (arithmetic-shift SDL_PRESSED (- x 1)))823 824 (--sdl-flags825 "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-eventstate836 (--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-major852 (foreign-lambda* unsigned-byte ((SDL_version v))853 "C_return(v->major);"))854 855 (define sdl-version-minor856 (foreign-lambda* unsigned-byte ((SDL_version v))857 "C_return(v->minor);"))858 859 (define sdl-version-patch860 (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 the864 ;; arguments indicate.865 (define (sdl-version-at-least sdl-version major minor patch)866 (cond867 ((> (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-version875 (foreign-lambda* SDL_version ()876 "SDL_version v; SDL_VERSION(&v); C_return(&v);"))877 878 (define sdl-linked-version879 (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-rect887 (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-pixel920 (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))921 "C_return(pf->BytesPerPixel);"))922 923 (define sdl-pixel-format-rmask924 (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))925 "C_return(pf->Rmask);"))926 (define sdl-pixel-format-gmask927 (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))928 "C_return(pf->Gmask);"))929 (define sdl-pixel-format-bmask930 (foreign-lambda* unsigned-byte ((SDL_PixelFormat pf))931 "C_return(pf->Bmask);"))932 (define sdl-pixel-format-amask933 (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 by967 ;; sdl-surface-pixels.968 (define (sdl-surface-pixels-length s)969 (* (sdl-surface-height s)970 (sdl-surface-pitch s)))971 972 ;;973 ;; SDL_VideoInfo974 ;;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-available995 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))996 "C_return(vi->hw_available);"))997 (define sdl-video-info-wm-available998 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))999 "C_return(vi->wm_available);"))1000 (define sdl-video-info-blit-hw1001 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1002 "C_return(vi->blit_hw);"))1003 (define sdl-video-info-blit-hw-cc1004 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1005 "C_return(vi->blit_hw_CC);"))1006 (define sdl-video-info-blit-hw-a1007 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1008 "C_return(vi->blit_hw_A);"))1009 (define sdl-video-info-blit-sw1010 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1011 "C_return(vi->blit_sw);"))1012 (define sdl-video-info-blit-sw-cc1013 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1014 "C_return(vi->blit_sw_CC);"))1015 (define sdl-video-info-blit-sw-a1016 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1017 "C_return(vi->blit_sw_A);"))1018 (define sdl-video-info-blit-fill1019 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1020 "C_return(vi->blit_fill);"))1021 (define sdl-video-info-video-mem1022 (foreign-lambda* unsigned-integer ((SDL_VideoInfo vi))1023 "C_return(vi->video_mem);"))1024 (define sdl-video-info-vfmt1025 (foreign-lambda* SDL_PixelFormat ((SDL_VideoInfo vi))1026 "C_return(vi->vfmt);"))1027 (define sdl-video-info-current-w1028 (foreign-lambda* integer ((SDL_VideoInfo vi))1029 "C_return(vi->current_w);"))1030 (define sdl-video-info-current-h1031 (foreign-lambda* integer ((SDL_VideoInfo vi))1032 "C_return(vi->current_h);"))1033 1034 (define sdl-get-video-info1035 (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-format1056 (foreign-lambda SDL_Surface "SDL_DisplayFormat" SDL_Surface))1057 (define sdl-display-format-alpha1058 (foreign-lambda SDL_Surface "SDL_DisplayFormatAlpha" SDL_Surface))1059 (define sdl-convert-surface1060 (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 a1065 ;; dynamically-loaded extension. Something internal to Quartz seems to1066 ;; get confused. You must call SDL_Init *directly* from your main1067 ;; program - if your main program is written in Scheme, you need to1068 ;; 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' and1077 ;; '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-expand1135 (mingw321136 (define get-time-of-day current-seconds))1137 (else1138 (define get-time-of-day1139 (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-event1157 (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-setter1170 (lambda (f r c)1171 (let ((name (cadr f))1172 (rest (cddr f)))1173 (let* ((strapp (lambda s (apply string-append1174 (map (lambda (x) (cond1175 ((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 we1276 ;; have trouble with setitimer and chicken - see the README - we1277 ;; reimplement (sdl-wait-event!) here calling out to our timer queue1278 ;; 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-result1288 ((-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 the1303 ;; 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 state1316 (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 01333 (string-index (blob->string bv)1334 (integer->char 0))))))1335 1336 (define sdl-set-video-mode (foreign-lambda SDL_Surface "SDL_SetVideoMode"1337 integer ; width1338 integer ; height1339 integer ; bpp1340 unsigned-integer ; flags1341 ))1342 1343 (define (sdl-video-mode-ok w h bpp flags)1344 (let ((result ((foreign-lambda integer "SDL_VideoModeOK"1345 integer integer1346 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_PixelFormat1358 unsigned-byte1359 unsigned-byte1360 unsigned-byte))1361 1362 (define sdl-map-rgba (foreign-lambda unsigned-integer "SDL_MapRGBA"1363 SDL_PixelFormat1364 unsigned-byte1365 unsigned-byte1366 unsigned-byte1367 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 ; flags1387 integer ; width1388 integer ; height1389 integer ; depth1390 unsigned-integer ; rmask1391 unsigned-integer ; gmask1392 unsigned-integer ; bmask1393 unsigned-integer)) ; amask1394 (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, srcrect1400 SDL_Surface SDL_Rect)) ; dst, dstrect1401 1402 (define (sdl-with-clip-rect s r thunk)1403 (let ((orig-clip-rect (make-sdl-rect 0 0 0 0)))1404 (dynamic-wind1405 (lambda ()1406 (sdl-get-clip-rect! s orig-clip-rect)1407 (sdl-set-clip-rect! s r))1408 thunk1409 (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-color1418 (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-char1467 "SDL_JoystickGetButton"1468 SDL_Joystick int))1469 ;TODO: sdl-joystick-get-ball1470 (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-attribute1499 (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-pointer1515 (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-version1524 (foreign-lambda* SDL_version ()1525 "SDL_version v; SDL_TTF_VERSION(&v); C_return(&v);"))1526 (define ttf-linked-version1527 (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 (begin1534 ((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-shaded1584 (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-shaded1590 (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-shaded1596 (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 65 1615 66 ;--------------------------------------------------------------------------- … … 1619 70 (define img-load (foreign-lambda SDL_Surface "IMG_Load" c-string)) 1620 71 1621 ;---------------------------------------------------------------------------1622 1623 (define rotozoom-surface (foreign-lambda SDL_Surface "rotozoomSurface"1624 SDL_Surface ; src1625 double ; angle1626 double ; zoom1627 bool)) ; smooth1628 1629 (define zoom-surface (foreign-lambda SDL_Surface "zoomSurface"1630 SDL_Surface ; src1631 double ; zoomx1632 double ; zoomy1633 bool)) ; smooth1634 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-address1642 (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 bv1652 (+ (* 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-a1677 (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[0]);"))1678 (define sdl-ip-address-b1679 (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[1]);"))1680 (define sdl-ip-address-c1681 (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[2]);"))1682 (define sdl-ip-address-d1683 (foreign-lambda* unsigned-byte ((IPaddress a)) "C_return(((char *)&(a->host))[3]);"))1684 1685 (define sdl-ip-address-port1686 (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-pointer1703 (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 sock1722 (begin1723 (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 ipa1745 #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 (begin1756 ((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-pointer1779 (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 milliseconds1793 (let ((result ((foreign-lambda int "SDLNet_CheckSockets" SDLNet_SocketSet unsigned-integer)1794 socket-set timeout)))1795 (if (= result -1)1796 #f1797 result)))1798 1799 (define sdl-net-socket-ready? (foreign-lambda bool "SDLNet_SocketReady" TCPsocket))1800 1801 ;---------------------------------------------------------------------------1802 1803 (define sdl-net-write-161804 (foreign-lambda* void ((blob bv)1805 (int offset)1806 (unsigned-short value))1807 "SDLNet_Write16(value, &bv[offset]);"))1808 1809 (define sdl-net-write-321810 (foreign-lambda* void ((blob bv)1811 (int offset)1812 (unsigned-integer value))1813 "SDLNet_Write32(value, &bv[offset]);"))1814 1815 (define sdl-net-read-161816 (foreign-lambda* unsigned-short ((blob bv)1817 (int offset))1818 "C_return(SDLNet_Read16(&bv[offset]));"))1819 1820 (define sdl-net-read-321821 (foreign-lambda* unsigned-integer ((blob bv)1822 (int offset))1823 "C_return(SDLNet_Read32(&bv[offset]));"))1824 1825 72 ) -
release/4/sdl-img/trunk/sdl-img.setup
r27336 r27338 1 1 ;;;; sdl.setup -*- Scheme -*- 2 3 4 (define (check-depends)5 6 (let* ((lib-fun-pack '(("SDL" "SDL_Init" "libsdl1.2-dev")7 ("SDL_gfx" "polygonColor" "libsdl-gfx1.2-dev")8 ("SDL_net" "SDLNet_Init" "libsdl-net1.2-dev")9 ("SDL_ttf" "TTF_Init" "libsdl-ttf2.0-dev")10 ("SDL_image" "IMG_Init" "libsdl-image1.2-dev")))11 (missing (filter (lambda (lib-fun)12 (not (find-library (first lib-fun) (second lib-fun))))13 lib-fun-pack)))14 (for-each15 (lambda (lib-fun)16 (print "\nWARNING: You seem to be missing the library " (first lib-fun) "!"))17 missing)18 (cond-expand19 (linux20 (unless (null? missing)21 (print "\nSuggested package(s) to install: " (map third missing))))22 (else #f))))23 24 (check-depends)25 2 26 3 (let* ((escape-flags (lambda (fs) … … 36 13 (with-input-from-pipe "sdl-config --cflags" read-line)))) 37 14 (sdl-lflags (apply string-append 38 ;; sdl-config doesn't give these 39 " -lSDL_gfx -lSDL_net -lSDL_ttf -lSDL_image" 15 " -lSDL_image" 40 16 (escape-flags 41 17 (with-input-from-pipe "sdl-config --libs" read-line)))) 42 18 (types? (version>=? (chicken-version) "4.7.4")) 43 (files (append '("sdl.so" 44 "sdl.import.so" 45 "sdl-foreign-types-include.scm") 46 (if types? '("sdl.types") '())))) 47 (compile ,@(if types? '(-emit-type-file sdl.types) '()) 48 -s -O3 -d1 sdl.scm -j sdl -lSDL ,sdl-cflags ,sdl-lflags) 49 (compile -s -O3 -d0 sdl.import.scm ,sdl-cflags ,sdl-lflags) 19 (files (append '("sdl-img.so" 20 "sdl-img.import.so") 21 (if types? '("sdl-img.types") '())))) 22 (compile ,@(if types? '(-emit-type-file sdl-img.types) '()) 23 -v -s -O3 -d1 24 -I ,(repository-path) 25 sdl-img.scm -j sdl-img ,sdl-cflags ,sdl-lflags) 26 (compile -s -O3 -d0 sdl-img.import.scm ,sdl-cflags ,sdl-lflags) 50 27 51 (install-extension 'sdl files '((version "0.5.5"))))28 (install-extension 'sdl-img files '((version "0.1")))) 52 29
Note: See TracChangeset
for help on using the changeset viewer.