~ chicken-core (chicken-5) c3393980e383a8d46c9b335ad6455a8589e5183d

commit c3393980e383a8d46c9b335ad6455a8589e5183d
Author:     LemonBoy <thatlemon@gmail.com>
AuthorDate: Wed Nov 8 15:36:29 2017 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Nov 12 09:09:55 2017 +1300

    Correctly parse FFI types wrapped in `const' forms
    
    Keep parsing the cdr when calculating the total size of the type.
    
    Signed-off-by: Peter Bex <peter@more-magic.net>
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index d0927e58..7a495951 100644
--- a/NEWS
+++ b/NEWS
@@ -161,6 +161,10 @@
   - The scrutinizer no longer uses 'fixnum as the type for fixnums
     that might not fit into a fixnum on 32-bit architectures.
 
+- Foreign function interface
+  - Correctly calculate memory requirements of Scheme objects produced
+    from foreign types with "const" qualifiers, avoiding memory
+    corruption (#1424, thanks to Vasilij Schneidermann and Lemonboy)
 
 4.12.0
 
diff --git a/support.scm b/support.scm
index 905f7ae8..9402309e 100644
--- a/support.scm
+++ b/support.scm
@@ -1183,6 +1183,7 @@
 	       (case (car t)
 		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance) 
 		  (words->bytes 3) )
+		 ((const) (next (cadr t)))
 		 ((enum) (words->bytes 6)) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
 		 (else (err t))))
 	      (else (err t))))))
@@ -1211,6 +1212,7 @@
 		 ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
 		       scheme-pointer nonnull-scheme-pointer enum)
 		  (words->bytes 1))
+		 ((const) (next (cadr t)))
 		 (else (err t)) ) )
 	      (else (err t)) ) ) ) )
    (lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index a4608279..bd150fe2 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -426,3 +426,12 @@
  (define (also-do-it arg)
    (get-value arg 3))
 )
+
+; let-location with const-wrapped type
+(let-location ((foo (const c-string) "boo"))
+  (assert (equal? foo "boo")))
+
+; #1424: a foreign lambda with const return type was wrongly rejected
+(let ((v0 ((foreign-lambda* c-string () "C_return(\"str\");")))
+      (v1 ((foreign-lambda* (const c-string) () "C_return(\"str\");"))))
+  (assert (equal? v0 v1)))