Changeset 26981 in project


Ignore:
Timestamp:
07/04/12 10:12:15 (9 years ago)
Author:
felix winkelmann
Message:

updated bind branch with code by kristianlm

Location:
release/4/bind/branches/struct-by-val
Files:
1 added
1 deleted
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/bind/branches/struct-by-val/bind-translator.scm

    r26549 r26981  
    850850                                       argt))]
    851851            [argdefs (map (lambda (atype index)
    852                             `(,atype ,(fix-name (conc "a" index) )))
     852                            `(,atype ,(->symbol (conc "a" index) )))
    853853                          argtypes (iota (length argtypes)))]
    854854            [call-stub (conc name "("
     
    894894                [io? (or (any identity io) (pair? lvars))]
    895895                [fname (if io? (gensym) name2)]
    896                 [%fname (fix-name (conc "%" fname))]
    897                 [%arglist (map (compose fix-name (cut conc "a" <>))
     896                [%fname (->symbol (conc fname "/overwrite!"))]
     897                [%arglist (map (compose ->symbol (cut conc "a" <>))
    898898                               (iota (length args)))]
    899899                [%def-fun (lambda (fname)
     
    901901                             ,(c-exception-wrapper (->string name) args cb rtype)))]
    902902                [def-fun (lambda (fname)
    903                            `(,(rename 'define) (,(fix-name fname) ,@%arglist)
     903                           `(,(rename 'define) (,fname ,@%arglist)
    904904                             (let ([dest
    905905                                    (location (make-blob (foreign-value
     
    10051005   (reverse items) ) )
    10061006
    1007 (define (gen-struct-stack-allocation-stub return-struct data)
    1008   (conc "
    1009 C_word ab [C_bytestowords(sizeof(C_header) + sizeof(struct " return-struct "))];
    1010 *((struct " return-struct "*)C_data_pointer(ab)) = " data ";
    1011 ab [0] = C_BYTEVECTOR_TYPE | sizeof(struct " return-struct ");
    1012 C_return(ab);"))
    1013 
    10141007(define (process-struct-member-def m sname name type mut?)
    1015   (let* ([getter (fix-name (string-append (->string sname) "-" (->string name)))]
    1016          [%getter (fix-name (string-append "%" (->string getter)))])
    1017     (let* ((rsname (->string (struct-name type)))
    1018            (args `((c-pointer (,m ,sname)) s))
    1019            (%g (if (struct-by-val? type)
    1020                   `(,(rename 'foreign-primitive) scheme-object (,args)
    1021                     ,(gen-struct-stack-allocation-stub rsname
    1022                                                        (conc "s->" (->string name))))
     1008  (let* ([getter (fix-name (string-append (->string sname) "-" (->string name)))] ; name of procedure
     1009         [args `((c-pointer (,m ,sname)) s)] ; foreign-lambda*-style arguments
     1010         ;; getter body
     1011         [g  (if (struct-by-val? type)
     1012                 ;; getter body where type is another struct
     1013                 `(,(rename 'lambda) (s)
     1014                   (let ([blob (location
     1015                                (,(rename 'make-blob)
     1016                                 (,(rename 'foreign-value) ,(sprintf "sizeof~A" type) int)) )]
     1017                         [copy-struct! (,(rename 'foreign-lambda*) void (((c-pointer ,type) _dest) ,args)
     1018                                        ,(sprintf "*_dest = s->~A;" name))])
     1019                     (copy-struct! blob s)
     1020                     blob))
     1021                 ;; getter body for primitive types
    10231022                 `(,(rename 'foreign-lambda*) ,type (,args)
    1024                    ,(sprintf "return(s->~A);" name) )) )
    1025           (s `(,(rename 'foreign-lambda*) void (,args
    1026                                                 (,type x) )
    1027                ,(sprintf "s->~A = x;" name) ) )
    1028           (%def (lambda (getter-name)
    1029                   (if mut?
    1030                        `(,(rename 'define) ,getter-name (,(rename 'getter-with-setter) ,%g ,s))
    1031                        `(,(rename 'define) ,getter-name ,%g) )))
    1032           (def (lambda (getter-name)
    1033                  `(define (,getter-name s) (location (,%getter s))))))
    1034       (emit (if (struct-by-val? type)
    1035                 `(begin ,(%def %getter)
    1036                         ,(def getter))
    1037                 `(begin ,(%def getter))))) ) )
     1023                   ,(sprintf "return(s->~A);" name) )) ]
     1024         ;; setter body
     1025         [s  `(,(rename 'foreign-lambda*) void (,args (,type x) )
     1026               ,(sprintf "s->~A = x;" name) ) ])
     1027    (emit (if mut?
     1028              (if (struct-by-val? type)
     1029                  (error "mutable nested structs not supported" (conc type " " name " in struct " sname))
     1030                  `(,(rename 'define) ,getter (,(rename 'getter-with-setter) ,g ,s)))
     1031              `(,(rename 'define) ,getter ,g) ) ) ) )
    10381032
    10391033(define (process-class-def name cname basenames)
  • release/4/bind/branches/struct-by-val/bind.scm

    r25986 r26981  
    5050  (lambda (x r c)
    5151    (set! ffi-include-path-list (append (cdr x) ffi-include-path-list))
    52     '(,(r 'void) ) ) )
     52    `(,(r 'void) ) ) )
    5353
    5454(define-syntax (bind-type x r c)
  • release/4/bind/branches/struct-by-val/bind.setup

    r25986 r26981  
    11;; bind.setup  -*- Scheme -*-
    22
    3 (define version "0.991")
     3(define version "0.992")
    44
    55(make (("c.l.scm" ("c.l")
  • release/4/bind/branches/struct-by-val/tests/run.scm

    r26512 r26981  
    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))
    11 
    12 (run (csc struct-by-value-test.scm -debug F -c++))
    13 (run (./struct-by-value-test))
Note: See TracChangeset for help on using the changeset viewer.