From 4ccb1efa134f578996a6cb960369f868673e0f2c Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Mon, 15 Jul 2013 00:00:15 +0200
Subject: Make the stack a SIMPLE-VECTOR, manage the fill-pointer as a special
 variable.

---
 sb-eval2.lisp | 28 +++++++++++++++-------------
 1 file changed, 15 insertions(+), 13 deletions(-)

diff --git a/sb-eval2.lisp b/sb-eval2.lisp
index af29739..6ba0ad6 100644
--- a/sb-eval2.lisp
+++ b/sb-eval2.lisp
@@ -10,9 +10,10 @@
 
 (defvar *stack*)
 (defvar *fp*)
+(defvar *sp*)
 
 (deftype stack ()
-  `(array t (*)))
+  'simple-vector)
 
 (defstruct (environment (:constructor make-environment (parent
                                                         &optional (size 0)
@@ -219,7 +220,7 @@
          (inline call-with-stack-frame))
 (defun call-with-stack-frame (nvars thunk)
   (let* ((stack *stack*)
-         (sp (fill-pointer stack))
+         (sp *sp*)
          (new-size (+ sp nvars 1)))
     (declare (type stack stack)
              (type fixnum sp new-size))
@@ -227,16 +228,16 @@
           while (< size new-size)
           do (format t "~&Resizing stack (new size: ~D)."
                      (+ new-size (the fixnum (round (* size 1.5)))))
-             (adjust-array stack
-                           (list (the fixnum
-                                      (+ new-size (the fixnum
-                                                       (round (* size 1.5))))))))
-    (setf (fill-pointer stack) new-size)
+             (setq stack
+                   (adjust-array stack
+                                 (list (the fixnum
+                                            (+ new-size (the fixnum
+                                                             (round (* size 1.5))))))))
+             (setq *stack* stack))
     (setf (aref stack sp) (the fixnum *fp*))
-    (unwind-protect
-         (let ((*fp* sp))
-           (funcall thunk))
-      (setf (fill-pointer stack) sp))))
+    (let ((*fp* sp)
+          (*sp* new-size))
+      (funcall thunk))))
 
 (declaim (ftype (function (fixnum) *) deref-stack)
          (inline deref-stack))
@@ -796,8 +797,9 @@
   `(call-with-stack (lambda () ,@body)))
 
 (defun call-with-stack (thunk)
-  (let ((*stack* (make-array '(2000) :fill-pointer t :adjustable t))
-        (*fp* 0))
+  (let ((*stack* (make-array '(10000)))
+        (*fp* 0)
+        (*sp* 0))
     (funcall thunk)))
 
 (defun eval (form)
-- 
cgit v1.2.3