Changeset 14590 in project


Ignore:
Timestamp:
05/11/09 13:49:45 (11 years ago)
Author:
felix winkelmann
Message:

applied patch by sjaaman for stripping FFI form variables

Location:
chicken/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • chicken/trunk/compiler.scm

    r14511 r14590  
    984984
    985985                        ((foreign-lambda)
    986                          (walk (expand-foreign-lambda x) e se dest) )
     986                         (walk (expand-foreign-lambda x #f) e se dest) )
    987987
    988988                        ((foreign-safe-lambda)
    989                          (walk (expand-foreign-callback-lambda x) e se dest) )
     989                         (walk (expand-foreign-lambda x #t) e se dest) )
    990990
    991991                        ((foreign-lambda*)
    992                          (walk (expand-foreign-lambda* x) e se dest) )
     992                         (walk (expand-foreign-lambda* x #f) e se dest) )
    993993
    994994                        ((foreign-safe-lambda*)
    995                          (walk (expand-foreign-callback-lambda* x) e se dest) )
     995                         (walk (expand-foreign-lambda* x #t) e se dest) )
    996996
    997997                        ((foreign-primitive)
     
    15281528                     rtype) ) ) ) ) ) ) )
    15291529
    1530 (define (expand-foreign-lambda exp)
     1530(define (expand-foreign-lambda exp callback?)
    15311531  (let* ([name (third exp)]
    1532          [sname (cond ((symbol? name) (symbol->string name))
     1532         [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
    15331533                      ((string? name) name)
    15341534                      (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    15351535         [rtype (second exp)]
    15361536         [argtypes (cdddr exp)] )
    1537     (create-foreign-stub rtype sname argtypes #f #f #f #f) ) )
    1538 
    1539 (define (expand-foreign-callback-lambda exp)
    1540   (let* ([name (third exp)]
    1541          [sname (cond ((symbol? name) (symbol->string name))
    1542                       ((string? name) name)
    1543                       (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
    1544          [rtype (second exp)]
    1545          [argtypes (cdddr exp)] )
    1546     (create-foreign-stub rtype sname argtypes #f #f #t #t) ) )
    1547 
    1548 (define (expand-foreign-lambda* exp)
     1537    (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
     1538
     1539(define (expand-foreign-lambda* exp callback?)
    15491540  (let* ([rtype (second exp)]
    15501541         [args (third exp)]
    15511542         [body (apply string-append (cdddr exp))]
    15521543         [argtypes (map car args)]
    1553          [argnames (map cadr args)] )
    1554     (create-foreign-stub rtype #f argtypes argnames body #f #f) ) )
    1555 
    1556 (define (expand-foreign-callback-lambda* exp)
    1557   (let* ([rtype (second exp)]
    1558          [args (third exp)]
    1559          [body (apply string-append (cdddr exp))]
    1560          [argtypes (map car args)]
    1561          [argnames (map cadr args)] )
    1562     (create-foreign-stub rtype #f argtypes argnames body #t #t) ) )
    1563 
     1544         ;; C identifiers aren't hygienically renamed inside body strings
     1545         [argnames (map cadr (##sys#strip-syntax args))] )
     1546    (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
     1547
     1548;; TODO: Try to fold this procedure into expand-foreign-lambda*
    15641549(define (expand-foreign-primitive exp)
    15651550  (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
    15661551         [rtype (if hasrtype (second exp) 'void)]
    1567          [args (if hasrtype (third exp) (second exp))]
     1552         [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
    15681553         [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
    15691554         [argtypes (map car args)]
    1570          [argnames (map cadr args)] )
     1555         ;; C identifiers aren't hygienically renamed inside body strings
     1556         [argnames (map cadr (##sys#strip-syntax args))] )
    15711557    (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
    15721558
  • chicken/trunk/tests/compiler-tests.scm

    r12201 r14590  
    4949(import x)
    5050(bar 42)
     51
     52;;; rev. 14574 (reported by Peter Bex)
     53;
     54; - type specifiers in foreign-lambda in macros are incorrectly renamed
     55; - variable names and type specifiers in foreign-lambda* and
     56;    foreign-primitive in macros are incorrectly renamed
     57
     58(let-syntax ((strlen-macro
     59              (syntax-rules ()
     60                ((strlen-macro arg)
     61                 (print ((foreign-lambda int strlen c-string) arg)))))
     62             (strlen-macro*
     63              (syntax-rules ()
     64                ((strlen-macro* arg)
     65                 (print ((foreign-lambda* int ((c-string str))
     66                                          "C_return(strlen(str));") arg)))))
     67             (strlen-safe-macro
     68              (syntax-rules ()
     69                ((strlen-safe-macro arg)
     70                 (print ((foreign-safe-lambda int strlen c-string) arg)))))
     71             (strlen-safe-macro*
     72              (syntax-rules ()
     73                ((strlen-safe-macro* arg)
     74                 (print ((foreign-safe-lambda* int ((c-string str))
     75                                               "C_return(strlen(str));") arg)))))
     76             (strlen-primitive-macro
     77              (syntax-rules ()
     78                ((strlen-primitive-macro* arg)
     79                 (print ((foreign-primitive int ((c-string str))
     80                                            "C_return(strlen(str));") arg))))))
     81  (strlen-macro "hello, world")
     82  (strlen-macro* "hello, world")
     83  (strlen-safe-macro "hello, world")
     84  (strlen-safe-macro* "hello, world")
     85  (strlen-primitive-macro "hello, world"))
Note: See TracChangeset for help on using the changeset viewer.