Changeset 14310 in project


Ignore:
Timestamp:
04/20/09 05:48:28 (10 years ago)
Author:
Jim Ursetto
Message:

foreigners: fix foreign-lambda* expansion

Location:
release/4/foreigners/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/foreigners/trunk/foreigners.scm

    r13841 r14310  
    6565          (##sys#hash-table-set! ##compiler#foreign-type-table tname `(c-pointer ,fname))
    6666
    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                                              '() ))))
     67          (let ((%void 'void)  ; foreign-lambda* does not recognize renamed type identifiers
     68                (%int 'int))
     69            (with-renamed r
     70                (declare foreign-declare begin define foreign-lambda*
     71                 if let lambda declare 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                                               '() ))))
    157157                             
    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)))))))
     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))))))))
    178178
    179179;;; define-foreign-enum-type
  • release/4/foreigners/trunk/foreigners.setup

    r13518 r14310  
    44 'foreigners
    55 '("foreigners.so" "foreigners.import.so")
    6  '((version 1.0) (syntax)))
     6 '((version 1.2) (syntax)))
Note: See TracChangeset for help on using the changeset viewer.