fix bug in compilation of and' and or'; more robust underflow detection.

* module/system/il/compile.scm (codegen): Rewrite handling of `and' and
  `or' ghil compilation, because it was broken if drop was #t. Tricky
  bug, this one! Took me days to track down!

* module/system/repl/repl.scm: Export call-with-backtrace, which probably
  should go in some other file.

* src/vm.c (scm_vm_save_stack): Handle the fp==0 case for errors before
  we have a frame.

* src/vm_engine.h (NEW_FRAME, FREE_FRAME): Stricter underflow checking,
  raising the stack base to the return address, in an attempt to prevent
  inadvertant stack smashing (the symptom of the and/or miscompilation
  bug).
  (CHECK_IP): A check that the current IP is within the bounds of the
  current program. Not normally compiled in. Perhaps it should be?

* src/vm_system.c (halt): Set vp->ip to NULL. Paranoia, I know.
  (return): Call CHECK_IP(), if such a thing is compiled in.

* testsuite/Makefile.am (vm_test_files):
* testsuite/t-catch.scm:
* testsuite/t-map.scm:
* testsuite/t-or.scm: New tests.

module/system/il/compile.scm

@@ -217,20 +217,22 @@
 	 ;;     (br L2)
 	 ;; L1: (const #f)
 	 ;; L2:
-	 (let ((L1 (make-label)) (L2 (make-label)))
-	   (if (null? exps)
-	       (return-object! loc #t)
-	       (do ((exps exps (cdr exps)))
-		   ((null? (cdr exps))
-		    (comp-tail (car exps))
-		    (if (not tail) (push-branch! #f 'br L2))
-		    (push-label! L1)
-		    (return-object! #f #f)
-		    (if (not tail) (push-label! L2))
-		    (maybe-drop)
-		    (maybe-return))
-		 (comp-push (car exps))
-		 (push-branch! #f 'br-if-not L1)))))
+         (cond ((null? exps) (return-object! loc #t))
+               ((null? (cdr exps)) (comp-tail (car exps)))
+               (else
+                (let ((L1 (make-label)) (L2 (make-label)))
+                  (let lp ((exps exps))
+                    (cond ((null? (cdr exps))
+                           (comp-tail (car exps))
+                           (push-branch! #f 'br L2)
+                           (push-label! L1)
+                           (return-object! #f #f)
+                           (push-label! L2)
+                           (maybe-return))
+                          (else
+                           (comp-push (car exps))
+                           (push-branch! #f 'br-if-not L1)
+                           (lp (cdr exps)))))))))
 
 	((<ghil-or> env loc exps)
 	 ;;     EXP
@@ -240,19 +242,21 @@
 	 ;;     ...
 	 ;;     TAIL
 	 ;; L1:
-	 (let ((L1 (make-label)))
-	   (if (null? exps)
-	       (return-object! loc #f)
-	       (do ((exps exps (cdr exps)))
-		   ((null? (cdr exps))
-		    (comp-tail (car exps))
-		    (push-label! L1)
-		    (maybe-drop)
-		    (maybe-return))
-		 (comp-push (car exps))
-		 (push-call! #f 'dup '())
-		 (push-branch! #f 'br-if L1)
-		 (push-call! #f 'drop '())))))
+         (cond ((null? exps) (return-object! loc #f))
+               ((null? (cdr exps)) (comp-tail (car exps)))
+               (else
+                (let ((L1 (make-label)))
+                  (let lp ((exps exps))
+                    (cond ((null? (cdr exps))
+                           (comp-tail (car exps))
+                           (push-label! L1)
+                           (maybe-return))
+                          (else
+                           (comp-push (car exps))
+                           (push-call! #f 'dup '())
+                           (push-branch! #f 'br-if L1)
+                           (push-call! #f 'drop '())
+                           (lp (cdr exps)))))))))
 
 	((<ghil-begin> env loc exps)
 	 ;; EXPS...

module/system/repl/repl.scm

@@ -29,7 +29,7 @@
   :use-module (system vm vm)
   :use-module (system vm debug)
   :use-module (ice-9 rdelim)
-  :export (start-repl))
+  :export (start-repl call-with-backtrace))
 
 (define meta-command-token (cons 'meta 'command))