> 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 <fe...@call-with-current-continuation.org> 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 <kristianl...@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 <fe...@call-with-current-continuation.org> --- 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
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
