From bf174e79851934dc302eb6cf85b36f8ae0812641 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Thu, 8 Dec 2016 21:40:45 +0100
Subject: [PATCH] Let macros know if they run at toplevel.

This allows us to error out when encountering a definition in an
"expression context" (i.e., not at toplevel or in a place where an
internal define is allowed)

Introduces a new "at-toplevel?" procedure which can also be used by user
code to determine whether the current expansion is taking place in a
toplevel context.

Fixes #1309
---
 NEWS                    |   2 +
 chicken-ffi-syntax.scm  |   3 +
 chicken-syntax.scm      |   5 ++
 core.scm                | 130 ++++++++++++++++++++---------------------
 eval.scm                | 151 ++++++++++++++++++++++++------------------------
 expand.scm              |  99 ++++++++++++++++++-------------
 manual/Macros           |  12 ++++
 tests/functor-tests.scm |   2 +
 tests/syntax-tests.scm  |   7 +++
 9 files changed, 232 insertions(+), 179 deletions(-)

diff --git a/NEWS b/NEWS
index 3d78582..5f33cd0 100644
--- a/NEWS
+++ b/NEWS
@@ -57,6 +57,8 @@
 - Syntax expander
   - Removed support for (define-syntax (foo e r c) ...), which was
     undocumented and not officially supported anyway.
