Changeset 13517 in project


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

foreign-records: reformat

File:
1 edited

Legend:

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

    r13516 r13517  
    4242              [tname (if (pair? name) (car name) name)]
    4343              [ctor #f]
    44               [dtor #f]
    45               (%begin (r 'begin))
    46               (%define (r 'define))
    47               (%foreign-lambda* (r 'foreign-lambda*))
    48               (%if (r 'if))
    49               (%let (r 'let))
    50               (%lambda (r 'lambda))
    51               (%void 'void)  ; foreign-lambda* does not allow renaming
    52               (%int 'int))
     44              [dtor #f])
    5345          (define (stype type)
    5446            (cond [(not (pair? type)) type]
     
    7264       
    7365          (##sys#hash-table-set! ##compiler#foreign-type-table tname `(c-pointer ,fname))
    74           `(begin
    75              ,@(if (pair? name)
    76                    '()
    77                    `((,(r 'declare)
    78                       (,(r 'foreign-declare)
    79                        ,(string-intersperse
    80                          (append
    81                           (cons
    82                            (string-append "struct " (->string name) " { ")
    83                            (map (lambda (slot)
    84                                   (##sys#check-syntax 'define-foreign-record-type slot '(_ _ _ . _))
    85                                   (if (pair? (cadr slot)) ; (type (name size) ...)
    86                                       (sprintf "~A[~A];"
    87                                                (##compiler#foreign-type-declaration
    88                                                 (car slot)
    89                                                 (->string (caadr slot)) )
    90                                                (cadadr slot) )
    91                                       (sprintf "~A;" ; (type name ...)
    92                                                (##compiler#foreign-type-declaration
    93                                                 (car slot)
    94                                                 (->string (cadr slot)) ) ) )
    95                                   ;; [else (syntax-error 'define-foreign-record "bad slot spec" slot)]
    96                                   )
    97                                 slots) )
    98                           (list "};") )
    99                          "\n") ) ) ) )
    100              ,@(if (not ctor)
    101                    '()
    102                    `((,%define ,ctor
    103                                (,%foreign-lambda* ,tname () ,(sprintf "return((~a *)C_malloc(sizeof(~a)));" fname fname)))))
    104              ,@(if (not dtor)
    105                    '()
    106                    (let ((ptr (r (gensym))))
    107                      `((,%define (,dtor ,ptr) (and ,ptr (##core#inline "C_qfree" ,ptr))))))
    108              ,@(map (lambda (slot)
    109                       (##sys#check-syntax 'define-foreign-record-type slot '(_ _ _ . _))
    110                       (let* ((type (car slot))
    111                              (namesz (cadr slot))
    112                              (type2 (stype type))
    113                              (getr (caddr slot))
    114                              (setr (cdddr slot)))
    115                         (if (pair? namesz)
    116                             (let ((sname (car namesz))
    117                                   (size (cadr namesz))
    118                                   (var (r (gensym)))
    119                                   (cvar (r (gensym)))
    120                                   (svar (r (gensym)))
    121                                   (xvar (r (gensym))))
    122                               `(,%begin
    123                                 (,%define ,getr
    124                                           (,%let ([,cvar
    125                                                    (,%foreign-lambda* ,type2 ([,tname ,var] [,%int ,svar])
    126                                                                       ,(sprintf "return(~A~A->~A[~A]);"
    127                                                                                 (if (not (strtype type)) "" "&")
    128                                                                                 var sname svar) ) ] )
    129                                                  (,%lambda (,var ,svar)
    130                                                            (,%if (##core#check (,(r 'and) (,(r 'fx>=) ,svar 0) (,(r 'fx<) ,svar ,size)))
    131                                                                  (,cvar ,var ,svar)
    132                                                                  ;; this should signal a range exn...
    133                                                                  (,(r 'syntax-error) 'define-foreign-record "array access out of range" ',tname ',svar ,size) ) ) ) )
    134                                 ,@(if (null? setr)
    135                                       '()
    136                                       (if (eq? type type2)
    137                                           `((,%define ,(car setr)
    138                                                       (,%let ([,cvar
    139                                                                (,%foreign-lambda* ,%void ([,tname ,var] [,%int ,svar] [,type ,xvar])
    140                                                                                   ,(sprintf "~A->~A[~A] = ~A;" var sname svar xvar) ) ] )
    141                                                              (,%lambda (,var ,svar ,xvar)
    142                                                                        (,%if (##core#check (,(r 'and) (,(r 'fx>=) ,svar 0) (,(r 'fx<) ,svar ,size)))
    143                                                                              (,cvar ,var ,svar ,xvar)
    144                                                                              (,(r 'syntax-error)
    145                                                                               'define-foreign-record
    146                                                                               "array access out of range" ',tname ',svar ,size) ) ) ) ) )
    147                                           '() ) ) ))
    148                          
    149                             (let ([sname (cadr slot)]
    150                                   [var (r (gensym))] ; rename may be unnecessary
    151                                   [xvar (r (gensym))])
    152                               `(,%begin
    153                                 (,%define ,getr
    154                                           (,%foreign-lambda* ,type2 ([,tname ,var])
    155                                                              ,(sprintf "return(~A~A->~A);"
    156                                                                        (if (not (strtype type)) "" "&")
    157                                                                        var sname) ) )
    158                                 ,@(if (null? setr)
    159                                       '()
    160                                       (if (eq? type type2)
    161                                           `((,%define ,(car setr)
    162                                                       (,%foreign-lambda* ,%void ([,tname ,var] [,type ,xvar])
    163                                                                          ,(sprintf "~A->~A = ~A;" var sname xvar) ) ) )
    164                                           '() ) ) ) )
    165                             ;; [else (syntax-error 'define-foreign-record "bad slot spec" slot)]
    166                             )))
    167                     slots) ) )) ))
     66
     67          ;; void note: foreign-lambda* does not allow renaming
     68          (with-renamed r
     69              (void int begin define foreign-lambda foreign-lambda*
     70                    if let lambda declare foreign-declare
     71                    syntax-error and fx>= fx<)
     72            `(,%begin
     73               ,@(if (pair? name)
     74                     '()
     75                     `((,%declare
     76                        (,%foreign-declare
     77                         ,(string-intersperse
     78                           (append
     79                            (cons
     80                             (string-append "struct " (->string name) " { ")
     81                             (map (lambda (slot)
     82                                    (##sys#check-syntax 'define-foreign-record-type
     83                                                        slot '(_ _ _ . _))
     84                                    (if (pair? (cadr slot)) ; (type (name size) ...)
     85                                        (sprintf "~A[~A];"
     86                                                 (##compiler#foreign-type-declaration
     87                                                  (car slot)
     88                                                  (->string (caadr slot)) )
     89                                                 (cadadr slot) )
     90                                        (sprintf "~A;" ; (type name ...)
     91                                                 (##compiler#foreign-type-declaration
     92                                                  (car slot)
     93                                                  (->string (cadr slot)) ) ) )
     94                                    ;; [else (syntax-error 'define-foreign-record
     95                                    ;;                     "bad slot spec" slot)]
     96                                    )
     97                                  slots) )
     98                            (list "};") )
     99                           "\n") ) ) ) )
     100               ,@(if (not ctor)
     101                     '()
     102                     `((,%define ,ctor
     103                         (,%foreign-lambda* ,tname ()
     104                           ,(sprintf "return((~a *)C_malloc(sizeof(~a)));" fname fname)))))
     105               ,@(if (not dtor)
     106                     '()
     107                     (let ((ptr (r (gensym))))
     108                       `((,%define (,dtor ,ptr)
     109                           (and ,ptr (##core#inline "C_qfree" ,ptr))))))
     110               ,@(map (lambda (slot)
     111                        (##sys#check-syntax 'define-foreign-record-type slot '(_ _ _ . _))
     112                        (let* ((type (car slot))
     113                               (namesz (cadr slot))
     114                               (type2 (stype type))
     115                               (getr (caddr slot))
     116                               (setr (cdddr slot)))
     117                          (if (pair? namesz)
     118                              (let ((sname (car namesz))
     119                                    (size (cadr namesz))
     120                                    (var (r (gensym)))
     121                                    (cvar (r (gensym)))
     122                                    (svar (r (gensym)))
     123                                    (xvar (r (gensym))))
     124                                `(,%begin
     125                                   (,%define ,getr
     126                                     (,%let ([,cvar
     127                                              (,%foreign-lambda* ,type2 ([,tname ,var] [,%int ,svar])
     128                                                ,(sprintf "return(~A~A->~A[~A]);"
     129                                                          (if (not (strtype type)) "" "&")
     130                                                          var sname svar) ) ] )
     131                                       (,%lambda (,var ,svar)
     132                                         (,%if (##core#check (,%and (,%fx>= ,svar 0)
     133                                                                    (,%fx< ,svar ,size)))
     134                                               (,cvar ,var ,svar)
     135                                               ;; this should signal a range exn...
     136                                               (,%syntax-error 'define-foreign-record
     137                                                               "array access out of range"
     138                                                               ',tname ',svar ,size)))))
     139                                   ,@(if (null? setr)
     140                                         '()
     141                                         (if (eq? type type2)
     142                                             `((,%define ,(car setr)
     143                                                 (,%let ([,cvar
     144                                                          (,%foreign-lambda* ,%void
     145                                                              ([,tname ,var] [,%int ,svar] [,type ,xvar])
     146                                                            ,(sprintf "~A->~A[~A] = ~A;"
     147                                                                      var sname svar xvar))])
     148                                                   (,%lambda (,var ,svar ,xvar)
     149                                                     (,%if (##core#check (,%and (,%fx>= ,svar 0)
     150                                                                                (,%fx< ,svar ,size)))
     151                                                           (,cvar ,var ,svar ,xvar)
     152                                                           (,%syntax-error
     153                                                            'define-foreign-record
     154                                                            "array access out of range"
     155                                                            ',tname ',svar ,size))))))
     156                                             '() ))))
     157                             
     158                              (let ([sname (cadr slot)]
     159                                    [var (r (gensym))] ; rename may be unnecessary
     160                                    [xvar (r (gensym))])
     161                                `(,%begin
     162                                   (,%define ,getr
     163                                     (,%foreign-lambda* ,type2 ([,tname ,var])
     164                                       ,(sprintf "return(~A~A->~A);"
     165                                                 (if (not (strtype type)) "" "&")
     166                                                 var sname) ) )
     167                                   ,@(if (null? setr)
     168                                         '()
     169                                         (if (eq? type type2)
     170                                             `((,%define ,(car setr)
     171                                                 (,%foreign-lambda* ,%void ([,tname ,var] [,type ,xvar])
     172                                                   ,(sprintf "~A->~A = ~A;" var sname xvar))))
     173                                             '() ))))
     174                              ;; [else (syntax-error 'define-foreign-record
     175                              ;;                     "bad slot spec" slot)]
     176                              )))
     177                      slots)))))))
    168178
    169179;;; define-foreign-enum-type
    170  
     180
    171181(require-library matchable)
    172182(import-for-syntax matchable)
Note: See TracChangeset for help on using the changeset viewer.