Changeset 13305 in project


Ignore:
Timestamp:
02/14/09 17:13:44 (11 years ago)
Author:
felix winkelmann
Message:

ported to chicken 4

Location:
release/4/xlib
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/xlib/xlib.meta

    r9002 r13305  
    1 ;;; xlib.meta -*- Hen -*-
     1;;; xlib.meta -*- Scheme -*-
    22
    33((synopsis "Xlib bindings")
    44 (author "Richard Mann")
     5 (maintainer "felix winkelmann")
    56 (category graphics)
    67 (license "unknown")
     8 (depends matchable)
    79 (doc-from-wiki)
    810 (egg "xlib.egg")
    9  (files "xlib.scm" "xlib-c.c" "xlib-original.scm" "xlib.setup"))
     11 (files "xlib.scm" "xlib-c.c" "xlib-original .scm" "xlib.setup"))
  • release/4/xlib/xlib.scm

    r18 r13305  
    1717
    1818
    19 (define ##xlib#peek-and-free-c-string
    20   (lambda (b)
    21     (and (not (##sys#null-pointer? b))
    22          (let* ([len (##core#inline "C_fetch_c_strlen" b)]
    23                 [str2 (##sys#make-string len)] )
    24            (##core#inline "C_peek_c_string" b str2 len)
    25            (##core#inline "C_free_xptr" b)
    26            str2) ) ) )
     19(module xlib ()
     20  (import scheme chicken foreign srfi-13 data-structures)
     21  (begin-for-syntax (require-library matchable))
     22  (import-for-syntax matchable chicken)
    2723
    28 (define-foreign-type xstring* c-pointer
    29   #f
    30   ##xlib#peek-and-free-c-string)
    31 
    32 
    33 (eval-when (compile)
    34 
    35 (print "Compiling xlib (this may take a while) ...")
    36 
    37 (use srfi-13)
    38 
    39 (cond-expand [dumpinfo
    40   (use format)
    41   (define-macro (foreign-function name args result cname)
    42     (let ([r (xlate-rtype result cname)])
    43       (format #t "(~A~:@(~{ ~A~})~:[ -> ~A~;~*~]~)~%"
    44               name
    45               (map (cut xlate-atype <> cname) args)
    46               (eq? r 'void) r) )
    47     #f)
    48   (define-macro (foreign-cb-function . args)
    49     `(foreign-function ,@args) )
    50   (define-macro (foreign-define name val)
    51     (format #t "~A~%" name)
    52     #f) ]
    53 [else
    54 
    55 (define-macro (foreign-function name args result cname)
    56   `(define ,name
    57      (foreign-lambda ,(xlate-rtype result cname) ,cname ,@(map (cut xlate-atype <> cname) args)) ) )
    58 
    59 (define-macro (foreign-cb-function name args result cname)
    60   `(define ,name
    61      (foreign-safe-lambda ,(xlate-rtype result cname) ,cname ,@(map (cut xlate-atype <> cname) args)) ) )
    62 
    63 (define-macro (foreign-define name val)
    64   `(define ,name ,val) )
    65 ])
    66 
    67 (define (xlate-type t cn)
    68   (match t
     24(define-for-syntax (xlate-type t cn)
     25  (match (strip-syntax t)               ; punt
    6926    [('POINTER 'FUNCTION) (xlate-warn t 'c-pointer cn)]
    7027    [('POINTER (or 'STRUCT 'UNION 'VOID)) 'c-pointer]
     
    7936    [(or 'UNSIGNED-INT 'UNSIGNED) 'unsigned-integer]
    8037    ['INT 'integer]
    81     [_ (error "type not supported" t cn)] ) )
     38    [_ (syntax-error "type not supported" t cn)] ) )
    8239
    83 (define (xlate-warn t t2 cn)
     40(define-for-syntax (xlate-warn t t2 cn)
    8441  (cond-expand
    8542   [pickytypes (fprintf (current-error-port) "Warning: ~s type in ~s.~%" t cn)]
     
    8744  t2)
    8845
    89 (define (xlate-rtype t cn)
     46(define-for-syntax (xlate-rtype t cn)
    9047  (match t
    9148    ['VOID 'void]
     
    9451    [_ (xlate-type t cn)] ) )
    9552
    96 (define (xlate-atype t cn)
     53(define-for-syntax (xlate-atype t cn)
    9754  (match t
    9855    [(or 'c-string 'STRING) 'c-string]
    9956    [_ (xlate-type t cn)] ) )
    10057
    101 )
     58(define peek-and-free-c-string
     59  (lambda (b)
     60    (and (not (##sys#null-pointer? b))
     61         (let* ([len (##core#inline "C_fetch_c_strlen" b)]
     62                [str2 (##sys#make-string len)] )
     63           (##core#inline "C_peek_c_string" b str2 len)
     64           (##core#inline "C_free_xptr" b)
     65           str2) ) ) )
     66
     67(define-foreign-type xstring* c-pointer
     68  #f
     69  peek-and-free-c-string)
     70
     71(eval-when (compile)
     72  (print "Compiling xlib (this may take a while) ..."))
     73
     74(define-syntax (foreign-function x r c)
     75  (match (cdr x)
     76    ((name args result cname)
     77     `(,(r 'begin)
     78       (,(r 'export) ,name)
     79       (,(r 'define) ,name
     80        (,(r 'foreign-lambda)
     81         ,(xlate-rtype result cname)
     82         ,cname
     83         ,@(map (cut xlate-atype <> cname) args)) ) ))))
     84
     85(define-syntax (foreign-cb-function x r c)
     86  (match (cdr x)
     87    ((name args result cname)
     88     `(,(r 'begin)
     89       (,(r 'export) ,name)
     90       (,(r 'define) ,name
     91        (,(r 'foreign-safe-lambda)
     92         ,(xlate-rtype result cname)
     93         ,cname
     94         ,@(map (cut xlate-atype <> cname) args)) ) ) ) ))
     95
     96(define-syntax foreign-define
     97  (syntax-rules ()
     98    ((_ name val)
     99     (begin
     100       (export name)
     101       (define name val)))))
    102102
    103103(include "xlib-original.scm")
     104
     105)
  • release/4/xlib/xlib.setup

    r8286 r13305  
    1 (run (csc xlib.scm -s -O2 -d0 -L "\"-L/usr/X11R6/lib -lX11\"" -C "\"-I/usr/X11R6/include\"" -emit-exports "xlib.exports"))
     1(run (csc xlib.scm -j xlib -s -O2 -d0 -L "\"-L/usr/X11R6/lib -lX11\"" -C "\"-I/usr/X11R6/include\""))
     2(run (csc xlib.import.scm -s -O2 -d0))
    23
    3 (install-extension 'xlib '("xlib.so" "xlib.exports") '((exports "xlib.exports")))
     4(install-extension
     5 'xlib
     6 '("xlib.so" "xlib.import.so") )
Note: See TracChangeset for help on using the changeset viewer.