Re: [Chicken-hackers] feature patch: preserving argument names in foreign-lambda and friends

[Felix]

> Hi guys,
> 
> Here is a suggestion for a patch which will preserve argument-names of
> foreign-lambdas* and friends. Check out the commit-message attached for
> more info.
> 

Hey, nice. I have attached a slightly amended version, that handles
non-atomic types and which moves "type->symbol" inside the
"create-foreign-stub" procedure.


cheers,
felix

>From 6aabca2dd9cef2f5f4fbb3d3dc5f2de22d816135 Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sun, 30 Sep 2012 11:44:58 +0200
Subject: [PATCH] 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 <address@hidden>,
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 <address@hidden>
---
 compiler.scm |   17 ++++++++++++++++-
 1 files changed, 16 insertions(+), 1 deletions(-)

diff --git a/compiler.scm b/compiler.scm
index 94d178d..5f93164 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)] )
-- 
1.7.0.4