~ chicken-core (chicken-5) 812b52ea9ad7cf5e50c12c568c330f6462284772

commit 812b52ea9ad7cf5e50c12c568c330f6462284772
Author:     Peter Bex <peter@more-magic.net>
AuthorDate: Sat Jan 30 14:23:47 2016 +0100
Commit:     Evan Hanson <evhan@foldling.org>
CommitDate: Sat Jan 30 14:23:47 2016 +0100

    Don't silently truncate huge literals
    
    Instead stop compilation and show an error.  Unfortunately, we can't
    really show the object that caused it to bomb, because that would be too
    large to print.
    
    Don't constant-fold expressions that result in such an unencodeable
    literal.
    
    Signed-off-by: Evan Hanson <evhan@foldling.org>

diff --git a/NEWS b/NEWS
index 401a1922..777a6be8 100644
--- a/NEWS
+++ b/NEWS
@@ -23,6 +23,7 @@
   - Compiler rewrites for char{<,>,<=,>=,=}? are now safe (#1122).
   - When requesting to emit import libraries that don't exist, the
      compiler now gives an error instead of quietly continuing (#1188).
+  - Don't silently truncate huge literals (thanks to Claude Marinier).
 
 - Core libraries
    - SRFI-18: thread-join! no longer gives an error when passed a
diff --git a/c-backend.scm b/c-backend.scm
index c534bedb..d61b59ab 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -1364,10 +1364,15 @@ return((C_header_bits(lit) >> 24) & 0xff);
     (foreign-lambda* int ((scheme-object lit))
       "return(C_header_size(lit));"))
   (define (encode-size n)
-    ;; only handles sizes in the 24-bit range!
-    (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
-	    (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
-	    (integer->char (bitwise-and #xff n))))
+    (if (not (zero? (arithmetic-shift n -24)))
+	;; Unfortunately we can't do much more to help the user.
+	;; Printing the literal is not helpful because it's *huge*,
+	;; and we have no line number information here.
+	(quit "Encoded literal size of ~S is too large (must fit in 24 bits)" n)
+	(string
+	 (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
+	 (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
+	 (integer->char (bitwise-and #xff n)))))
   (define (finish str)		   ; can be taken out at a later stage
     (string-append (string #\xfe) str))
   (finish
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
index 1df475f2..408ad2c3 100644
--- a/compiler-namespace.scm
+++ b/compiler-namespace.scm
@@ -115,6 +115,7 @@
  enable-inline-files
  enable-specialization
  encode-literal
+ encodeable-literal?
  eq-inline-operator
  estimate-foreign-result-location-size
  estimate-foreign-result-size
diff --git a/support.scm b/support.scm
index 28437ff6..f28d9949 100644
--- a/support.scm
+++ b/support.scm
@@ -1487,19 +1487,48 @@
 (define (constant-form-eval op argnodes k)
   (let* ((args (map (lambda (n) (first (node-parameters n))) argnodes))
 	 (form (cons op (map (lambda (arg) `(quote ,arg)) args))))
-    (handle-exceptions ex 
-	(begin
-	  (k #f form #f (get-condition-property ex 'exn 'message)))
-      ;; op must have toplevel binding, result must be single-valued
-      (let ((proc (##sys#slot op 0)))
-	(if (procedure? proc)
-	    (let ((results (receive (apply proc args))))
-	      (cond ((= 1 (length results))
-		     (debugging 'o "folded constant expression" form)
-		     (k #t form (car results) #f))
-		    (else 
-		     (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
-	    (bomb "attempt to constant-fold call to non-procedure" form))))))
+    ;; op must have toplevel binding, result must be single-valued
+    (let ((proc (##sys#slot op 0)))
+      (if (procedure? proc)
+	  (let ((results (handle-exceptions ex
+			     (k #f form #f
+				(get-condition-property ex 'exn 'message))
+			   (receive (apply proc args)))))
+	    (cond ((node? results) ; TODO: This should not happen
+		   (k #f form #f #f))
+		  ((and (= 1 (length results))
+			(encodeable-literal? (car results)))
+		   (debugging 'o "folded constant expression" form)
+		   (k #t form (car results) #f))
+		  ((= 1 (length results)) ; not encodeable; don't fold
+		   (k #f form #f #f))
+		  (else
+		   (bomb "attempt to constant-fold call to procedure that has multiple results" form))))
+	  (bomb "attempt to constant-fold call to non-procedure" form)))))
+
+;; Is the literal small enough to be encoded?  Otherwise, it should
+;; not be constant-folded.
+(define (encodeable-literal? lit)
+  (define getsize
+    (foreign-lambda* int ((scheme-object lit))
+      "return(C_header_size(lit));"))
+  (define (fits? n)
+    (zero? (arithmetic-shift n -24)))
+  (cond ((immediate? lit))
+	((fixnum? lit))
+	((flonum? lit))
+	((symbol? lit)
+	 (let ((str (##sys#slot lit 1)))
+	   (fits? (string-length str))))
+	((##core#inline "C_byteblockp" lit)
+	 (fits? (getsize lit)))
+	(else
+	 (let ((len (getsize lit)))
+	   (and (fits? len)
+		(every
+		 encodeable-literal?
+		 (list-tabulate len (lambda (i)
+				      (##sys#slot lit i)))))))))
 
 
 ;;; Dump node structure: