~ chicken-core (chicken-5) a0bb345a4ad94e70e61a5cb9ae0247c809dcc3ad

commit a0bb345a4ad94e70e61a5cb9ae0247c809dcc3ad
Author:     LemonBoy <thatlemon@gmail.com>
AuthorDate: Wed Nov 8 15:56:21 2017 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sun Nov 12 09:35:47 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 48a48402..212f40b2 100644
--- a/NEWS
+++ b/NEWS
@@ -42,6 +42,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 fcf0b0c1..a6c842ee 100644
--- a/support.scm
+++ b/support.scm
@@ -1198,6 +1198,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))]
 		 [else 0] ) ]
 	      [else 0] ) ) ) )
    (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
@@ -1226,6 +1227,7 @@
 		 [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
 		       scheme-pointer nonnull-scheme-pointer)
 		  (words->bytes 1)]
+		 [(const) (next (cadr t))]
 		 [else (err t)] ) ]
 	      [else (err t)] ) ) ) )
    (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 53de9711..4c2bf806 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -319,3 +319,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)))