Changeset 27327 in project


Ignore:
Timestamp:
08/29/12 13:22:23 (9 years ago)
Author:
megane
Message:

sdl-base: - removed sdl-(ttf, gfx, img, net) support

Location:
release/4/sdl-base/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/sdl-base/trunk/sdl-base-foreign-types-include.scm

    r27326 r27327  
    55       `(lambda (pointer)
    66          (and pointer
    7                (,(i (string->symbol
    8                      (string-append "make-"(symbol->string (i record-name))))) pointer)))))))
    9 
    10 (define-foreign-type SDL_version (c-pointer "SDL_version")
    11   sdl-version-pointer
    12   (pointer-to-record-lambda sdl-version))
     7               (,(i (symbol-append 'make- (strip-syntax record-name))) pointer)))))))
    138
    149(define (-sdl-unbox-rect e)
     
    1914(define-foreign-type SDL_Rect (c-pointer "SDL_Rect")
    2015  -sdl-unbox-rect)
    21 
    22 (define-foreign-type SDL_PixelFormat (c-pointer "SDL_PixelFormat")
    23   sdl-pixel-format-pointer
    24   (pointer-to-record-lambda sdl-pixel-format))
    25 
    26 (define-foreign-type SDL_Surface (c-pointer "SDL_Surface")
    27   sdl-surface-pointer
    28   (lambda (p) (set-finalizer!
    29                ((pointer-to-record-lambda sdl-surface) p)
    30                sdl-free-surface)))
    3116
    3217(define (-sdl-unbox-color e)
     
    4631  -sdl-unbox-event)
    4732
     33
     34(define-foreign-type SDL_version (c-pointer "SDL_version")
     35  sdl-version-pointer
     36  (pointer-to-record-lambda sdl-version))
     37
     38(define-foreign-type SDL_PixelFormat (c-pointer "SDL_PixelFormat")
     39  sdl-pixel-format-pointer
     40  (pointer-to-record-lambda sdl-pixel-format))
     41
     42(define-foreign-type SDL_Surface (c-pointer "SDL_Surface")
     43  sdl-surface-pointer
     44  (lambda (p) (set-finalizer!
     45               ((pointer-to-record-lambda sdl-surface) p)
     46               sdl-free-surface)))
     47
    4848(define-foreign-type SDL_Joystick (c-pointer "SDL_Joystick")
    4949  sdl-joystick-pointer
  • release/4/sdl-base/trunk/sdl-base.meta

    r27326 r27327  
    1 ;;; sdl.meta -*- Hen -*-
     1;;; sdl-base.meta -*- scheme -*-
    22
    33((category graphics)
    4  (author "Tony Garnock-Jones")
     4 (author "")
    55 (synopsis "Basic SDL support")
    66 (license "LGPL-2.1")
    77 (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-base.egg")
     9 (files "sdl-base.meta"
     10        "sdl-base.scm"
     11        "sdl-base.setup"
     12        "COPYING"
     13        "Makefile"
     14        "test-heap.scm"
     15        "heap.scm"
     16        "timer.scm"))
  • release/4/sdl-base/trunk/sdl-base.scm

    r27326 r27327  
    1616; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
    1717; USA
    18 
    19 ; ---------------------------------------------------------------------------
    20 
    21 (module sdl
    22 
    23 ( *sdl-egg-version*
    24 
    25   SDL_BUTTON
     18(module sdl-base
     19
     20( make-sdl-version
     21  sdl-version-pointer
    2622  sdl-version-major
    2723  sdl-version-minor
     
    3026  sdl-compiled-version
    3127  sdl-linked-version
    32   ; sdl gfx
     28
    3329  make-sdl-rect
     30  sdl-rect-buffer
    3431  sdl-rect?
    3532  sdl-rect-x
     
    3734  sdl-rect-w
    3835  sdl-rect-h
     36
    3937  make-sdl-pixel-format
     38  sdl-pixel-format-pointer
    4039  sdl-pixel-format?
    4140  sdl-pixel-format-bytes-per-pixel
     
    4443  sdl-pixel-format-bmask
    4544  sdl-pixel-format-amask
     45
     46 
     47  make-sdl-surface
     48  sdl-surface-pointer
     49  sdl-surface?
     50  sdl-create-rgb-surface
    4651  sdl-surface-flags
    4752  sdl-surface-pixel-format
     
    5156  sdl-surface-pixels
    5257  sdl-surface-pixels-length
     58
     59  make-sdl-video-info
     60  sdl-video-info-pointer
    5361  sdl-get-video-info
    5462  sdl-video-info-hw-available
     
    6573  sdl-video-info-current-w
    6674  sdl-video-info-current-h
     75
    6776  sdl-get-clip-rect!
    6877  sdl-set-clip-rect!
     
    7382  sdl-convert-surface
    7483
    75   ; sdl system stuff
     84  ;; sdl system stuff
    7685  sdl-init
    7786  sdl-init-sub-system
     
    95104  get-time-of-day
    96105  sdl-add-relative-timer!
    97   make-sdl-event
    98   sdl-event?
    99   sdl-event-type
    100106  sdl-pump-events
    101107  sdl-poll-event!
     
    116122  sdl-fill-rect
    117123  sdl-flip
    118   sdl-surface?
    119   sdl-create-rgb-surface
    120124  sdl-free-surface
    121125  sdl-blit-surface
    122126  sdl-with-clip-rect
     127
    123128  make-sdl-color
     129  sdl-color-buffer
    124130  sdl-color?
    125131  sdl-color-r
     
    128134
    129135  make-sdl-joystick
     136  sdl-joystick-pointer
    130137  sdl-joystick?
    131138  sdl-joystick-event-state
     
    149156  sdl-gl-get-attribute
    150157
    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 
     158  make-sdl-event
     159  sdl-event-buffer sdl-event-buffer-set!
     160  sdl-event-type
    225161  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!
     162  sdl-event-gain         set-sdl-event-gain!
     163  sdl-event-which        set-sdl-event-which!
     164  sdl-event-state        set-sdl-event-state!
     165  sdl-event-scancode     set-sdl-event-scancode!
     166  sdl-event-sym          set-sdl-event-sym!
     167  sdl-event-mod          set-sdl-event-mod!
     168  sdl-event-unicode      set-sdl-event-unicode!
     169  sdl-event-x            set-sdl-event-x!
     170  sdl-event-y            set-sdl-event-y!
     171  sdl-event-xrel         set-sdl-event-xrel!
     172  sdl-event-yrel         set-sdl-event-yrel!
     173  sdl-event-axis         set-sdl-event-axis!
     174  sdl-event-ball         set-sdl-event-ball!
     175  sdl-event-hat          set-sdl-event-hat!
     176  sdl-event-value        set-sdl-event-value!
     177  sdl-event-button       set-sdl-event-button!
     178  sdl-event-w            set-sdl-event-w!
     179  sdl-event-h            set-sdl-event-h!
     180 
    263181  heap?
    264182 
    265183
    266   ; constants
    267 
     184  ;; constants
    268185  SDL_INIT_TIMER
    269186  SDL_INIT_AUDIO
     
    305222
    306223
    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
     224  SDL_NOEVENT                     ; Unused (do not remove)
     225  SDL_ACTIVEEVENT                 ; Application loses/gains visibility
     226  SDL_APPMOUSEFOCUS               ; Mouse focus gained/lost
     227  SDL_APPINPUTFOCUS               ; Input focus gained/lost
     228  SDL_APPACTIVE                   ; Application iconified/restored
     229  SDL_KEYDOWN                     ; Keys pressed
     230  SDL_KEYUP                       ; Keys released
     231  SDL_MOUSEMOTION                 ; Mouse moved
     232  SDL_MOUSEBUTTONDOWN             ; Mouse button pressed
     233  SDL_MOUSEBUTTONUP               ; Mouse button released
     234  SDL_JOYAXISMOTION               ; Joystick axis motion
     235  SDL_JOYBALLMOTION               ; Joystick trackball motion
     236  SDL_JOYHATMOTION                ; Joystick hat position change
     237  SDL_JOYBUTTONDOWN               ; Joystick button pressed
     238  SDL_JOYBUTTONUP                 ; Joystick button released
     239  SDL_QUIT                        ; User-requested quit
     240  SDL_SYSWMEVENT                  ; System specific event
     241  SDL_EVENT_RESERVEDA             ; Reserved for future use..
     242  SDL_EVENT_RESERVEDB             ; Reserved for future use..
     243  SDL_VIDEORESIZE                 ; User resized video mode
     244  SDL_VIDEOEXPOSE                 ; Screen needs to be redrawn
     245  SDL_EVENT_RESERVED2             ; Reserved for future use..
     246  SDL_EVENT_RESERVED3             ; Reserved for future use..
     247  SDL_EVENT_RESERVED4             ; Reserved for future use..
     248  SDL_EVENT_RESERVED5             ; Reserved for future use..
     249  SDL_EVENT_RESERVED6             ; Reserved for future use..
     250  SDL_EVENT_RESERVED7             ; Reserved for future use..
     251  SDL_USEREVENT    ; SDL_USEREVENT .. SDL_NUMEVENTS are for client use
    335252  SDL_NUMEVENTS
    336253
     
    353270  SDL_SYSWMEVENTMASK
    354271  SDL_ALLEVENTS
    355                                         ; General button/key states
     272
     273  ;; General button/key states
    356274  SDL_PRESSED
    357275  SDL_RELEASED
    358                                         ; Mouse button states
     276
     277  ;; Mouse button states
     278  SDL_BUTTON
    359279  SDL_BUTTON_LEFT
    360280  SDL_BUTTON_MIDDLE
     
    362282  SDL_BUTTON_WHEELUP
    363283  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)
     284  SDL_BUTTON_LMASK                  ; = SDL_BUTTON(SDL_BUTTON_LEFT)
     285  SDL_BUTTON_MMASK                  ; = SDL_BUTTON(SDL_BUTTON_MIDDLE)
     286  SDL_BUTTON_RMASK                  ; = SDL_BUTTON(SDL_BUTTON_RIGHT)
    367287  SDL_QUERY
    368288  SDL_IGNORE
     
    387307  SDL_GL_SWAP_CONTROL
    388308  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
    399309
    400310  ;; scancodes
     
    634544  SDLK_UNDO
    635545
    636 )
     546  )
    637547
    638548;---------------------------------------------------------------------------
     
    647557(foreign-declare #<<EOF
    648558
    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 
    660559#include <sys/time.h>
    661560
    662561#include "SDL.h"
    663 #include "SDL_ttf.h"
    664 #include "SDL_image.h"
    665 #include "SDL_rotozoom.h"
    666562#include "SDL_keysym.h"
    667563#include "SDL_endian.h"
    668564
    669565#include <string.h>
    670 #include "SDL_net.h"
    671566
    672567EOF
     
    675570(include "heap.scm")
    676571(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))
    685572
    686573;---------------------------------------------------------------------------
     
    696583                   (cdr e)))))
    697584
     585(define-record sdl-rect buffer)
     586(define-record sdl-event buffer)
     587(define-record sdl-color buffer)
     588(define make-sdl-rect% make-sdl-rect)
     589(define make-sdl-event% make-sdl-event)
     590(define make-sdl-color% make-sdl-color)
     591
    698592(define-record sdl-version pointer)
    699 (define-record sdl-rect buffer)
    700593(define-record sdl-pixel-format pointer)
    701594(define-record sdl-surface pointer)
    702595(define-record sdl-video-info pointer)
    703 (define-record sdl-event buffer)
    704 (define-record sdl-color buffer)
    705596(define-record sdl-joystick pointer)
    706597
    707 (include "sdl-foreign-types-include.scm")
     598(include "sdl-base-foreign-types-include.scm")
    708599(include "keysym.scm")
    709600
     
    808699 "SDL_RELEASED")
    809700
    810 ;; SDL_image constants
    811 (--sdl-flags
    812  "IMG_INIT_JPG"
    813  "IMG_INIT_PNG"
    814  "IMG_INIT_TIF")
    815 
    816701; Mouse button states
    817702
     
    883768(define-foreign-variable sizeof-sdl-rect int "sizeof(SDL_Rect)")
    884769
    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))))
     770(set! make-sdl-rect
     771      (lambda (x y w h)
     772        (let ((r (make-sdl-rect% (make-blob sizeof-sdl-rect))))
     773          (sdl-rect-x-set! r x)
     774          (sdl-rect-y-set! r y)
     775          (sdl-rect-w-set! r w)
     776          (sdl-rect-h-set! r h)
     777          r)))
    894778
    895779(define-record-printer (sdl-rect s out)
     
    11531037(define-foreign-variable sizeof-sdl-event int "sizeof(SDL_Event)")
    11541038
    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))))))
     1039(set! make-sdl-event
     1040      (lambda ()
     1041        (let ((bv (blob->u8vector (make-blob sizeof-sdl-event))))
     1042          (u8vector-set! bv 0 SDL_NOEVENT)
     1043          (make-sdl-event% (u8vector->blob bv)))))
    11611044
    11621045(define-record-printer (sdl-event s out)
     
    14141297(define-foreign-variable sizeof-sdl-color int "sizeof(SDL_Color)")
    14151298
    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)))))
     1299(set! make-sdl-color
     1300      (lambda (r g b)
     1301        (let ((bv (make-blob sizeof-sdl-color)))
     1302          (fill-sdl-color! (make-sdl-color% bv) r g b))))
    14211303
    14221304(define-record-printer (sdl-color s out)
     
    15031385          (and (zero? r) ptr))))))
    15041386
    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 
    18251387)
  • release/4/sdl-base/trunk/sdl-base.setup

    r27326 r27327  
    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-each
    15      (lambda (lib-fun)
    16        (print "\nWARNING: You seem to be missing the library " (first lib-fun) "!"))
    17      missing)
    18     (cond-expand
    19      (linux
    20       (unless (null? missing)
    21         (print "\nSuggested package(s) to install: " (map third missing))))
    22      (else #f))))
    23 
    24 (check-depends)
     1;;;; sdl-base.setup -*- Scheme -*-
    252
    263(let* ((escape-flags (lambda (fs)
     
    3613                           (with-input-from-pipe "sdl-config --cflags" read-line))))
    3714       (sdl-lflags (apply string-append
    38                           ;; sdl-config doesn't give these
    39                           " -lSDL_gfx -lSDL_net -lSDL_ttf -lSDL_image"
    4015                          (escape-flags
    4116                           (with-input-from-pipe "sdl-config --libs" read-line))))
    4217       (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)
     18       (files (append '("sdl-base.so"
     19                        "sdl-base.import.so"
     20                        "sdl-base-foreign-types-include.scm")
     21                      (if types? '("sdl-base.types") '()))))
     22 
     23  (compile ,@(if types? '(-emit-type-file sdl-base.types) '())
     24           -v -s -O3 -d1 sdl-base.scm -j sdl-base ,sdl-cflags ,sdl-lflags)
     25  (compile -s -O3 -d0 sdl-base.import.scm ,sdl-cflags ,sdl-lflags)
    5026
    51   (install-extension 'sdl files '((version "0.5.5"))))
     27  (install-extension 'sdl-base files '((version "0.1"))))
    5228
Note: See TracChangeset for help on using the changeset viewer.