Hello,

Here's a fix for an issue Kristian discovered at the last meetup. It's
related to our switch to a more strict treatment of definitions occuring
outside the top level. Basically, definitions in an included file should
be allowed (but currently aren't) if the include occurs somewhere a
definition could go.

The commit message has a full explanation of the problem and solution.

Cheers,

Evan
>From 0fc32324836fdfa78f44493f9c59425b267eb196 Mon Sep 17 00:00:00 2001
From: Evan Hanson <ev...@foldling.org>
Date: Wed, 13 Jun 2018 19:35:24 +1200
Subject: [PATCH] Splice includes into body contexts so definitions are handled
 correctly

Now that non-toplevel definitions outside a "body" context are no longer
allowed, we have to expand include forms during body canonicalisation so
that any definitions in the included file are correctly spliced into the
surrounding context. Otherwise, they won't be recognised as internal
definitions and the compiler will reject them as "toplevel definitions
in non-toplevel context".

So, whenever a `##core#include' node is encountered, it's now extended
to include the remainder of the forms in the surrounding body and
control is handed back to the compiler. Then, whenever the compiler
reads forms from an included file, it checks for a body and, if one is
present, it knows it should return to the canonicalisation routine with
the included forms (as well as the remainder of the original body
context). If no body is present, included forms are treated as usual,
i.e. as a normal sequence that gets inserted into a `##core#begin' node.
This treatment is similar to what we currently do for modules, which
must also be handled as a special case during body canonicalisation.
---
 core.scm               | 10 ++++++++--
 eval.scm               |  8 +++++++-
 expand.scm             | 18 ++++++++++--------
 tests/runtests.bat     |  2 +-
 tests/runtests.sh      |  2 +-
 tests/syntax-tests.scm | 16 ++++++++++++++++
 6 files changed, 43 insertions(+), 13 deletions(-)

diff --git a/core.scm b/core.scm
index a09ba4af..2bbed0b2 100644
--- a/core.scm
+++ b/core.scm
@@ -111,7 +111,7 @@
 ; (##core#set! <variable> <exp>)
 ; (##core#ensure-toplevel-definition <variable>)
 ; (##core#begin <exp> ...)
-; (##core#include <string> <string> | #f)
+; (##core#include <string> <string> | #f [<body>])
 ; (##core#loop-lambda <llist> <body>)
 ; (##core#undefined)
 ; (##core#primitive <name>)
@@ -951,7 +951,13 @@
 			   (cadr x)
 			   (caddr x)
 			   (lambda (forms)
-			     (walk `(##core#begin ,@forms) e dest ldest h ln tl?)))))
+			     (walk (if (pair? (cdddr x)) ; body?
+				       (canonicalize-body/ln
+					ln
+					(append forms (cadddr x))
+					compiler-syntax-enabled)
+				       `(##core#begin ,@forms))
+				   e dest ldest h ln tl?)))))
 
 		       ((##core#let-module-alias)
 			(##sys#with-module-aliases
diff --git a/eval.scm b/eval.scm
index ae70f888..7aad9636 100644
--- a/eval.scm
+++ b/eval.scm
@@ -519,7 +519,13 @@
 			   (cadr x)
 			   (caddr x)
 			   (lambda (forms)
-			     (compile `(##core#begin ,@forms) e #f tf cntr tl?))))
+			     (compile
+			      (if (pair? (cdddr x)) ; body?
+				  (##sys#canonicalize-body
+				   (append forms (cadddr x))
+				   (##sys#current-environment))
+				  `(##core#begin ,@forms))
+			      e #f tf cntr tl?))))
 
 			 ((##core#let-module-alias)
 			  (##sys#with-module-aliases
diff --git a/expand.scm b/expand.scm
index b2f97d4b..6c83dc66 100644
--- a/expand.scm
+++ b/expand.scm
@@ -511,18 +511,20 @@
 			     (##sys#append (reverse exps) (list (expand body)))))
 			(let ((x2 (##sys#expand-0 x se cs?)))
 			  (if (eq? x x2)
-			      ;; Modules must be registered before we
-			      ;; can continue with other forms, so
-			      ;; hand back control to the compiler
+			      ;; Modules and includes must be processes before
+			      ;; we can continue with other forms, so hand
+			      ;; control back to the compiler
 			      (if (and (pair? x)
 				       (symbol? (car x))
-				       (comp '##core#module (car x)))
+				       (or (comp '##core#module (car x))
+					   (comp '##core#include (car x))))
 				  `(##core#begin
 				    ,@(reverse exps)
-				    ,x
-				    ,@(if (null? rest)
-					  '()
-					  `((##core#let () ,@rest))))
+				    ,@(if (comp '##core#module (car x))
+					  (if (null? rest)
+					      `(,x)
+					      `(,x (##core#let () ,@rest)))
+					  `((##core#include ,@(cdr x) ,rest))))
 				  (loop rest (cons x exps)))
 			      (loop2 (cons x2 rest)) )) ))) ))
 	  ;; We saw defines.  Translate to letrec, and let compiler
diff --git a/tests/runtests.bat b/tests/runtests.bat
index f6856ccc..6030d387 100644
--- a/tests/runtests.bat
+++ b/tests/runtests.bat
@@ -22,7 +22,7 @@ set compile_r=..\%PROGRAM_PREFIX%csc%PROGRAM_SUFFIX% %COMPILE_OPTIONS% -o a.out
 set compile_s=..\%PROGRAM_PREFIX%csc%PROGRAM_SUFFIX% %COMPILE_OPTIONS% -s -types %TYPESDB% -ignore-repository
 set interpret=..\%PROGRAM_PREFIX%csi%PROGRAM_SUFFIX% -n -include-path %TEST_DIR%/..
 
-del /f /q /s *.exe *.so *.o *.import.* ..\foo.import.* %CHICKEN_INSTALL_REPOSITORY%
+del /f /q /s *.exe *.so *.o *.out *.import.* ..\foo.import.* %CHICKEN_INSTALL_REPOSITORY%
 rmdir /q /s %CHICKEN_INSTALL_REPOSITORY%
 mkdir %CHICKEN_INSTALL_REPOSITORY%
 copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY%
diff --git a/tests/runtests.sh b/tests/runtests.sh
index a9e8a5b1..06279127 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -59,7 +59,7 @@ $time true >/dev/null 2>/dev/null
 test $? -eq 127 && time=
 set -e
 
-rm -fr *.exe *.so *.o *.import.* a.out ../foo.import.* test-repository
+rm -fr *.exe *.so *.o *.out *.import.* ../foo.import.* test-repository
 mkdir -p test-repository
 cp $TYPESDB test-repository/types.db
 
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index d01d8883..38ae5978 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -1239,6 +1239,22 @@ other-eval
   (assert (eq? req 1)))
 
 
+;; Includes should be spliced into the surrounding body context:
+
+(begin-for-syntax
+  (with-output-to-file "x.out" (cut pp '(define x 2))))
+
+(let ()
+  (define x 1)
+  (include "x.out")
+  (t 2 x))
+
+(let ()
+  (define x 1)
+  (let ()
+    (include "x.out"))
+  (t 1 x))
+
 ;; letrec vs. letrec*
 
 ;;XXX this fails - the optimizer substitutes "foo" for it's known constant value
-- 
2.11.0

_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers

Reply via email to