Changeset 11798 in project


Ignore:
Timestamp:
08/29/08 10:48:57 (13 years ago)
Author:
felix winkelmann
Message:

experimental support for exception wrapper code

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/easyffi/easyffi-base.scm

    r11740 r11798  
    4646(define use-finalizers #f)
    4747(define exception-handler #f)
     48(define c-exception-handler #f)
    4849(define destructor-name 'destroy)
    4950(define pp-mode #f)
     
    793794      (emit `(define ,name ,name)))))
    794795
     796(define (c-exception-wrapper name argtypes safe rtype)
     797  (if c-exception-handler
     798      (let ((vars (map (lambda _ (gensym "a")) argtypes)))
     799        `(,(if safe 'foreign-safe-lambda* 'foreign-lambda*)
     800          ,rtype ,(map list argtypes vars)
     801          ,(let ((rvar (->string (gensym "r"))))
     802             (string-append
     803              (if (eq? 'void rtype)
     804                  ""
     805                  (sprintf "~a;\n" (foreign-type-declaration rtype rvar)))
     806              (car c-exception-handler) "\n"
     807              (if (eq? 'void rtype) "" (sprintf "~a=" rvar))
     808              (sprintf "~a(~a)" name (string-intersperse (map ->string vars) ","))
     809              ";\n"
     810              (cdr c-exception-handler) "\n"
     811              (if (eq? 'void rtype) "" (sprintf "return(~a);" rvar))))))
     812      `(,(if safe 'foreign-safe-lambda 'foreign-lambda)
     813        ,rtype name ,@argtypes)))
     814
    795815(define (process-prototype-def rtype name args io lvars cb #!optional (use-prefix #t))
    796816  (let* ([name2 (fix-name name use-prefix)]
     
    802822           `(begin
    803823              (declare (hide ,tmp))
    804               (define ,tmp
    805                 (,(if cb 'foreign-safe-lambda 'foreign-lambda)
    806                  ,rtype ,(->string name) ,@args) )
     824              (define ,tmp
     825                ,(c-exception-wrapper (->string name) args cb rtype))
    807826              (define-method (,name2 ,@(filter-map (lambda (spec io i)
    808827                                                     (and (memq io '(#f in inout))
     
    816835              ,@(if io? `((declare (hide ,fname))) '())
    817836              (define ,fname
    818                 (,(if cb 'foreign-safe-lambda 'foreign-lambda)
    819                  ,rtype ,(->string name) ,@args))
     837                ,(c-exception-wrapper (->string name) args cb rtype))
    820838              ,@(if io?
    821839                    (let ([inlist (filter-map (lambda (var io i)
     
    942960     `(begin
    943961        (declare (hide ,constr))
    944         (define ,constr (foreign-lambda (pointer ,name) ,(string-append "new " name) ,@args))
     962        (define ,constr
     963          (foreign-lambda (pointer ,name) ,(string-append "new " name) ,@args))
    945964        (define-method (initialize (this ,cname) initargs)
    946965          ;; no CALL-NEXT-METHOD here: we don't want to invoke the base-class constructor.
     
    10371056    [("exception_handler" ('string code))
    10381057     (set! exception-handler code) ]
     1058    [("c_exception_handler" ('string code))
     1059     (let ((p (substring-index "###" code)))
     1060       (set! c-exception-handler
     1061         (cons (substring code 0 p) (substring code (+ p 3)))))]
    10391062    [("mutable_fields" ('id "yes"))
    10401063     (set! mutable-fields #t) ]
Note: See TracChangeset for help on using the changeset viewer.