~ chicken-core (chicken-5) f86a31d32f5cef4e297414251516d65b2bb39c33

commit f86a31d32f5cef4e297414251516d65b2bb39c33
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Sun Sep 30 11:44:58 2012 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun Sep 30 12:07:13 2012 +0100

    Compiler preserves argument names in foreign-lambda* and friends
    
    This is useful because if you print your procedures, the arguments
    will be a little more meaningful.
    
    This will preserve argument-names with foreign-lambda* and friends,
    or construct ones based on type with foreign-lambda and friends.
    
    Running this sample-snippet:
    
    (define fl* (foreign-lambda* void (((c-pointer (struct "point")) cursor)) "cursor->x=0;"))
    (define fl  (foreign-lambda  void "external_lambda" (c-pointer (struct "point"))))
    (print fl* "\n" fl)
    
    Before this patch:
      #<procedure (fl* a612)>
      #<procedure (fl a1519)>
    
    After this patch:
      #<procedure (fl* cursor712)>
      #<procedure (fl point*1519)>
    
    (Contributed by Kristian Lein-Mathisen <kristianlein@gmail.com>,
    slightly amended by felix to fallback on 'a in the non-list case
    and moving type->symbol inside create-foreign-stub to avoid exposing
    its global binding)
    
    Signed-off-by: felix <felix@call-with-current-continuation.org>
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/compiler.scm b/compiler.scm
index 94d178de..5f93164c 100644
--- a/compiler.scm
+++ b/compiler.scm
@@ -1575,9 +1575,24 @@
   (callback foreign-stub-callback))	       ; boolean
 
 (define (create-foreign-stub rtype sname argtypes argnames body callback cps)
+  ;; try to describe a foreign-lambda type specification
+  ;; eg. (type->symbol '(c-pointer (struct "point"))) => point*
+  (define (type->symbol type-spec)
+    (let loop ([type type-spec])
+      (cond
+       ((null? type) 'a)
+       ((list? type)
+	(case (car type)
+	  ((c-pointer) (string->symbol (conc (loop (cdr type)) "*"))) ;; if pointer, append *
+	  ((const struct) (loop (cdr type))) ;; ignore these
+	  (else (loop (car type)))))
+       ((or (symbol? type) (string? type)) type)
+       (else 'a))))
   (let* ((rtype (##sys#strip-syntax rtype))
 	 (argtypes (##sys#strip-syntax argtypes))
-	 [params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
+	 [params (if argnames
+                     (map gensym argnames)
+                     (map (o gensym type->symbol) argtypes))]
 	 [f-id (gensym 'stub)]
 	 [bufvar (gensym)] 
 	 [rsize (estimate-foreign-result-size rtype)] )