~ chicken-core (chicken-5) 7d328f154de19f941899586ce9d6d62ca4580036

commit 7d328f154de19f941899586ce9d6d62ca4580036
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Apr 11 08:31:39 2011 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Mon Apr 11 08:31:39 2011 +0200

    strip foreign-result type in finish-foreign-result (patch by sjamaan)

diff --git a/support.scm b/support.scm
index d2fde7af..1b7bd317 100644
--- a/support.scm
+++ b/support.scm
@@ -1119,36 +1119,37 @@
 ;;; Convert result value, if a string:
 
 (define (finish-foreign-result type body)
-  (case type
-    [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
-    [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
-    [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
-    [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
-    [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
-    [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
-    [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
-    [else
-     (if (list? type)
-	 (if (and (eq? (car type) 'const)
-		  (= 2 (length type))
-		  (memq (cadr type) '(c-string c-string* unsigned-c-string
-					       unsigned-c-string* nonnull-c-string
-					       nonnull-c-string*
-					       nonnull-unsigned-string*)))
-	     (finish-foreign-result (cadr type) body)
-	     (if (= 3 (length type))
-		 (case (car type)
-		   ((instance instance-ref)
-		    (let ((tmp (gensym)))
-		      `(let ((,tmp ,body))
-			 (and ,tmp
-			      (not (##sys#null-pointer? ,tmp))
-			      (make ,(caddr type) 'this ,tmp) ) ) ) )
-		   ((nonnull-instance)
-		    `(make ,(caddr type) 'this ,body) )
-		   (else body))
-		 body))
-	 body)]))
+  (let ((type (##sys#strip-syntax type)))
+    (case type
+      [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
+      [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
+      [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
+      [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
+      [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
+      [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
+      [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
+      [else
+       (if (list? type)
+	   (if (and (eq? (car type) 'const)
+		    (= 2 (length type))
+		    (memq (cadr type) '(c-string c-string* unsigned-c-string
+						 unsigned-c-string* nonnull-c-string
+						 nonnull-c-string*
+						 nonnull-unsigned-string*)))
+	       (finish-foreign-result (cadr type) body)
+	       (if (= 3 (length type))
+		   (case (car type)
+		     ((instance instance-ref)
+		      (let ((tmp (gensym)))
+			`(let ((,tmp ,body))
+			   (and ,tmp
+				(not (##sys#null-pointer? ,tmp))
+				(make ,(caddr type) 'this ,tmp) ) ) ) )
+		     ((nonnull-instance)
+		      `(make ,(caddr type) 'this ,body) )
+		     (else body))
+		   body))
+	   body)])))
 
 
 ;;; Scan expression-node for variable usage:
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 43e308e1..f4feb011 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -125,6 +125,19 @@
     (fp)))
 
 
+;; "const" qualifier should have no visible effect in Scheme
+(define-syntax generate-external
+  (syntax-rules ()
+    ((_) (define-external
+           (print_foo ((const c-string) foo))
+           void
+           (assert (string? foo))
+           (print foo)))))
+(generate-external)
+((foreign-safe-lambda* void () 
+   "print_foo(\"bar\");"))
+
+
 ;;; compiler-syntax for map/for-each must be careful when the
 ;   operator may have side-effects (currently only lambda exprs and symbols
 ;   are allowed)