Artifact 9164e688a1f46e88936ae4ffb632f94100a19ca2:
- File sdl2/init.ss — part of check-in [af432e7ef4] at 2016-11-08 16:17:36 on branch trunk — fixed bug in sdl-library-init (user: aldo size: 2119)
0000: 0a 20 28 64 65 66 69 6e 65 20 28 73 64 6c 2d 6c . (define (sdl-l 0010: 69 62 72 61 72 79 2d 69 6e 69 74 20 2e 20 6c 29 ibrary-init . l) 0020: 20 20 0a 0a 20 20 20 23 3b 28 69 6d 70 6f 72 74 .. #;(import 0030: 20 28 6f 6e 6c 79 20 28 73 64 6c 32 20 76 69 64 (only (sdl2 vid 0040: 65 6f 29 20 73 64 6c 2d 77 69 6e 64 6f 77 2d 74 eo) sdl-window-t 0050: 20 73 64 6c 2d 64 65 73 74 72 6f 79 2d 77 69 6e sdl-destroy-win 0060: 64 6f 77 29 0a 09 20 20 20 28 6f 6e 6c 79 20 28 dow).. (only ( 0070: 73 64 6c 32 20 73 75 72 66 61 63 65 29 20 73 64 sdl2 surface) sd 0080: 6c 2d 73 75 72 66 61 63 65 2d 74 20 73 64 6c 2d l-surface-t sdl- 0090: 66 72 65 65 2d 73 75 72 66 61 63 65 29 0a 09 20 free-surface).. 00a0: 20 20 28 6f 6e 6c 79 20 28 73 64 6c 32 20 72 65 (only (sdl2 re 00b0: 6e 64 65 72 29 20 73 64 6c 2d 74 65 78 74 75 72 nder) sdl-textur 00c0: 65 2d 74 20 73 64 6c 2d 64 65 73 74 72 6f 79 2d e-t sdl-destroy- 00d0: 74 65 78 74 75 72 65 20 73 64 6c 2d 72 65 6e 64 texture sdl-rend 00e0: 65 72 65 72 2d 74 20 73 64 6c 2d 64 65 73 74 72 erer-t sdl-destr 00f0: 6f 79 2d 72 65 6e 64 65 72 65 72 29 0a 09 20 20 oy-renderer).. 0100: 20 28 6f 6e 6c 79 20 28 73 64 6c 32 20 6d 75 74 (only (sdl2 mut 0110: 65 78 29 20 73 64 6c 2d 6d 75 74 65 78 2d 74 20 ex) sdl-mutex-t 0120: 73 64 6c 2d 64 65 73 74 72 6f 79 2d 6d 75 74 65 sdl-destroy-mute 0130: 78 20 73 64 6c 2d 63 6f 6e 64 2d 74 20 73 64 6c x sdl-cond-t sdl 0140: 2d 64 65 73 74 72 6f 79 2d 63 6f 6e 64 29 0a 09 -destroy-cond).. 0150: 20 20 20 28 6f 6e 6c 79 20 28 73 64 6c 32 20 6d (only (sdl2 m 0160: 6f 75 73 65 29 20 73 64 6c 2d 63 75 72 73 6f 72 ouse) sdl-cursor 0170: 2d 74 20 73 64 6c 2d 66 72 65 65 2d 63 75 72 73 -t sdl-free-curs 0180: 6f 72 29 0a 09 20 20 20 28 6f 6e 6c 79 20 28 73 or).. (only (s 0190: 64 6c 32 20 70 69 78 65 6c 73 29 20 73 64 6c 2d dl2 pixels) sdl- 01a0: 70 69 78 65 6c 2d 66 6f 72 6d 61 74 2d 74 20 73 pixel-format-t s 01b0: 64 6c 2d 66 72 65 65 2d 66 6f 72 6d 61 74 20 73 dl-free-format s 01c0: 64 6c 2d 70 61 6c 65 74 74 65 2d 74 20 73 64 6c dl-palette-t sdl 01d0: 2d 66 72 65 65 2d 70 61 6c 65 74 74 65 29 0a 09 -free-palette).. 01e0: 20 20 20 28 6f 6e 6c 79 20 28 73 64 6c 32 20 72 (only (sdl2 r 01f0: 77 6f 70 73 29 20 73 64 6c 2d 72 77 2d 6f 70 73 wops) sdl-rw-ops 0200: 2d 74 20 73 64 6c 2d 66 72 65 65 2d 72 77 29 09 -t sdl-free-rw). 0210: 20 20 20 0a 09 20 20 20 28 6f 6e 6c 79 20 28 73 .. (only (s 0220: 64 6c 32 20 67 75 61 72 64 69 61 6e 29 20 73 64 dl2 guardian) sd 0230: 6c 2d 67 75 61 72 64 69 61 6e 20 73 64 6c 2d 66 l-guardian sdl-f 0240: 72 65 65 2d 67 61 72 62 61 67 65 29 29 0a 20 20 ree-garbage)). 0250: 20 28 6c 6f 61 64 2d 73 68 61 72 65 64 2d 6f 62 (load-shared-ob 0260: 6a 65 63 74 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ject (if (null? 0270: 6c 29 20 22 6c 69 62 53 44 4c 32 2e 73 6f 22 20 l) "libSDL2.so" 0280: 28 63 61 72 20 6c 29 29 29 0a 20 20 20 28 73 64 (car l))). (sd 0290: 6c 2d 66 72 65 65 2d 67 61 72 62 61 67 65 2d 73 l-free-garbage-s 02a0: 65 74 2d 66 75 6e 63 0a 09 20 28 6c 61 6d 62 64 et-func.. (lambd 02b0: 61 20 28 29 0a 09 20 20 20 28 6c 65 74 20 6c 6f a ().. (let lo 02c0: 6f 70 20 28 5b 70 20 28 73 64 6c 2d 67 75 61 72 op ([p (sdl-guar 02d0: 64 69 61 6e 29 5d 29 0a 09 20 20 20 20 20 28 77 dian)]).. (w 02e0: 68 65 6e 20 70 0a 09 09 20 20 20 28 77 68 65 6e hen p... (when 02f0: 20 28 66 74 79 70 65 2d 70 6f 69 6e 74 65 72 3f (ftype-pointer? 0300: 20 70 29 0a 09 09 09 20 3b 28 70 72 69 6e 74 66 p).... ;(printf 0310: 20 22 73 64 6c 2d 66 72 65 65 2d 67 61 72 62 61 "sdl-free-garba 0320: 67 65 3a 20 66 72 65 65 69 6e 67 20 6d 65 6d 6f ge: freeing memo 0330: 72 79 20 61 74 20 7e 78 5c 6e 22 20 70 29 0a 09 ry at ~x\n" p).. 0340: 09 09 20 3b 3b 5b 28 66 74 79 70 65 2d 70 6f 69 .. ;;[(ftype-poi 0350: 6e 74 65 72 3f 20 75 73 62 2d 64 65 76 69 63 65 nter? usb-device 0360: 2a 2d 61 72 72 61 79 20 70 29 0a 09 09 09 20 28 *-array p).... ( 0370: 63 6f 6e 64 20 0a 09 09 09 20 20 5b 28 66 74 79 cond .... [(fty 0380: 70 65 2d 70 6f 69 6e 74 65 72 3f 20 73 64 6c 2d pe-pointer? sdl- 0390: 77 69 6e 64 6f 77 2d 74 20 70 29 20 28 73 64 6c window-t p) (sdl 03a0: 2d 64 65 73 74 72 6f 79 2d 77 69 6e 64 6f 77 20 -destroy-window 03b0: 70 29 5d 0a 09 09 09 20 20 5b 28 66 74 79 70 65 p)].... [(ftype 03c0: 2d 70 6f 69 6e 74 65 72 3f 20 73 64 6c 2d 73 75 -pointer? sdl-su 03d0: 72 66 61 63 65 2d 74 20 70 29 20 28 73 64 6c 2d rface-t p) (sdl- 03e0: 66 72 65 65 2d 73 75 72 66 61 63 65 20 70 29 5d free-surface p)] 03f0: 0a 09 09 09 20 20 5b 28 66 74 79 70 65 2d 70 6f .... [(ftype-po 0400: 69 6e 74 65 72 3f 20 73 64 6c 2d 74 65 78 74 75 inter? sdl-textu 0410: 72 65 2d 74 20 70 29 20 28 73 64 6c 2d 64 65 73 re-t p) (sdl-des 0420: 74 72 6f 79 2d 74 65 78 74 75 72 65 20 70 29 5d troy-texture p)] 0430: 0a 09 09 09 20 20 5b 28 66 74 79 70 65 2d 70 6f .... [(ftype-po 0440: 69 6e 74 65 72 3f 20 73 64 6c 2d 72 65 6e 64 65 inter? sdl-rende 0450: 72 65 72 2d 74 20 70 29 20 28 73 64 6c 2d 64 65 rer-t p) (sdl-de 0460: 73 74 72 6f 79 2d 72 65 6e 64 65 72 65 72 20 70 stroy-renderer p 0470: 29 5d 0a 09 09 09 20 20 5b 28 66 74 79 70 65 2d )].... [(ftype- 0480: 70 6f 69 6e 74 65 72 3f 20 73 64 6c 2d 6d 75 74 pointer? sdl-mut 0490: 65 78 2d 74 20 70 29 20 28 73 64 6c 2d 64 65 73 ex-t p) (sdl-des 04a0: 74 72 6f 79 2d 6d 75 74 65 78 20 70 29 5d 09 09 troy-mutex p)].. 04b0: 09 20 0a 09 09 09 20 20 5b 28 66 74 79 70 65 2d . .... [(ftype- 04c0: 70 6f 69 6e 74 65 72 3f 20 73 64 6c 2d 73 65 6d pointer? sdl-sem 04d0: 2d 74 20 70 29 20 28 73 64 6c 2d 64 65 73 74 72 -t p) (sdl-destr 04e0: 6f 79 2d 73 65 6d 61 70 68 6f 72 65 20 70 29 5d oy-semaphore p)] 04f0: 0a 0a 09 09 09 20 20 5b 28 66 74 79 70 65 2d 70 ..... [(ftype-p 0500: 6f 69 6e 74 65 72 3f 20 73 64 6c 2d 63 6f 6e 64 ointer? sdl-cond 0510: 2d 74 20 70 29 20 28 73 64 6c 2d 64 65 73 74 72 -t p) (sdl-destr 0520: 6f 79 2d 63 6f 6e 64 20 70 29 5d 0a 09 09 09 20 oy-cond p)].... 0530: 20 5b 28 66 74 79 70 65 2d 70 6f 69 6e 74 65 72 [(ftype-pointer 0540: 3f 20 73 64 6c 2d 63 75 72 73 6f 72 2d 74 20 70 ? sdl-cursor-t p 0550: 29 20 28 73 64 6c 2d 66 72 65 65 2d 63 75 72 73 ) (sdl-free-curs 0560: 6f 72 20 70 29 5d 0a 09 09 09 20 20 5b 28 66 74 or p)].... [(ft 0570: 79 70 65 2d 70 6f 69 6e 74 65 72 3f 20 73 64 6c ype-pointer? sdl 0580: 2d 70 69 78 65 6c 2d 66 6f 72 6d 61 74 2d 74 20 -pixel-format-t 0590: 70 29 20 28 73 64 6c 2d 66 72 65 65 2d 66 6f 72 p) (sdl-free-for 05a0: 6d 61 74 20 70 29 5d 0a 09 09 09 20 20 5b 28 66 mat p)].... [(f 05b0: 74 79 70 65 2d 70 6f 69 6e 74 65 72 3f 20 73 64 type-pointer? sd 05c0: 6c 2d 70 61 6c 65 74 74 65 2d 74 20 70 29 20 28 l-palette-t p) ( 05d0: 73 64 6c 2d 66 72 65 65 2d 70 61 6c 65 74 74 65 sdl-free-palette 05e0: 20 70 29 5d 0a 09 09 09 20 20 5b 28 66 74 79 70 p)].... [(ftyp 05f0: 65 2d 70 6f 69 6e 74 65 72 3f 20 73 64 6c 2d 72 e-pointer? sdl-r 0600: 77 2d 6f 70 73 2d 74 20 70 29 20 28 73 64 6c 2d w-ops-t p) (sdl- 0610: 66 72 65 65 2d 72 77 20 70 29 5d 0a 09 09 09 20 free-rw p)].... 0620: 20 5b 65 6c 73 65 0a 09 09 09 20 20 20 28 66 6f [else.... (fo 0630: 72 65 69 67 6e 2d 66 72 65 65 20 28 66 74 79 70 reign-free (ftyp 0640: 65 2d 70 6f 69 6e 74 65 72 2d 61 64 64 72 65 73 e-pointer-addres 0650: 73 20 70 29 29 5d 0a 09 09 09 20 20 29 29 0a 09 s p))].... )).. 0660: 09 20 20 20 28 6c 6f 6f 70 20 28 73 64 6c 2d 67 . (loop (sdl-g 0670: 75 61 72 64 69 61 6e 29 29 29 29 29 29 29 0a 0a uardian))))))).. 0680: 20 28 64 65 66 69 6e 65 2d 66 6c 61 67 73 20 73 (define-flags s 0690: 64 6c 2d 69 6e 69 74 69 61 6c 69 7a 61 74 69 6f dl-initializatio 06a0: 6e 0a 20 20 20 28 74 69 6d 65 72 20 20 20 20 20 n. (timer 06b0: 20 20 20 20 20 20 23 78 30 30 30 30 30 30 30 31 #x00000001 06c0: 29 0a 20 20 20 28 61 75 64 69 6f 20 20 20 20 20 ). (audio 06d0: 20 20 20 20 20 20 23 78 30 30 30 30 30 30 31 30 #x00000010 06e0: 29 0a 20 20 20 28 76 69 64 65 6f 20 20 20 20 20 ). (video 06f0: 20 20 20 20 20 20 23 78 30 30 30 30 30 30 32 30 #x00000020 0700: 29 0a 20 20 20 28 6a 6f 79 73 74 69 63 6b 20 20 ). (joystick 0710: 20 20 20 20 20 20 23 78 30 30 30 30 30 32 30 30 #x00000200 0720: 29 0a 20 20 20 28 68 61 70 74 69 63 20 20 20 20 ). (haptic 0730: 20 20 20 20 20 20 23 78 30 30 30 30 31 30 30 30 #x00001000 0740: 29 0a 20 20 20 28 67 61 6d 65 2d 63 6f 6e 74 72 ). (game-contr 0750: 6f 6c 6c 65 72 20 23 78 30 30 30 30 32 30 30 30 oller #x00002000 0760: 29 0a 20 20 20 28 65 76 65 6e 74 73 20 20 20 20 ). (events 0770: 20 20 20 20 20 20 23 78 30 30 30 30 34 30 30 30 #x00004000 0780: 29 0a 20 20 20 28 6e 6f 2d 70 61 72 61 63 68 75 ). (no-parachu 0790: 74 65 20 20 20 20 23 78 30 30 31 30 30 30 30 30 te #x00100000 07a0: 29 29 0a 0a 20 3b 3b 20 63 61 6c 63 75 6c 61 74 )).. ;; calculat 07b0: 65 73 20 27 65 76 65 72 79 74 68 69 6e 67 20 66 es 'everything f 07c0: 6c 61 67 0a 20 28 64 65 66 69 6e 65 20 73 64 6c lag. (define sdl 07d0: 2d 69 6e 69 74 69 61 6c 69 7a 61 74 69 6f 6e 2d -initialization- 07e0: 65 76 65 72 79 74 68 69 6e 67 20 0a 20 20 20 28 everything . ( 07f0: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 20 fold (lambda (x 0800: 61 63 63 29 20 28 6c 6f 67 6f 72 20 28 63 64 72 acc) (logor (cdr 0810: 20 78 29 20 61 63 63 29 20 29 20 30 20 28 66 6c x) acc) ) 0 (fl 0820: 61 67 73 2d 61 6c 69 73 74 20 73 64 6c 2d 69 6e ags-alist sdl-in 0830: 69 74 69 61 6c 69 7a 61 74 69 6f 6e 2d 66 6c 61 itialization-fla 0840: 67 73 29 29 29 0a 0a gs)))..