From 717257249d8f4ae5abe0e98380855d81ea7e37ea Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Sun, 25 Aug 2019 12:23:05 +0200
Subject: [PATCH] Disallow exporting variables defined with define-external

When finalizing modules, explicitly check in compiled code whether
the export refers to a variable defined with "define-external".
Since such variables represent foreign memory, they do not follow Scheme
semantics and any changes to them will not be reflected by an associated
exported variable. Note that this is different for functions, these
can not change spontaneously as compared to (say) a volatile external
variable.
---
 core.scm    |  4 +++-
 modules.scm | 54 +++++++++++++++++++++++++++++-------------------------
 2 files changed, 32 insertions(+), 26 deletions(-)

diff --git a/core.scm b/core.scm
index bd36448b..9a51f04d 100644
--- a/core.scm
+++ b/core.scm
@@ -1019,7 +1019,9 @@
 						       ;; avoid backtrace
 						       (print-error-message ex (current-error-port))
 						       (exit 1))
-						   (##sys#finalize-module (##sys#current-module)))
+						   (##sys#finalize-module 
+                                                     (##sys#current-module)
+                                                     (map car foreign-variables)))
 						 (let ((il (or (assq name import-libraries) all-import-libraries)))
 						   (when il
 						     (emit-import-lib name il)
diff --git a/modules.scm b/modules.scm
index a7fb3f18..b1297632 100644
--- a/modules.scm
+++ b/modules.scm
@@ -444,7 +444,8 @@
 (define ##sys#finalize-module 
   (let ((display display)
 	(write-char write-char))
-    (lambda (mod)
+    (lambda (mod #!optional (bad-exports '())) 
+      ;; bad-exports: any list of symbols which should be rejected as invalid
       (let* ((explist (module-export-list mod))
 	     (name (module-name mod))
 	     (dlist (module-defined-list mod))
@@ -466,30 +467,33 @@
 		    '()
 		    (let* ((h (car xl))
 			   (id (if (symbol? h) h (car h))))
-		      (if (assq id sexports) 
-			  (loop (cdr xl))
-			  (cons 
-			   (cons 
-			    id
-			    (let ((def (assq id dlist)))
-			      (if (and def (symbol? (cdr def))) 
-				  (cdr def)
-				  (let ((a (assq id (##sys#current-environment))))
-				    (cond ((and a (symbol? (cdr a))) 
-					   (dm "reexporting: " id " -> " (cdr a))
-					   (cdr a)) 
-					  ((not def)
-					   (set! missing #t)
-					   (##sys#warn 
-					    (string-append 
-					     "exported identifier of module `" 
-					     (symbol->string name)
-					     "' has not been defined")
-					    id)
-					   #f)
-					  (else (module-rename id name)))))))
-			   (loop (cdr xl)))))))))
-	(for-each
+		      (cond ((assq id sexports) (loop (cdr xl)))
+                            ((memq id bad-exports)
+                             (##sys#error "special identifier may not be exported"
+                                          id))
+                            (else 
+                              (cons 
+                                (cons 
+			          id
+                                  (let ((def (assq id dlist)))
+                                    (if (and def (symbol? (cdr def))) 
+                                        (cdr def)
+                                        (let ((a (assq id (##sys#current-environment))))
+                                          (cond ((and a (symbol? (cdr a))) 
+                                                 (dm "reexporting: " id " -> " (cdr a))
+                                                 (cdr a)) 
+                                                ((not def)
+                                                 (set! missing #t)
+                                                 (##sys#warn 
+                                                   (string-append 
+					           "exported identifier of module `" 
+					           (symbol->string name)
+					           "' has not been defined")
+					           id)
+                                                 #f)
+                                                (else (module-rename id name)))))))
+                              (loop (cdr xl))))))))))
+        (for-each
 	 (lambda (u)
 	   (let* ((where (cdr u))
 		  (u (car u)))
-- 
2.11.0