Changeset 13516 in project


Ignore:
Timestamp:
03/06/09 01:02:49 (11 years ago)
Author:
Jim Ursetto
Message:

foreign-records: add define-foreign-enum-type

Location:
release/4/foreign-records/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/foreign-records/trunk/foreign-records.meta

    r10963 r13516  
    88 (category lang-exts)
    99 (doc-from-wiki)
     10 (needs matchable)
    1011 (files "foreign-records.scm" "foreign-records.setup" "foreign-records.html"))
  • release/4/foreign-records/trunk/foreign-records.scm

    r11124 r13516  
    1 ;;; implement define-foreign-record-type
    2 
    3 #|
    4 ,x
    5 (define-foreign-record-type (servent "struct servent")
    6   (constructor: make-servent)
    7   (destructor: free-servent)
    8   (c-string s_name servent-name servent-name-set!)
    9   (c-pointer s_aliases servent-s_aliases)
    10   (port-number s_port servent-port servent-port-set!)
    11   (c-string s_proto servent-proto servent-proto-set!))
    12 
    13 ,x
    14 (define-foreign-record-type point
    15   (int (xyz 3) point-coords point-coords-set!))
    16 
    17 ; rename: not used
    18 ; const specifier not used, avoid specifying setter
    19 
    20 |#
    21 
    22 #|
    23 ;; for interactive testing
    24 (define (##compiler#foreign-type-declaration t n)
    25   (conc t " " n))
    26 (define ##compiler#foreign-type-table (make-hash-table))
    27 (define (##sys#hash-table-set! . args) (display "hash-table-set! ") (write args) (newline))
    28 |#
     1;;; foreign-records module
     2
     3;;; renaming module
     4
     5;; Renaming helper macro for er-macros below.  Must be a module
     6;; so we can import via (import-for-syntax renaming).
     7
     8(module renaming (with-renamed)
     9  (import scheme)
     10  ;; (with-renamed r (begin car cdr) body ...)
     11  ;; -> (let ((%begin (r 'begin)) (%car (r 'car)) (%cdr (r 'cdr)))
     12  ;;      body ...)
     13  (define-syntax with-renamed
     14    (lambda (f r c)
     15      (##sys#check-syntax 'with-renamed f '(_ _ (_ . _) . _))
     16      (let ((renamer (cadr f))
     17            (identifiers (caddr f))
     18            (body (cdddr f))
     19            (munger (lambda (x) (string->symbol
     20                            (string-append "%" (symbol->string x))))))
     21        `(,(r 'let)
     22          ,(map (lambda (x)
     23                  `(,(munger x) (,renamer ',x)))
     24                identifiers)
     25          ,@body)))))
     26
     27;;; define-foreign-record-type
    2928
    3029(module foreign-records
    31   (define-foreign-record-type)
    32 
    33   (import scheme foreign)
     30  (define-foreign-record-type define-foreign-enum-type)
     31
     32  (import scheme chicken foreign)
    3433
    3534  (define-syntax define-foreign-record-type
     
    3938      (let ((name (cadr f))
    4039            (slots (cddr f)))
    41         (let ([fname (if (pair? name) (->string (cadr name)) (sprintf "struct ~A" name))]
     40        (let ([fname (if (pair? name) (->string (cadr name))
     41                         (sprintf "struct ~A" name))]
    4242              [tname (if (pair? name) (car name) name)]
    4343              [ctor #f]
     
    165165                            ;; [else (syntax-error 'define-foreign-record "bad slot spec" slot)]
    166166                            )))
    167                     slots) ) )) )))
     167                    slots) ) )) ))
     168
     169;;; define-foreign-enum-type
     170 
     171(require-library matchable)
     172(import-for-syntax matchable)
     173(import-for-syntax renaming)
     174
     175;; Ignored case where typename is a symbol, for now.
     176;; Permit string or symbol as REALTYPE in ENUMSPEC.
     177(define-syntax define-foreign-enum-type
     178  (lambda (f r c)
     179    (match
     180     f
     181     ((_ (type-name native-type default-value)
     182         (to-native from-native)
     183         enumspecs ...)
     184      (let ((enums (map (lambda (spec)
     185                          (match spec
     186                                 (((s v) n d) spec)
     187                                 (((s v) n)   `((,s ,v) ,n ',s))
     188                                 (((s) n d)   `((,s ,(gensym)) ,n ,d))
     189                                 (((s) n)     `((,s ,(gensym)) ,n ',s))
     190                                 ((s n d)     `((,s ,s) ,n ,d))
     191                                 ((s n)       `((,s ,s) ,n ',s))
     192                                 ((s ...)     (error 'define-foreign-enum-type
     193                                                     "error in enum spec" spec))
     194                                 (s          `((,s ,s) ,s ',s))
     195                                 (else
     196                                  (syntax-error 'default-foreign-enum-type
     197                                         "error in enum spec" spec))))
     198                        enumspecs)))
     199        (with-renamed
     200         r (begin define cond else if let symbol? list null?
     201                  car cdr case bitwise-ior error =
     202                  define-foreign-type define-foreign-variable)
     203
     204         `(,%begin
     205           (,%define-foreign-type ,type-name
     206             ,native-type ,to-native ,from-native)
     207           
     208           ,@(map (lambda (e)
     209                    (match-let ([ ((s var) name d) e ])
     210                      `(,%define-foreign-variable ,var ,native-type
     211                         ,(if (symbol? name) (symbol->string name) name))))
     212                  enums)
     213
     214           (,%define (,from-native val)
     215             (,%cond
     216              ,@(map (lambda (e)
     217                       (match-let ([ ((s var) n value) e ])
     218                         `((,%= val ,var) ,value)))
     219                     enums)
     220              (,%else ,default-value)))
     221
     222           (,%define (,to-native syms)
     223             (,%let loop ((syms (,%if (,%symbol? syms) (,%list syms) syms))
     224                          (sum 0))
     225               (,%if (,%null? syms)
     226                     sum
     227                     (loop (,%cdr syms)
     228                           (,%bitwise-ior
     229                            sum
     230                            (,%let ((val (,%car syms)))
     231                              (,%case
     232                               val
     233                               ,@(map (lambda (e)
     234                                        (match-let ([((symbol var) n d) e])
     235                                          `((,symbol) ,var)))
     236                                      enums)
     237                               (,%else (,%error "not a member of enum" val
     238                                                ',type-name)))))))))
     239           ))))
     240
     241     ; handle missing default-value
     242     ((_ (type-name native-type) . rest)
     243      `(define-foreign-enum-type (,type-name ,native-type '()) ,@rest))
     244     ))))
     245
     246
     247;;; Testing
     248
     249#|
     250,x
     251(define-foreign-record-type (servent "struct servent")
     252  (constructor: make-servent)
     253  (destructor: free-servent)
     254  (c-string s_name servent-name servent-name-set!)
     255  (c-pointer s_aliases servent-s_aliases)
     256  (port-number s_port servent-port servent-port-set!)
     257  (c-string s_proto servent-proto servent-proto-set!))
     258
     259,x
     260(define-foreign-record-type point
     261  (int (xyz 3) point-coords point-coords-set!))
     262
     263; rename: not used
     264; const specifier not used, avoid specifying setter
     265
     266|#
     267
     268#|
     269;; for interactive testing
     270(define (##compiler#foreign-type-declaration t n)
     271  (conc t " " n))
     272(define ##compiler#foreign-type-table (make-hash-table))
     273(define (##sys#hash-table-set! . args) (display "hash-table-set! ") (write args) (newline))
     274|#
  • release/4/foreign-records/trunk/foreign-records.setup

    r11218 r13516  
    1 (compile -host -s -O2 -d2 foreign-records.scm -j foreign-records)
     1(compile -host -s -O2 -d2 foreign-records.scm -j renaming -j foreign-records )
    22(compile -host -s -O2 -d0 foreign-records.import.scm)
    33(install-extension
Note: See TracChangeset for help on using the changeset viewer.