From 632703656926b0ac6461538d3cbf35fb95df72dc Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 18 Apr 2018 21:04:54 -0700
Subject: compiler: don't expand top-level forms twice.

* share/txr/stdlib/compiler.tl (usr:compile-toplevel): Support
optional parameter indicating that no expansion is required.
(usr:compile-file): Call compile-toplevel with a t argument
for the new expanded-p parameter, so no further expansion
takes place.

* txr.1: Document new optional parameter of compile-toplevel.
---
 share/txr/stdlib/compiler.tl | 12 ++++++++----
 txr.1                        |  8 +++++++-
 2 files changed, 15 insertions(+), 5 deletions(-)

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 1ac0c3af..5ae8fb93 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -1382,12 +1382,16 @@
                       (add ^(,pars.rest))))))
          ,*lm-body))))
 
-(defun usr:compile-toplevel (exp)
+(defun usr:compile-toplevel (exp : (expanded-p nil))
   (let ((co (new compiler))
         (as (new assembler)))
     (let* ((oreg co.(alloc-treg))
-           (xexp (prog1 (expand* exp) (unless *load-recursive*
-                                        (release-deferred-warnings))))
+           (xexp (if expanded-p
+                   exp
+                   (unwind-protect
+                     (expand* exp)
+                     (unless *load-recursive*
+                       (release-deferred-warnings)))))
            (frag co.(compile oreg (new env co co) xexp)))
       co.(free-treg oreg)
       co.(check-treg-leak)
@@ -1471,7 +1475,7 @@
                                     [mapdo compile-form (cdr form)]))
                        (t (when (and (or *eval* *emit*)
                                      (not (constantp form)))
-                            (let* ((vm-desc (compile-toplevel form))
+                            (let* ((vm-desc (compile-toplevel form t))
                                    (flat-vd (list-from-vm-desc vm-desc)))
                               (when *eval*
                                 (sys:vm-execute-toplevel vm-desc))
diff --git a/txr.1 b/txr.1
index 6ba2404b..fd1a6b76 100644
--- a/txr.1
+++ b/txr.1
@@ -61983,7 +61983,7 @@ circular structures are reproduced.
 
 .coNP Function @ compile-toplevel
 .synb
-.mets (compile-toplevel << form )
+.mets (compile-toplevel < form << expanded-p )
 .syne
 .desc
 The
@@ -62002,6 +62002,12 @@ using the
 .code eval
 function.
 
+The
+.meta expanded-p
+argument indicates that
+.meta form
+has already been expanded and is to be compiled without further expansion.
+
 Note: in spite of the name,
 .code compile-toplevel
 makes no consideration whether or not
-- 
cgit v1.2.3