+  - define and friends are now aggressively rejected in "expression
+    contexts" (i.e., anywhere but toplevel or as internal defines).
 
 4.11.2
 
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 9bbe73f..0df4cbd 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -55,6 +55,7 @@
  '()
  (##sys#er-transformer
   (lambda (form r c)
+    (##sys#check-toplevel-definition 'define-external form)
     (let* ((form (cdr form))
 	   (quals (and (pair? form) (string? (car form))))
 	   (var (and (not quals) (pair? form) (symbol? (car form)))) )
@@ -100,6 +101,7 @@
  '()
  (##sys#er-transformer
   (lambda (form r c)
+    (##sys#check-toplevel-definition 'define-location form)
     (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
     (let ((var (cadr form))
 	  (type (caddr form))
@@ -212,6 +214,7 @@
  '()
  (##sys#er-transformer
   (lambda (form r c)
+    (##sys#check-toplevel-definition 'define-foreign-variable form)
     `(##core#define-foreign-variable ,@(cdr form)))))
 
 (##sys#extend-macro-environment
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index b4a19a1..4937ff1 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -56,6 +56,7 @@
  '()
  (##sys#er-transformer
   (lambda (form r c)
+    (##sys#check-toplevel-definition 'define-constant form)
     (##sys#check-syntax 'define-constant form '(_ symbol _))
     `(##core#define-constant ,@(cdr form)))))
 
@@ -63,6 +64,7 @@
  'define-record '()
  (##sys#er-transformer
   (lambda (x r c)
+    (##sys#check-toplevel-definition 'define-record x) ; clearer error
     (##sys#check-syntax 'define-record x '(_ symbol . _))
     (let* ((name (cadr x))
 	   (slots (cddr x))
@@ -354,6 +356,7 @@
    'define-values '()
    (##sys#er-transformer
     (lambda (form r c)
+      (##sys#check-toplevel-definition 'define-values form)
       (##sys#check-syntax 'define-values form '(_ lambda-list _))
       (##sys#decompose-lambda-list
        (cadr form)
@@ -467,6 +470,7 @@
  'define-inline '()
  (##sys#er-transformer
   (lambda (form r c)
+    (##sys#check-toplevel-definition 'define-inline form)
     (letrec ([quotify-proc 
 	      (lambda (xs id)
 		(##sys#check-syntax id xs '#(_ 1))
@@ -840,6 +844,7 @@
  'define-record-printer '()
  (##sys#er-transformer
   (lambda (form r c)
+    ;; TODO: Only allow at toplevel?  It's not really a definition...
     (##sys#check-syntax 'define-record-printer form '(_ _ . _))
     (let ([head (cadr form)]
 	  [body (cddr form)])
diff --git a/core.scm b/core.scm
index db6337d..e0a18b9 100644
--- a/core.scm
+++ b/core.scm
@@ -529,9 +529,9 @@
       (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map (lambda (x) (car x)) se)))
       (cond ((not (symbol? x)) x0)	; syntax?
 	    ((##sys#hash-table-ref constant-table x)
-	     => (lambda (val) (walk val e se dest ldest h #f)))
+	     => (lambda (val) (walk val e se dest ldest h #f #f)))
 	    ((##sys#hash-table-ref inline-table x)
-	     => (lambda (val) (walk val e se dest ldest h #f)))
+	     => (lambda (val) (walk val e se dest ldest h #f #f)))
 	    ((assq x foreign-variables)
 	     => (lambda (fv)
 		  (let* ((t (second fv))
@@ -541,7 +541,7 @@
 		     (foreign-type-convert-result
 		      (finish-foreign-result ft body)
 		      t)
-		     e se dest ldest h #f))))
+		     e se dest ldest h #f #f))))
 	    ((assq x location-pointer-map)
 	     => (lambda (a)
 		  (let* ((t (third a))
@@ -551,7 +551,7 @@
 		     (foreign-type-convert-result
 		      (finish-foreign-result ft body)
 		      t)
-		     e se dest ldest h #f))))
+		     e se dest ldest h #f #f))))
 	    ((##sys#get x '##core#primitive))
 	    ((not (memq x e)) (##sys#alias-global-hook x #f h)) ; only if global
 	    (else x))))
@@ -579,7 +579,7 @@
 		 (for-each pretty-print imps)
 		 (print "\n;; END OF FILE"))))) ) )
 
-  (define (walk x e se dest ldest h outer-ln)
+  (define (walk x e se dest ldest h outer-ln tl?)
     (cond ((symbol? x)
 	   (cond ((keyword? x) `(quote ,x))
 		 ((memq x unlikely-variables)
@@ -600,25 +600,25 @@
 	     (set! ##sys#syntax-error-culprit x)
 	     (let* ((name0 (lookup (car x) se))
 		    (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
-		    (xexpanded (expand x se compiler-syntax-enabled)))
+		    (xexpanded (expand x se compiler-syntax-enabled tl?)))
 	       (when ln (update-line-number-database! xexpanded ln))
 	       (cond ((not (eq? x xexpanded))
-		      (walk xexpanded e se dest ldest h ln))
+		      (walk xexpanded e se dest ldest h ln tl?))
 
 		     ((##sys#hash-table-ref inline-table name)
 		      => (lambda (val)
-			   (walk (cons val (cdr x)) e se dest ldest h ln)))
+			   (walk (cons val (cdr x)) e se dest ldest h ln #f)))
 
 		     (else
 		      (case name
 
 			((##core#if)
 			 `(if
-			   ,(walk (cadr x) e se #f #f h ln)
-			   ,(walk (caddr x) e se #f #f h ln)
+			   ,(walk (cadr x) e se #f #f h ln #f)
+			   ,(walk (caddr x) e se #f #f h ln #f)
 			   ,(if (null? (cdddr x))
 				'(##core#undefined)
-				(walk (cadddr x) e se #f #f h ln) ) ) )
+				(walk (cadddr x) e se #f #f h ln #f) ) ) )
 
 			((##core#syntax ##core#quote)
 			 `(quote ,(strip-syntax (cadr x))))
@@ -626,21 +626,21 @@
 			((##core#check)
 			 (if unsafe
 			     ''#t
-			     (walk (cadr x) e se dest ldest h ln) ) )
+			     (walk (cadr x) e se dest ldest h ln tl?) ) )
 
 			((##core#the)
 			 `(##core#the
 			   ,(strip-syntax (cadr x))
 			   ,(caddr x)
-			   ,(walk (cadddr x) e se dest ldest h ln)))
+			   ,(walk (cadddr x) e se dest ldest h ln tl?)))
 
 			((##core#typecase)
 			 `(##core#typecase
 			   ,(or ln (cadr x))
-			   ,(walk (caddr x) e se #f #f h ln)
+			   ,(walk (caddr x) e se #f #f h ln tl?)
 			   ,@(map (lambda (cl)
 				    (list (strip-syntax (car cl))
-					  (walk (cadr cl) e se dest ldest h ln)))
+					  (walk (cadr cl) e se dest ldest h ln tl?)))
 				  (cdddr x))))
 
 			((##core#immutable)
@@ -667,7 +667,7 @@
 			((##core#inline_loc_ref)
 			 `(##core#inline_loc_ref
 			   ,(strip-syntax (cadr x))
-			   ,(walk (caddr x) e se dest ldest h ln)))
+			   ,(walk (caddr x) e se dest ldest h ln #f)))
 
 			((##core#require-for-syntax)
 			 (load-extension (cadr x))
@@ -683,7 +683,7 @@
 				file-requirements type
 				(cut lset-adjoin/eq? <> id)
 				(cut list id)))
-			     (walk exp e se dest ldest h ln))))
+			     (walk exp e se dest ldest h ln #f))))
 
 			((##core#let)
 			 (let* ((bindings (cadr x))
@@ -693,12 +693,12 @@
 			   (set-real-names! aliases vars)
 			   `(let
 			     ,(map (lambda (alias b)
-				     (list alias (walk (cadr b) e se (car b) #t h ln)) )
+				     (list alias (walk (cadr b) e se (car b) #t h ln #f)) )
 				   aliases bindings)
 			     ,(walk (##sys#canonicalize-body
 				     (cddr x) se2 compiler-syntax-enabled)
 				    (append aliases e)
-				    se2 dest ldest h ln) ) )  )
+				    se2 dest ldest h ln #f) ) )  )
 
 			((##core#letrec*)
 			 (let ((bindings (cadr x))
@@ -712,7 +712,7 @@
 				       `(##core#set! ,(car b) ,(cadr b)))
 				     bindings)
 			      (##core#let () ,@body) )
-			    e se dest ldest h ln)))
+			    e se dest ldest h ln #f)))
 
 			((##core#letrec)
 			 (let* ((bindings (cadr x))
@@ -730,7 +730,7 @@
 					`(##core#set! ,v ,t))
 				      vars tmps)
 			       (##core#let () ,@body) ) )
-			    e se dest ldest h ln)))
+			    e se dest ldest h ln #f)))
 
 			((##core#lambda)
 			 (let ((llist (cadr x))
@@ -753,7 +753,7 @@
 						  (##core#debug-event "C_DEBUG_ENTRY" ',dest)
 						  ,body0)
 						body0)
-					    (append aliases e) se2 #f #f dest ln))
+					    (append aliases e) se2 #f #f dest ln #f))
 				     (llist2
 				      (build-lambda-list
 				       aliases argc
@@ -790,7 +790,7 @@
 			   (walk
 			    (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
 			    e se2
-			    dest ldest h ln) ) )
+			    dest ldest h ln #f) ) )
 
 		       ((##core#letrec-syntax)
 			(let* ((ms (map (lambda (b)
@@ -808,7 +808,7 @@
 			   ms)
 			  (walk
 			   (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
-			   e se2 dest ldest h ln)))
+			   e se2 dest ldest h ln #f)))
 
 		       ((##core#define-syntax)
 			(##sys#check-syntax
@@ -833,7 +833,7 @@
 				 ',var
 				 (##sys#current-environment) ,body) ;XXX possibly wrong se?
 			       '(##core#undefined) )
-			   e se dest ldest h ln)) )
+			   e se dest ldest h ln #f)) )
 
 		       ((##core#define-compiler-syntax)
 			(let* ((var (cadr x))
@@ -865,7 +865,7 @@
 					 ',var)
 					(##sys#current-environment))))
 			       '(##core#undefined) )
-			   e se dest ldest h ln)))
+			   e se dest ldest h ln #f)))
 
 		       ((##core#let-compiler-syntax)
 			(let ((bs (map
@@ -892,7 +892,7 @@
 				(walk
 				 (##sys#canonicalize-body
 				  (cddr x) se compiler-syntax-enabled)
-				 e se dest ldest h ln) )
+				 e se dest ldest h ln tl?) )
 			      (lambda ()
 				(for-each
 				 (lambda (b)
@@ -907,7 +907,7 @@
 			   (cadr x)
 			   (caddr x)
 			   (lambda (forms)
-			     (walk `(##core#begin ,@forms) e se dest ldest h ln)))))
+			     (walk `(##core#begin ,@forms) e se dest ldest h ln tl?)))))
 
 		       ((##core#let-module-alias)
 			(##sys#with-module-aliases
@@ -916,7 +916,7 @@
 				(strip-syntax b))
 			      (cadr x))
 			 (lambda ()
-			   (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln))))
+			   (walk `(##core#begin ,@(cddr x)) e se dest ldest h ln #t))))
 
 		       ((##core#module)
 			(let* ((name (strip-syntax (cadr x)))
@@ -986,7 +986,7 @@
 							 (car body)
 							 e ;?
 							 (##sys#current-environment)
-							 #f #f h ln)
+							 #f #f h ln #t)	; reset to toplevel!
 							xs))))))))))
 			    (let ((body
 				   (canonicalize-begin-body
@@ -999,7 +999,7 @@
 					  (walk
 					   x
 					   e ;?
-					   (##sys#current-meta-environment) #f #f h ln) )
+					   (##sys#current-meta-environment) #f #f h ln tl?) )
 					(cons `(##core#provide ,req) module-registration)))
 				      body))))
 			      (do ((cs compiler-syntax (cdr cs)))
@@ -1017,7 +1017,7 @@
 				(walk
 				 (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
 				 (append aliases e)
-				 se2 #f #f dest ln) ] )
+				 se2 #f #f dest ln #f) ] )
 			  (set-real-names! aliases vars)
 			  `(##core#lambda ,aliases ,body) ) )
 
@@ -1039,7 +1039,7 @@
 					      (##core#inline_update
 					       (,(third fv) ,type)
 					       ,(foreign-type-check tmp type) ) )
-					   e se #f #f h ln))))
+					   e se #f #f h ln #f))))
 				 ((assq var location-pointer-map)
 				  => (lambda (a)
 				       (let* ([type (third a)]
@@ -1050,7 +1050,7 @@
 					      (,type)
 					      ,(second a)
 					      ,(foreign-type-check tmp type) ) )
-					  e se #f #f h ln))))
+					  e se #f #f h ln #f))))
 				 (else
 				  (unless (memq var e) ; global?
 				    (set! var (or (##sys#get var '##core#primitive)
@@ -1074,38 +1074,38 @@
 					 (##sys#notice "assignment to imported value binding" var)))
 				  (when (keyword? var)
 				    (warning (sprintf "assignment to keyword `~S'" var) ))
-				  `(set! ,var ,(walk val e se var0 (memq var e) h ln))))))
+				  `(set! ,var ,(walk val e se var0 (memq var e) h ln #f))))))
 
 			((##core#debug-event)
 			 `(##core#debug-event
 			   ,(unquotify (cadr x) se)
 			   ,ln ; this arg is added - from this phase on ##core#debug-event has an additional argument!
 			   ,@(map (lambda (arg)
-				    (unquotify (walk arg e se #f #f h ln) se))
+				    (unquotify (walk arg e se #f #f h ln tl?) se))
 				  (cddr x))))
 
 			((##core#inline)
 			 `(##core#inline
-			   ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln)))
+			   ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se h ln #f)))
 
 			((##core#inline_allocate)
 			 `(##core#inline_allocate
 			   ,(map (cut unquotify <> se) (second x))
-			   ,@(mapwalk (cddr x) e se h ln)))
+			   ,@(mapwalk (cddr x) e se h ln #f)))
 
 			((##core#inline_update)
-			 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln)) )
+			 `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f #f h ln #f)) )
 
 			((##core#inline_loc_update)
 			 `(##core#inline_loc_update
 			   ,(cadr x)
-			   ,(walk (caddr x) e se #f #f h ln)
-			   ,(walk (cadddr x) e se #f #f h ln)) )
+			   ,(walk (caddr x) e se #f #f h ln #f)
+			   ,(walk (cadddr x) e se #f #f h ln #f)) )
 
 			((##core#compiletimetoo ##core#elaborationtimetoo)
 			 (let ((exp (cadr x)))
 			   (##sys#eval/meta exp)
-			   (walk exp e se dest #f h ln) ) )
+			   (walk exp e se dest #f h ln tl?) ) )
 
 			((##core#compiletimeonly ##core#elaborationtimeonly)
 			 (##sys#eval/meta (cadr x))
@@ -1118,24 +1118,24 @@
 				(let ([x (car xs)]
 				      [r (cdr xs)] )
 				  (if (null? r)
-				      (list (walk x e se dest ldest h ln))
-				      (cons (walk x e se #f #f h ln) (fold r)) ) ) ) )
+				      (list (walk x e se dest ldest h ln tl?))
+				      (cons (walk x e se #f #f h ln tl?) (fold r)) ) ) ) )
 			     '(##core#undefined) ) )
 
 			((##core#foreign-lambda)
-			 (walk (expand-foreign-lambda x #f) e se dest ldest h ln) )
+			 (walk (expand-foreign-lambda x #f) e se dest ldest h ln #f) )
 
 			((##core#foreign-safe-lambda)
-			 (walk (expand-foreign-lambda x #t) e se dest ldest h ln) )
+			 (walk (expand-foreign-lambda x #t) e se dest ldest h ln #f) )
 
 			((##core#foreign-lambda*)
-			 (walk (expand-foreign-lambda* x #f) e se dest ldest h ln) )
+			 (walk (expand-foreign-lambda* x #f) e se dest ldest h ln #f) )
 
 			((##core#foreign-safe-lambda*)
-			 (walk (expand-foreign-lambda* x #t) e se dest ldest h ln) )
+			 (walk (expand-foreign-lambda* x #t) e se dest ldest h ln #f) )
 
 			((##core#foreign-primitive)
-			 (walk (expand-foreign-primitive x) e se dest ldest h ln) )
+			 (walk (expand-foreign-primitive x) e se dest ldest h ln #f) )
 
 			((##core#define-foreign-variable)
 			 (let* ((var (strip-syntax (second x)))
@@ -1169,7 +1169,7 @@
 					(define
 					 ,ret
 					 ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
-				     e se dest ldest h ln) ) ]
+				     e se dest ldest h ln #f) ) ]
 				 [else
 				  (register-foreign-type! name type)
 				  '(##core#undefined) ] ) ) )
@@ -1212,7 +1212,7 @@
 				      '() )
 				,(if init (fifth x) (fourth x)) ) )
 			    e (alist-cons var alias se)
-			    dest ldest h ln) ) )
+			    dest ldest h ln #f) ) )
 
 			((##core#define-inline)
 			 (let* ((name (second x))
@@ -1244,7 +1244,7 @@
 				    (hide-variable var)
 				    (mark-variable var '##compiler#constant)
 				    (mark-variable var '##compiler#always-bound)
-				    (walk `(define ,var (##core#quote ,val)) e se #f #f h ln)))
+				    (walk `(define ,var (##core#quote ,val)) e se #f #f h ln tl?)))
 				 (else
 				  (quit-compiling "invalid compile-time value for named constant `~S'"
 					name)))))
@@ -1258,7 +1258,7 @@
 				       (lambda (id)
 					 (memq (lookup id se) e))))
 				    (cdr x) ) )
-			  e '() #f #f h ln) )
+			  e '() #f #f h ln #f) )
 
 			((##core#foreign-callback-wrapper)
 			 (let-values ([(args lam) (split-at (cdr x) 4)])
@@ -1280,7 +1280,7 @@
 				"non-matching or invalid argument list to foreign callback-wrapper"
 				vars atypes) )
 			     `(##core#foreign-callback-wrapper
-			       ,@(mapwalk args e se h ln)
+			       ,@(mapwalk args e se h ln #f)
 			       ,(walk `(##core#lambda
 					,vars
 					(##core#let
@@ -1337,7 +1337,7 @@
 						     (##sys#make-c-string r ',name)) ) ) )
 						(else (cddr lam)) ) )
 					   rtype) ) )
-				      e se #f #f h ln) ) ) ) )
+				      e se #f #f h ln #f) ) ) ) )
 
 			((##core#location)
 			 (let ([sym (cadr x)])
@@ -1346,23 +1346,23 @@
 				      => (lambda (a)
 					   (walk
 					    `(##sys#make-locative ,(second a) 0 #f 'location)
-					    e se #f #f h ln) ) ]
+					    e se #f #f h ln #f) ) ]
 				     [(assq sym external-to-pointer)
-				      => (lambda (a) (walk (cdr a) e se #f #f h ln)) ]
+				      => (lambda (a) (walk (cdr a) e se #f #f h ln #f)) ]
 				     [(assq sym callback-names)
 				      `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
 				     [else
 				      (walk
 				       `(##sys#make-locative ,sym 0 #f 'location)
-				       e se #f #f h ln) ] )
+				       e se #f #f h ln #f) ] )
 			       (walk
 				`(##sys#make-locative ,sym 0 #f 'location)
-				e se #f #f h ln) ) ) )
+				e se #f #f h ln #f) ) ) )
 
 			(else
 			 (let* ((x2 (fluid-let ((##sys#syntax-context
 						 (cons name ##sys#syntax-context)))
-				      (mapwalk x e se h ln)))
+				      (mapwalk x e se h ln tl?)))
 				(head2 (car x2))
 				(old (##sys#hash-table-ref line-number-database-2 head2)) )
 			   (when ln
@@ -1378,7 +1378,7 @@
 	  ((constant? (car x))
 	   (emit-syntax-trace-info x #f)
 	   (warning "literal in operator position" x)
-	   (mapwalk x e se h outer-ln) )
+	   (mapwalk x e se h outer-ln tl?) )
 
 	  (else
 	   (emit-syntax-trace-info x #f)
@@ -1387,10 +1387,10 @@
 	      `(##core#let
 		((,tmp ,(car x)))
 		(,tmp ,@(cdr x)))
-	      e se dest ldest h outer-ln)))))
+	      e se dest ldest h outer-ln #f)))))
 
-  (define (mapwalk xs e se h ln)
-    (map (lambda (x) (walk x e se #f #f h ln)) xs) )
+  (define (mapwalk xs e se h ln tl?)
+    (map (lambda (x) (walk x e se #f #f h ln tl?)) xs) )
 
   (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
   (foreign-code "C_clear_trace_buffer();")
@@ -1403,7 +1403,7 @@
      ,(begin
 	(set! extended-bindings (append internal-bindings extended-bindings))
 	exp) )
-   '() (##sys#current-environment) #f #f #f #f) ) )
+   '() (##sys#current-environment) #f #f #f #f #t) ) )
 
 
 (define (process-declaration spec se local?)
diff --git a/eval.scm b/eval.scm
index c43e444..bddc5f3 100644
--- a/eval.scm
+++ b/eval.scm
@@ -207,7 +207,7 @@
 
 (define compile-to-closure
   (let ((reverse reverse))
-    (lambda (exp env se #!optional cntr evalenv static)
+    (lambda (exp env se #!optional cntr evalenv static tl?)
 
       (define (find-id id se)		; ignores macro bindings
 	(cond ((null? se) #f)
@@ -252,7 +252,7 @@
       (define (decorate p ll h cntr)
 	(eval-decorator p ll h cntr))
 
-      (define (compile x e h tf cntr se)
+      (define (compile x e h tf cntr se tl?)
 	(cond ((keyword? x) (lambda v x))
 	      ((symbol? x)
 	       (receive (i j) (lookup x e se)
@@ -315,10 +315,10 @@
 	       (##sys#syntax-error/context "illegal non-atomic object" x)]
 	      [(symbol? (##sys#slot x 0))
 	       (emit-syntax-trace-info tf x cntr)
-	       (let ((x2 (expand x se)))
+	       (let ((x2 (expand x se #f tl?)))
 		 (d `(EVAL/EXPANDED: ,x2))
 		 (if (not (eq? x2 x))
-		     (compile x2 e h tf cntr se)
+		     (compile x2 e h tf cntr se tl?)
 		     (let ((head (rename (##sys#slot x 0) se)))
 		       ;; here we did't resolve ##core#primitive, but that is done in compile-call (via 
 		       ;; a normal walking of the operator)
@@ -341,40 +341,40 @@
 			    (lambda v c)))
 
 			 [(##core#check)
-			  (compile (cadr x) e h tf cntr se) ]
+			  (compile (cadr x) e h tf cntr se #f) ]
 
 			 [(##core#immutable)
-			  (compile (cadr x) e #f tf cntr se) ]
+			  (compile (cadr x) e #f tf cntr se #f) ]
 		   
 			 [(##core#undefined) (lambda (v) (##core#undefined))]
 
 			 [(##core#if)
-			  (let* ([test (compile (cadr x) e #f tf cntr se)]
-				 [cns (compile (caddr x) e #f tf cntr se)]
-				 [alt (if (pair? (cdddr x))
-					  (compile (cadddr x) e #f tf cntr se)
-					  (compile '(##core#undefined) e #f tf cntr se) ) ] )
+			  (let* ((test (compile (cadr x) e #f tf cntr se #f))
+				 (cns (compile (caddr x) e #f tf cntr se #f))
+				 (alt (if (pair? (cdddr x))
+					  (compile (cadddr x) e #f tf cntr se #f)
+					  (compile '(##core#undefined) e #f tf cntr se #f) ) ) )
 			    (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
 
 			 [(##core#begin)
 			  (let* ((body (##sys#slot x 1))
 				 (len (length body)) )
 			    (case len
-			      [(0) (compile '(##core#undefined) e #f tf cntr se)]
-			      [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
-			      [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
-					  [x2 (compile (cadr body) e #f tf cntr se)] )
-				     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
-			      [else
-			       (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
-				      [x2 (compile (cadr body) e #f tf cntr se)] 
-				      [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
-				 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
+			      ((0) (compile '(##core#undefined) e #f tf cntr se tl?))
+			      ((1) (compile (##sys#slot body 0) e #f tf cntr se tl?))
+			      ((2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
+					  [x2 (compile (cadr body) e #f tf cntr se tl?)] )
+				     (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) )
+			      (else
+			       (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se tl?)]
+				      [x2 (compile (cadr body) e #f tf cntr se tl?)] 
+				      [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se tl?)] )
+				 (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ) ) ) ]
 
 			 [(##core#set!)
 			  (let ((var (cadr x)))
 			    (receive (i j) (lookup var e se)
-			      (let ((val (compile (caddr x) e var tf cntr se)))
+			      (let ((val (compile (caddr x) e var tf cntr se #f)))
 				(cond [(not i)
 				       (when ##sys#notices-enabled
 					 (and-let* ((a (assq var (##sys#current-environment)))
@@ -406,28 +406,28 @@
 				 (se2 (##sys#extend-se se vars aliases))
 				 [body (compile-to-closure
 					(##sys#canonicalize-body (cddr x) se2 #f)
-					e2 se2 cntr evalenv static) ] )
+					e2 se2 cntr evalenv static #f) ] )
 			    (case n
-			      [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
+			      [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se #f)])
 				     (lambda (v)
 				       (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
-			      [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
-					 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
+			      [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+					 [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] )
 				     (lambda (v)
 				       (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
-			      [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
-					  [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
+			      [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+					  [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] 
 					  [t (cddr bindings)]
-					  [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
+					  [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] )
 				     (lambda (v)
 				       (##core#app 
 					body
 					(cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
-			      [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
-					  [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] 
+			      [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se #f)]
+					  [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se #f)] 
 					  [t (cddr bindings)]
-					  [val3 (compile (cadar t) e (caddr vars) tf cntr se)] 
-					  [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
+					  [val3 (compile (cadar t) e (caddr vars) tf cntr se #f)] 
+					  [val4 (compile (cadadr t) e (cadddr vars) tf cntr se #f)] )
 				     (lambda (v)
 				       (##core#app 
 					body
@@ -437,7 +437,7 @@
 						      (##core#app val4 v))
 					      v)) ) ) ]
 			      [else
-			       (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
+			       (let ((vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se #f)) bindings)))
 				 (lambda (v)
 				   (let ([v2 (##sys#make-vector n)])
 				     (do ([i 0 (fx+ i 1)]
@@ -458,7 +458,7 @@
 					      `(##core#set! ,(car b) ,(cadr b))) 
 					    bindings)
 			       (##core#let () ,@body) )
-			     e h tf cntr se)))
+			     e h tf cntr se #f)))
 
 			((##core#letrec)
 			 (let* ((bindings (cadr x))
@@ -475,7 +475,7 @@
 						   `(##core#set! ,v ,t))
 						 vars tmps)
 					  (##core#let () ,@body) ) )
-			      e h tf cntr se)))
+			      e h tf cntr se #f)))
 
 			 [(##core#lambda)
 			  (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
@@ -496,7 +496,7 @@
 				      (body 
 				       (compile-to-closure
 					(##sys#canonicalize-body body se2 #f)
-					e2 se2 (or h cntr) evalenv static) ) )
+					e2 se2 (or h cntr) evalenv static #f) ) )
 				 (case argc
 				   [(0) (if rest
 					    (lambda (v)
@@ -583,7 +583,7 @@
 				      se) ) )
 			    (compile
 			     (##sys#canonicalize-body (cddr x) se2 #f)
-			     e #f tf cntr se2)))
+			     e #f tf cntr se2 #f)))
 			       
 			 ((##core#letrec-syntax)
 			  (let* ((ms (map (lambda (b)
@@ -601,7 +601,7 @@
 			     ms) 
 			    (compile
 			     (##sys#canonicalize-body (cddr x) se2 #f)
-			     e #f tf cntr se2)))
+			     e #f tf cntr se2 #f)))
 			       
 			 ((##core#define-syntax)
 			  (let* ((var (cadr x))
@@ -616,22 +616,22 @@
 			     name
 			     (##sys#current-environment)
 			     (##sys#eval/meta body))
-			    (compile '(##core#undefined) e #f tf cntr se) ) )
+			    (compile '(##core#undefined) e #f tf cntr se #f) ) )
 
 			 ((##core#define-compiler-syntax)
-			  (compile '(##core#undefined) e #f tf cntr se))
+			  (compile '(##core#undefined) e #f tf cntr se #f))
 
 			 ((##core#let-compiler-syntax)
 			  (compile 
 			   (##sys#canonicalize-body (cddr x) se #f)
-			   e #f tf cntr se))
+			   e #f tf cntr se #f))
 
 			 ((##core#include)
 			  (##sys#include-forms-from-file
 			   (cadr x)
 			   (caddr x)
 			   (lambda (forms)
-			     (compile `(##core#begin ,@forms) e #f tf cntr se))))
+			     (compile `(##core#begin ,@forms) e #f tf cntr se tl?))))
 
 			 ((##core#let-module-alias)
 			  (##sys#with-module-aliases
@@ -640,7 +640,7 @@
 				  (strip-syntax b))
 				(cadr x))
 			   (lambda ()
-			     (compile `(##core#begin ,@(cddr x)) e #f tf cntr se))))
+			     (compile `(##core#begin ,@(cddr x)) e #f tf cntr se tl?))))
 
 			 ((##core#module)
 			  (let* ((x (strip-syntax x))
@@ -691,14 +691,15 @@
 					(cons (compile 
 					       (car body) 
 					       '() #f tf cntr 
-					       (##sys#current-environment))
+					       (##sys#current-environment)
+					       #t) ; reset back to toplevel!
 					      xs))))) ) )))
 
 			 [(##core#loop-lambda)
-			  (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
+			  (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se #f) ]
 
 			 [(##core#provide)
-			  (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se)]
+			  (compile `(##sys#provide (##core#quote ,(cadr x))) e #f tf cntr se #f)]
 
 			 [(##core#require-for-syntax)
 			  (let ((id (cadr x)))
@@ -708,30 +709,30 @@
 			       ,@(map (lambda (x)
 					`(##sys#load-extension (##core#quote ,x)))
 				      (lookup-runtime-requirements id)))
-			     e #f tf cntr se))]
+			     e #f tf cntr se #f))]
 
 			 [(##core#require)
 			  (let ((id         (cadr x))
 				(alternates (cddr x)))
 			    (let-values (((exp _ _) (##sys#process-require id #f alternates)))
-			      (compile exp e #f tf cntr se)))]
+			      (compile exp e #f tf cntr se #f)))]
 
 			 [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
 			  (##sys#eval/meta (cadr x))
-			  (compile '(##core#undefined) e #f tf cntr se) ]
+			  (compile '(##core#undefined) e #f tf cntr se tl?) ]
 
 			 [(##core#compiletimetoo)
-			  (compile (cadr x) e #f tf cntr se) ]
+			  (compile (cadr x) e #f tf cntr se tl?) ]
 
 			 [(##core#compiletimeonly ##core#callunit) 
-			  (compile '(##core#undefined) e #f tf cntr se) ]
+			  (compile '(##core#undefined) e #f tf cntr se tl?) ]
 
 			 [(##core#declare)
 			  (##sys#notice "declarations are ignored in interpreted code" x)
-			  (compile '(##core#undefined) e #f tf cntr se) ]
+			  (compile '(##core#undefined) e #f tf cntr se #f) ]
 
 			 [(##core#define-inline ##core#define-constant)
-			  (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
+			  (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se #f) ]
                    
 			 [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda 
 					    ##core#define-foreign-variable 
@@ -744,13 +745,13 @@
 			  (compile-call (cdr x) e tf cntr se) ]
 
 			 ((##core#the)
-			  (compile (cadddr x) e h tf cntr se))
+			  (compile (cadddr x) e h tf cntr se tl?))
 			 
 			 ((##core#typecase)
 			  ;; drops exp and requires "else" clause
 			  (cond ((assq 'else (strip-syntax (cdddr x))) =>
 				 (lambda (cl)
-				   (compile (cadr cl) e h tf cntr se)))
+				   (compile (cadr cl) e h tf cntr se tl?)))
 				(else
 				 (##sys#syntax-error-hook
 				  'compiler-typecase
@@ -789,7 +790,7 @@
 	(let* ((head (##sys#slot x 0))
 	       (fn (if (procedure? head) 
 		       (lambda _ head)
-		       (compile (##sys#slot x 0) e #f tf cntr se)))
+		       (compile (##sys#slot x 0) e #f tf cntr se #f)))
 	       (args (##sys#slot x 1))
 	       (argc (checked-length args))
 	       (info x) )
@@ -798,34 +799,34 @@
 	    [(0) (lambda (v)
 		   (emit-trace-info tf info cntr e v)
 		   ((##core#app fn v)))]
-	    [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
+	    [(1) (let ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f)))
 		   (lambda (v)
 		     (emit-trace-info tf info cntr e v)
 		     ((##core#app fn v) (##core#app a1 v))) ) ]
-	    [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
-			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
+	    [(2) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f)) )
 		   (lambda (v)
 		     (emit-trace-info tf info cntr e v)
 		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
-	    [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
-			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
-			[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
+	    [(3) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
+			(a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) )
 		   (lambda (v)
 		     (emit-trace-info tf info cntr e v)
 		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
-	    [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
-			[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
-			[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] 
-			[a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
+	    [(4) (let* ((a1 (compile (##sys#slot args 0) e #f tf cntr se #f))
+			(a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se #f))
+			(a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se #f)) 
+			(a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se #f)) )
 		   (lambda (v)
 		     (emit-trace-info tf info cntr e v)
 		     ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
-	    [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
+	    [else (let ((as (##sys#map (lambda (a) (compile a e #f tf cntr se #f)) args)))
 		    (lambda (v)
 		      (emit-trace-info tf info cntr e v)
 		      (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
 
-      (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se) ) ) )
+      (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se tl?) ) ) )
 
 
 ;;; evaluate in the macro-expansion/compile-time environment
@@ -846,8 +847,10 @@
 	  ((compile-to-closure
 	    form
 	    '() 
-	    (##sys#current-meta-environment)) ;XXX evalenv? static?
-	   '() ) )
+	    (##sys#current-meta-environment)
+	    #f #f #f			;XXX evalenv? static?
+	    #t)				; toplevel.
+	   '()) )
 	(lambda ()
 	  (##sys#active-eval-environment aee)
 	  (##sys#current-module oldcm)
@@ -865,11 +868,11 @@
 	      (let ((se2 (##sys#slot env 2)))
 		((if se2		; not interaction-environment?
 		     (parameterize ((##sys#macro-environment '()))
-		       (compile-to-closure x '() se2 #f env (##sys#slot env 3)))
-		     (compile-to-closure x '() se #f env #f))
+		       (compile-to-closure x '() se2 #f env (##sys#slot env 3) #t))
+		     (compile-to-closure x '() se #f env #f #t))
 		 '() ) ) )
 	     (else
-	      ((compile-to-closure x '() se #f #f #f) '())))))))
+	      ((compile-to-closure x '() se #f #f #f #t) '())))))))
 
 (define (eval x . env)
   (apply (eval-handler) x env))
diff --git a/expand.scm b/expand.scm
index 783b34d..e95fb19 100644
--- a/expand.scm
+++ b/expand.scm
@@ -42,7 +42,8 @@
    strip-syntax
    syntax-error
    er-macro-transformer
-   ir-macro-transformer)
+   ir-macro-transformer
+   at-toplevel?)
 
 (import scheme chicken
 	chicken.keyword)
@@ -209,7 +210,7 @@
 
 ;; The basic macro-expander
 
-(define (##sys#expand-0 exp dse cs?)
+(define (##sys#expand-0 exp dse cs? toplevel?)
   (define (call-handler name handler exp se cs)
     (dd "invoking macro: " name)
     (dd `(STATIC-SE: ,@(map-se se)))
@@ -272,41 +273,42 @@
 	    (call-handler head (cadr mdef) exp (car mdef) #f)
 	    #t))
 	  (else (values exp #f)) ) )
-  (let loop ((exp exp))
-    (if (pair? exp)
-      (let ((head (car exp))
-	    (body (cdr exp)) )
-	(if (symbol? head)
-	    (let ((head2 (or (lookup head dse) head)))
-	      (unless (pair? head2)
-		(set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
-	      (cond [(eq? head2 '##core#let)
-		     (##sys#check-syntax 'let body '#(_ 2) #f dse)
-		     (let ([bindings (car body)])
-		       (cond [(symbol? bindings) ; expand named let
-			      (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
-			      (let ([bs (cadr body)])
-				(values
-				 `(##core#app
-				   (##core#letrec*
-				    ([,bindings 
-				      (##core#loop-lambda
-				       ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
-				    ,bindings)
-				   ,@(##sys#map cadr bs) )
-				 #t) ) ]
-			     [else (values exp #f)] ) ) ]
-		    ((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
-		     (lambda (cs)
-		       (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
-			 (cond ((eq? result exp) (expand head exp head2))
-			       (else
-				(when ##sys#compiler-syntax-hook
-				  (##sys#compiler-syntax-hook head result))
-				(loop result))))))
-		    [else (expand head exp head2)] ) )
-	    (values exp #f) ) )
-      (values exp #f) ) ) )
+  (parameterize ((expander-at-toplevel toplevel?))
+    (let loop ((exp exp))
+      (if (pair? exp)
+	  (let ((head (car exp))
+		(body (cdr exp)) )
+	    (if (symbol? head)
+		(let ((head2 (or (lookup head dse) head)))
+		  (unless (pair? head2)
+		    (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
+		  (cond [(eq? head2 '##core#let)
+			 (##sys#check-syntax 'let body '#(_ 2) #f dse)
+			 (let ([bindings (car body)])
+			   (cond [(symbol? bindings) ; expand named let
+				  (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
+				  (let ([bs (cadr body)])
+				    (values
+				     `(##core#app
+				       (##core#letrec*
+					([,bindings 
+					  (##core#loop-lambda
+					   ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
+					,bindings)
+				       ,@(##sys#map cadr bs) )
+				     #t) ) ]
+				 [else (values exp #f)] ) ) ]
+			((and cs? (symbol? head2) (getp head2 '##compiler#compiler-syntax)) =>
+			 (lambda (cs)
+			   (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
+			     (cond ((eq? result exp) (expand head exp head2))
+				   (else
+				    (when ##sys#compiler-syntax-hook
+				      (##sys#compiler-syntax-hook head result))
+				    (loop result))))))
+			[else (expand head exp head2)] ) )
+		(values exp #f) ) )
+	  (values exp #f) ) )) )
 
 (define ##sys#compiler-syntax-hook #f)
 (define ##sys#enable-runtime-macros #f)
@@ -315,9 +317,9 @@
 
 ;;; User-level macroexpansion
 
-(define (expand exp #!optional (se (##sys#current-environment)) cs?)
+(define (expand exp #!optional (se (##sys#current-environment)) cs? (toplevel? #t))
   (let loop ((exp exp))
-    (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
+    (let-values (((exp2 m) (##sys#expand-0 exp se cs? toplevel?)))
       (if m
 	  (loop exp2)
 	  exp2) ) ) )
@@ -595,7 +597,7 @@
 		    (else
 		     (if (member (list head) vars)
 			 (fini vars vals mvars body)
-			 (let ((x2 (##sys#expand-0 x se cs?)))
+			 (let ((x2 (##sys#expand-0 x se cs? #f)))
 			   (if (eq? x x2)
 			       (fini vars vals mvars body)
 			       (loop (cons x2 rest)
@@ -642,6 +644,11 @@
 (define ##sys#syntax-error-culprit #f)
 (define ##sys#syntax-context '())
 
+;; Used to forbid definitions in expression contexts
+(define expander-at-toplevel (make-parameter #t))
+
+(define (at-toplevel?) (expander-at-toplevel))
+
 (define (syntax-error . args)
   (apply ##sys#signal-hook #:syntax-error
 	 (strip-syntax args)))
@@ -713,6 +720,17 @@
 
 (define-constant +default-argument-count-limit+ 99999)
 
+(define ##sys#check-toplevel-definition
+  (lambda (form exp)
+    (unless (at-toplevel?)
+      (let ((ln (get-line-number exp))
+	    (msg "definition found in expression context"))
+	(##sys#syntax-error-hook
+	 (if ln
+	     (string-append "(" ln ") in `" (symbol->string form) "' - " msg)
+	     (string-append "in `" (symbol->string form) "' - " msg))
+	 exp)))))
+
 (define ##sys#check-syntax
   (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
 
@@ -1034,6 +1052,7 @@
    '()
    (##sys#er-transformer
     (lambda (x r c)
+      (##sys#check-toplevel-definition 'define x)
       (##sys#check-syntax 'define x '(_ . #(_ 1)))
       (let loop ((form x))
 	(let ((head (cadr form))
diff --git a/manual/Macros b/manual/Macros
index 36be848..691f4bc 100644
--- a/manual/Macros
+++ b/manual/Macros
@@ -86,6 +86,18 @@ below for more information about implicit renaming macros.
 Strips all syntactical information from {{EXPRESSION}}, returning a new expression
 where symbols have all context-information removed.
 
+==== at-toplevel?
+
+<procedure>(at-toplevel?)</procedure>
+
+This procedure determines whether the currently expanding macro is
+being expanded in a toplevel context.  This can be useful to reject
+definitions in an expression context.
+
+It returns {{#t}} directly at the toplevel, but also for direct
+sub-expressions of any {{begin}} or {{module}} expression which is
+itself at the toplevel.
+
 
 === Explicit renaming macros
 
diff --git a/tests/functor-tests.scm b/tests/functor-tests.scm
index 3f0588b..5ef48bb 100644
--- a/tests/functor-tests.scm
+++ b/tests/functor-tests.scm
@@ -166,6 +166,8 @@
   (import chicken X)
   yibble)
 
+;; XXX This is somewhat iffy: functor instantiation results in a
+;; value!
 (test-equal
  "alternative functor instantiation syntax"
  (module yabble = frob (import scheme) (define yibble 99))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index a43b20e..d17e472 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -783,6 +783,13 @@
 )
 |#
 
+;;; Definitions in expression contexts are rejected (#1309)
+
+(f (eval '(let () 1 (begin 2 (define x 3) 4))))
+(f (eval '(display (define x 1))))
+;; Some tests for nested but valid definition expressions:
+(t 2 (eval '(begin (define x 1) 2)))
+(t 2 (eval '(module _ () (import scheme) (define x 1) 2)))
 
 ;;; renaming of keyword argument (#277)
 
-- 
2.1.4