Changeset 27014 in project


Ignore:
Timestamp:
07/07/12 22:29:46 (9 years ago)
Author:
felix winkelmann
Message:

bind 1.0: struct-by-value support (by kristianlm)

Location:
release/4/bind
Files:
9 edited
3 copied

Legend:

Unmodified
Added
Removed
  • release/4/bind/tags/1.0

  • release/4/bind/tags/1.0/bind-translator.scm

    r26960 r27014  
    524524    [_ (parsing-error "invalid enum syntax" ts)] ) )
    525525
     526(define (struct-name arg-def)
     527  (let loop ((arg-def arg-def))
     528    (match arg-def
     529      [('struct sname) sname]
     530      [('const ('struct sname))  sname]
     531      [else (if (list? arg-def) (loop (car arg-def)) #f)])))
     532
     533(define struct-by-val? struct-name)
     534
     535; ((const (struct "mystruct")) name) -> (((c-pointer (const ... ))) name)
     536(define (wrap-in-pointer arg-def)
     537  (let loop ((arg-def arg-def))
     538    (match arg-def
     539      (('struct _) `(c-pointer ,arg-def))
     540      (('const ('struct _)) `(c-pointer ,arg-def))
     541      (else (if (list? arg-def)
     542                `(,(loop (car arg-def)) ,@(cdr arg-def))
     543                arg-def)))) )
     544
    526545(define (parse-struct-def m sname ab ts)
    527546  (let ([fields '()])
     
    550569                    sname more))] ) ) ) ) )
    551570    (unless ab
    552       (let ([maker (fix-name (string-append "make-" (->string sname)))]
    553             [fields (reverse fields)] )
     571      (let* ([maker (fix-name (string-append "make-" (->string sname)))]
     572             [fields (reverse fields)]
     573             [argfields (map (lambda (f) (if (struct-by-val? f)
     574                                        (wrap-in-pointer f)
     575                                        f)) fields)])
    554576        (emit
    555577         `(,(rename 'define) ,maker
    556            (,(rename 'foreign-lambda*) (c-pointer (,m ,sname)) ,fields
     578           (,(rename 'foreign-lambda*) (c-pointer (,m ,sname)) ,argfields
    557579            ,(sprintf "~A ~A *tmp_ = (~A ~A *)C_malloc(sizeof(~A ~A));~%~AC_return(tmp_);"
    558                m sname m sname m sname
    559                (string-intersperse
    560                 (map (lambda (f) (sprintf "tmp_->~A = ~A;~%" (cadr f) (cadr f)))
    561                      fields)
    562                 "") ) ) ) ) ) ) ) )
     580                      m sname m sname m sname
     581                      (string-intersperse
     582                       (map (lambda (f) (sprintf "tmp_->~A = ~A~A;~%~n"
     583                                            (cadr f)
     584                                            (if (struct-by-val? f) "*" "")
     585                                            (cadr f)))
     586                            fields)
     587                       "") ) ) ) ) ) ) ) )
    563588
    564589(define (parse-typedef ts)
     
    819844              (cdr c-exception-handler) "\n"
    820845              (if (eq? 'void rtype) "" (sprintf "return(~a);" rvar))))))
    821       `(,(rename (if safe 'foreign-safe-lambda 'foreign-lambda))
    822         ,rtype ,name ,@argtypes)))
     846      (let* ([rstruct? (struct-by-val? rtype)]
     847             [any-struct-arg? (or rstruct? (any struct-by-val? argtypes))]
     848             [maybe-wrap-arg  (lambda (argt) (if (struct-by-val? argt)
     849                                       (wrap-in-pointer argt)
     850                                       argt))]
     851            [argdefs (map (lambda (atype index)
     852                            `(,atype ,(->symbol (conc "a" index) )))
     853                          argtypes (iota (length argtypes)))]
     854            [call-stub (conc name "("
     855                              (string-intersperse
     856                               (map (lambda (a)
     857                                      (if (struct-by-val? a)
     858                                          (conc "*" (cadr a))
     859                                          (conc (cadr a)))) argdefs)
     860                               ",") ")")]
     861            [call-stub-ret (sprintf (cond [(eq? 'void rtype) "~a;"]
     862                                       [rstruct? "*dest=(~a);"]
     863                                       [else "C_return(~a);"])
     864                                 call-stub)]
     865            [wrapped-args (map maybe-wrap-arg argdefs)])
     866        (if any-struct-arg?
     867           `(,(rename (if safe 'foreign-primitive 'foreign-lambda*))
     868             ,(if rstruct? 'void rtype)
     869             ,(if rstruct?
     870                  `(((c-pointer ,rtype) dest) ,@wrapped-args)
     871                  wrapped-args) ,call-stub-ret)
     872           `(,(rename (if safe 'foreign-safe-lambda 'foreign-lambda))
     873             ,rtype ,name ,@argtypes)))))
    823874
    824875(define (process-prototype-def rtype name args io lvars cb #!optional (use-prefix #t))
     
    842893         (let* ([vars (map (lambda (x) (gensym)) args)]
    843894                [io? (or (any identity io) (pair? lvars))]
    844                 [fname (if io? (gensym) name2)] )
     895                [fname (if io? (gensym) name2)]
     896                [%fname (->symbol (conc fname "/overwrite!"))]
     897                [%arglist (map (compose ->symbol (cut conc "a" <>))
     898                               (iota (length args)))]
     899                [%def-fun (lambda (fname)
     900                            `(,(rename 'define) ,fname
     901                             ,(c-exception-wrapper (->string name) args cb rtype)))]
     902                [def-fun (lambda (fname)
     903                           `(,(rename 'define) (,fname ,@%arglist)
     904                             (let ([dest
     905                                    (location (make-blob (foreign-value
     906                                                          ,(conc "sizeof" rtype)
     907                                                          int)))])
     908                               (,%fname dest ,@%arglist)
     909                               dest)))])
    845910           `(,(rename 'begin)
    846               ,@(if io? `((,(rename 'declare) (hide ,fname))) '())
    847               (,(rename 'define) ,fname
    848                 ,(c-exception-wrapper (->string name) args cb rtype))
    849               ,@(if io?
    850                     (let ([inlist (filter-map (lambda (var io i)
    851                                                 (and (memq io '(#f in inout))
    852                                                      (not (assq i lvars))
    853                                                      var) )
    854                                               vars io (iota (length vars))) ] )
    855                       `((,(rename 'define) (,name2 ,@inlist)
    856                           ,(make-inout-wrapper fname rtype vars args io lvars) ) ) )
    857                     '() ) ) ) ) ) ) )
     911             ,@(if io? `((,(rename 'declare) (hide ,fname))) '())
     912             ,(if (struct-by-val? rtype)
     913                  `(begin ,(%def-fun %fname)
     914                          ,(def-fun fname))
     915                  (%def-fun fname))
     916             ,@(if io?
     917                   (let ([inlist (filter-map (lambda (var io i)
     918                                               (and (memq io '(#f in inout))
     919                                                    (not (assq i lvars))
     920                                                    var) )
     921                                             vars io (iota (length vars))) ] )
     922                     `((,(rename 'define) (,name2 ,@inlist)
     923                        ,(make-inout-wrapper fname rtype vars args io lvars) ) ) )
     924                   '() ) ) ) ) ) ) )
    858925
    859926(define (make-inout-wrapper rname rtype vars args io lvars)
     
    9401007
    9411008(define (process-struct-member-def m sname name type mut?)
    942   (let ([getter (fix-name (string-append (->string sname) "-" (->string name)))])
    943     (let ((g `(,(rename 'foreign-lambda*) ,type (((c-pointer (,m ,sname)) s))
    944                ,(sprintf "return(s->~A);" name) ) )
    945           (s `(,(rename 'foreign-lambda*) void (((c-pointer (,m ,sname)) s)
    946                                                 (,type x) )
    947                 ,(sprintf "s->~A = x;" name) ) ) )
    948       (emit
    949        (if mut?
    950            `(,(rename 'define) ,getter (,(rename 'getter-with-setter) ,g ,s))
    951            `(,(rename 'define) ,getter ,g) ) ) ) ) )
     1009  (let* ([getter (fix-name (string-append (->string sname) "-" (->string name)))] ; name of procedure
     1010         [args `((c-pointer (,m ,sname)) s)] ; foreign-lambda*-style arguments
     1011         ;; getter body
     1012         [g  (if (struct-by-val? type)
     1013                 ;; getter body where type is another struct
     1014                 `(,(rename 'lambda) (s)
     1015                   (let ([blob (location
     1016                                (,(rename 'make-blob)
     1017                                 (,(rename 'foreign-value) ,(sprintf "sizeof~A" type) int)) )]
     1018                         [copy-struct! (,(rename 'foreign-lambda*) void (((c-pointer ,type) _dest) ,args)
     1019                                        ,(sprintf "*_dest = s->~A;" name))])
     1020                     (copy-struct! blob s)
     1021                     blob))
     1022                 ;; getter body for primitive types
     1023                 `(,(rename 'foreign-lambda*) ,type (,args)
     1024                   ,(sprintf "return(s->~A);" name) )) ]
     1025         ;; setter body
     1026         [s  `(,(rename 'foreign-lambda*) void (,args (,type x) )
     1027               ,(sprintf "s->~A = x;" name) ) ])
     1028    (emit (if mut?
     1029              (if (struct-by-val? type)
     1030                  (error "mutable nested structs not supported" (conc type " " name " in struct " sname))
     1031                  `(,(rename 'define) ,getter (,(rename 'getter-with-setter) ,g ,s)))
     1032              `(,(rename 'define) ,getter ,g) ) ) ) )
    9521033
    9531034(define (process-class-def name cname basenames)
  • release/4/bind/tags/1.0/bind.meta

    r23255 r27014  
    77 (doc-from-wiki #t)
    88 (author "[[felix winkelmann]]")
    9  (files "bind-translator.scm" "bind.release-info" "bind.scm" "bind.meta" "cplusplus-object.scm" "c.l" "bind.setup" "runsilex.scm" "tests/cplusplus-test.scm" "tests/run.scm" "tests/tests.scm" "chicken-bind.scm"))
     9 (files "bind-translator.scm" "bind.release-info" "bind.scm" "bind.meta" "cplusplus-object.scm" "c.l" "bind.setup" "runsilex.scm" "tests/cplusplus-test.scm" "tests/run.scm" "tests/tests.scm" "tests/struct-passing-tests.scm" "chicken-bind.scm"))
    1010
  • release/4/bind/tags/1.0/bind.setup

    r26848 r27014  
    11;; bind.setup  -*- Scheme -*-
    22
    3 (define version "0.992")
     3(define version "1.0")
    44
    55(make (("c.l.scm" ("c.l")
  • release/4/bind/tags/1.0/tests/run.scm

    r18859 r27014  
    77(run (./tests))
    88
     9(run (csc struct-passing-tests.scm -debug F))
     10(run (./struct-passing-tests))
     11
    912(run (csc cplusplus-test.scm -debug F -c++))
    1013(run (./cplusplus-test))
  • release/4/bind/trunk

  • release/4/bind/trunk/bind-translator.scm

    r26960 r27014  
    524524    [_ (parsing-error "invalid enum syntax" ts)] ) )
    525525
     526(define (struct-name arg-def)
     527  (let loop ((arg-def arg-def))
     528    (match arg-def
     529      [('struct sname) sname]
     530      [('const ('struct sname))  sname]
     531      [else (if (list? arg-def) (loop (car arg-def)) #f)])))
     532
     533(define struct-by-val? struct-name)
     534
     535; ((const (struct "mystruct")) name) -> (((c-pointer (const ... ))) name)
     536(define (wrap-in-pointer arg-def)
     537  (let loop ((arg-def arg-def))
     538    (match arg-def
     539      (('struct _) `(c-pointer ,arg-def))
     540      (('const ('struct _)) `(c-pointer ,arg-def))
     541      (else (if (list? arg-def)
     542                `(,(loop (car arg-def)) ,@(cdr arg-def))
     543                arg-def)))) )
     544
    526545(define (parse-struct-def m sname ab ts)
    527546  (let ([fields '()])
     
    550569                    sname more))] ) ) ) ) )
    551570    (unless ab
    552       (let ([maker (fix-name (string-append "make-" (->string sname)))]
    553             [fields (reverse fields)] )
     571      (let* ([maker (fix-name (string-append "make-" (->string sname)))]
     572             [fields (reverse fields)]
     573             [argfields (map (lambda (f) (if (struct-by-val? f)
     574                                        (wrap-in-pointer f)
     575                                        f)) fields)])
    554576        (emit
    555577         `(,(rename 'define) ,maker
    556            (,(rename 'foreign-lambda*) (c-pointer (,m ,sname)) ,fields
     578           (,(rename 'foreign-lambda*) (c-pointer (,m ,sname)) ,argfields
    557579            ,(sprintf "~A ~A *tmp_ = (~A ~A *)C_malloc(sizeof(~A ~A));~%~AC_return(tmp_);"
    558                m sname m sname m sname
    559                (string-intersperse
    560                 (map (lambda (f) (sprintf "tmp_->~A = ~A;~%" (cadr f) (cadr f)))
    561                      fields)
    562                 "") ) ) ) ) ) ) ) )
     580                      m sname m sname m sname
     581                      (string-intersperse
     582                       (map (lambda (f) (sprintf "tmp_->~A = ~A~A;~%~n"
     583                                            (cadr f)
     584                                            (if (struct-by-val? f) "*" "")
     585                                            (cadr f)))
     586                            fields)
     587                       "") ) ) ) ) ) ) ) )
    563588
    564589(define (parse-typedef ts)
     
    819844              (cdr c-exception-handler) "\n"
    820845              (if (eq? 'void rtype) "" (sprintf "return(~a);" rvar))))))
    821       `(,(rename (if safe 'foreign-safe-lambda 'foreign-lambda))
    822         ,rtype ,name ,@argtypes)))
     846      (let* ([rstruct? (struct-by-val? rtype)]
     847             [any-struct-arg? (or rstruct? (any struct-by-val? argtypes))]
     848             [maybe-wrap-arg  (lambda (argt) (if (struct-by-val? argt)
     849                                       (wrap-in-pointer argt)
     850                                       argt))]
     851            [argdefs (map (lambda (atype index)
     852                            `(,atype ,(->symbol (conc "a" index) )))
     853                          argtypes (iota (length argtypes)))]
     854            [call-stub (conc name "("
     855                              (string-intersperse
     856                               (map (lambda (a)
     857                                      (if (struct-by-val? a)
     858                                          (conc "*" (cadr a))
     859                                          (conc (cadr a)))) argdefs)
     860                               ",") ")")]
     861            [call-stub-ret (sprintf (cond [(eq? 'void rtype) "~a;"]
     862                                       [rstruct? "*dest=(~a);"]
     863                                       [else "C_return(~a);"])
     864                                 call-stub)]
     865            [wrapped-args (map maybe-wrap-arg argdefs)])
     866        (if any-struct-arg?
     867           `(,(rename (if safe 'foreign-primitive 'foreign-lambda*))
     868             ,(if rstruct? 'void rtype)
     869             ,(if rstruct?
     870                  `(((c-pointer ,rtype) dest) ,@wrapped-args)
     871                  wrapped-args) ,call-stub-ret)
     872           `(,(rename (if safe 'foreign-safe-lambda 'foreign-lambda))
     873             ,rtype ,name ,@argtypes)))))
    823874
    824875(define (process-prototype-def rtype name args io lvars cb #!optional (use-prefix #t))
     
    842893         (let* ([vars (map (lambda (x) (gensym)) args)]
    843894                [io? (or (any identity io) (pair? lvars))]
    844                 [fname (if io? (gensym) name2)] )
     895                [fname (if io? (gensym) name2)]
     896                [%fname (->symbol (conc fname "/overwrite!"))]
     897                [%arglist (map (compose ->symbol (cut conc "a" <>))
     898                               (iota (length args)))]
     899                [%def-fun (lambda (fname)
     900                            `(,(rename 'define) ,fname
     901                             ,(c-exception-wrapper (->string name) args cb rtype)))]
     902                [def-fun (lambda (fname)
     903                           `(,(rename 'define) (,fname ,@%arglist)
     904                             (let ([dest
     905                                    (location (make-blob (foreign-value
     906                                                          ,(conc "sizeof" rtype)
     907                                                          int)))])
     908                               (,%fname dest ,@%arglist)
     909                               dest)))])
    845910           `(,(rename 'begin)
    846               ,@(if io? `((,(rename 'declare) (hide ,fname))) '())
    847               (,(rename 'define) ,fname
    848                 ,(c-exception-wrapper (->string name) args cb rtype))
    849               ,@(if io?
    850                     (let ([inlist (filter-map (lambda (var io i)
    851                                                 (and (memq io '(#f in inout))
    852                                                      (not (assq i lvars))
    853                                                      var) )
    854                                               vars io (iota (length vars))) ] )
    855                       `((,(rename 'define) (,name2 ,@inlist)
    856                           ,(make-inout-wrapper fname rtype vars args io lvars) ) ) )
    857                     '() ) ) ) ) ) ) )
     911             ,@(if io? `((,(rename 'declare) (hide ,fname))) '())
     912             ,(if (struct-by-val? rtype)
     913                  `(begin ,(%def-fun %fname)
     914                          ,(def-fun fname))
     915                  (%def-fun fname))
     916             ,@(if io?
     917                   (let ([inlist (filter-map (lambda (var io i)
     918                                               (and (memq io '(#f in inout))
     919                                                    (not (assq i lvars))
     920                                                    var) )
     921                                             vars io (iota (length vars))) ] )
     922                     `((,(rename 'define) (,name2 ,@inlist)
     923                        ,(make-inout-wrapper fname rtype vars args io lvars) ) ) )
     924                   '() ) ) ) ) ) ) )
    858925
    859926(define (make-inout-wrapper rname rtype vars args io lvars)
     
    9401007
    9411008(define (process-struct-member-def m sname name type mut?)
    942   (let ([getter (fix-name (string-append (->string sname) "-" (->string name)))])
    943     (let ((g `(,(rename 'foreign-lambda*) ,type (((c-pointer (,m ,sname)) s))
    944                ,(sprintf "return(s->~A);" name) ) )
    945           (s `(,(rename 'foreign-lambda*) void (((c-pointer (,m ,sname)) s)
    946                                                 (,type x) )
    947                 ,(sprintf "s->~A = x;" name) ) ) )
    948       (emit
    949        (if mut?
    950            `(,(rename 'define) ,getter (,(rename 'getter-with-setter) ,g ,s))
    951            `(,(rename 'define) ,getter ,g) ) ) ) ) )
     1009  (let* ([getter (fix-name (string-append (->string sname) "-" (->string name)))] ; name of procedure
     1010         [args `((c-pointer (,m ,sname)) s)] ; foreign-lambda*-style arguments
     1011         ;; getter body
     1012         [g  (if (struct-by-val? type)
     1013                 ;; getter body where type is another struct
     1014                 `(,(rename 'lambda) (s)
     1015                   (let ([blob (location
     1016                                (,(rename 'make-blob)
     1017                                 (,(rename 'foreign-value) ,(sprintf "sizeof~A" type) int)) )]
     1018                         [copy-struct! (,(rename 'foreign-lambda*) void (((c-pointer ,type) _dest) ,args)
     1019                                        ,(sprintf "*_dest = s->~A;" name))])
     1020                     (copy-struct! blob s)
     1021                     blob))
     1022                 ;; getter body for primitive types
     1023                 `(,(rename 'foreign-lambda*) ,type (,args)
     1024                   ,(sprintf "return(s->~A);" name) )) ]
     1025         ;; setter body
     1026         [s  `(,(rename 'foreign-lambda*) void (,args (,type x) )
     1027               ,(sprintf "s->~A = x;" name) ) ])
     1028    (emit (if mut?
     1029              (if (struct-by-val? type)
     1030                  (error "mutable nested structs not supported" (conc type " " name " in struct " sname))
     1031                  `(,(rename 'define) ,getter (,(rename 'getter-with-setter) ,g ,s)))
     1032              `(,(rename 'define) ,getter ,g) ) ) ) )
    9521033
    9531034(define (process-class-def name cname basenames)
  • release/4/bind/trunk/bind.meta

    r23255 r27014  
    77 (doc-from-wiki #t)
    88 (author "[[felix winkelmann]]")
    9  (files "bind-translator.scm" "bind.release-info" "bind.scm" "bind.meta" "cplusplus-object.scm" "c.l" "bind.setup" "runsilex.scm" "tests/cplusplus-test.scm" "tests/run.scm" "tests/tests.scm" "chicken-bind.scm"))
     9 (files "bind-translator.scm" "bind.release-info" "bind.scm" "bind.meta" "cplusplus-object.scm" "c.l" "bind.setup" "runsilex.scm" "tests/cplusplus-test.scm" "tests/run.scm" "tests/tests.scm" "tests/struct-passing-tests.scm" "chicken-bind.scm"))
    1010
  • release/4/bind/trunk/bind.setup

    r26848 r27014  
    11;; bind.setup  -*- Scheme -*-
    22
    3 (define version "0.992")
     3(define version "1.0")
    44
    55(make (("c.l.scm" ("c.l")
  • release/4/bind/trunk/tests/run.scm

    r18859 r27014  
    77(run (./tests))
    88
     9(run (csc struct-passing-tests.scm -debug F))
     10(run (./struct-passing-tests))
     11
    912(run (csc cplusplus-test.scm -debug F -c++))
    1013(run (./cplusplus-test))
Note: See TracChangeset for help on using the changeset viewer.