Lay off dynamic-wind.

Implemented dynamic bindings with *specpdl*, avoiding a dynamic-wind
for every funcall.

diff --git a/src/elisp/Symbols.scm b/src/elisp/Symbols.scm
index 0bf89b93e338d75b9d98a3605bbcd63a9b472240..9b5a5d9ebdfbc13e5fe4c9ce93d0074ace05d8ab 100644 (file)
--- a/src/elisp/Symbols.scm
+++ b/src/elisp/Symbols.scm
@@ -95,6 +95,62 @@ Emacs symbol. |#
   (%record %symbol name +unbound+ +unbound+ '() '() false false-procedure
           '() '() '() '() '() '() '() '() '()))
 \f
+;;;; Special bindings stack.
+
+(define *specpdl* '())
+
+(define-integrable (%specbind vars inits thunk)
+  (let ((saved-specpdl *specpdl*))
+    (%wind-one! (cons (cons vars inits) *specpdl*))
+    (let ((value (thunk)))
+      (%unwind! saved-specpdl)
+      value)))
+
+(define-integrable (%wind! saved-state)
+  (cond ((eq? saved-state *specpdl*) unspecific)
+       ((null? saved-state)
+        (error "Cannot wind to saved-state!" saved-state))
+       (else
+        ;; Wind up to previous state.
+        (%wind! (cdr saved-state))
+        ;; Wind up this state.
+        (%wind-one! saved-state)
+        unspecific)))
+
+(define (%wind-one! saved-state)
+  (let loop ((vars (car (car saved-state)))
+            (vals (cdr (car saved-state))))
+    (if (pair? vars)
+       (let ((var (car vars))
+             (val (car vals)))
+         (set-car! vals (%symbol-value-no-error var))
+         (if (eq? val +unbound+)
+             (%set-symbol-unbound! var)
+             (%set-symbol-value! var val))
+         (loop (cdr vars) (cdr vals)))))
+  (set! *specpdl* saved-state))
+
+(define (%unwind! saved-state)
+  (cond ((eq? *specpdl* saved-state) unspecific)
+       ((null? *specpdl*)
+        (error "Unwound past saved state!" saved-state))
+       (else
+        ;; Unwind this state.
+        (let loop ((vars (car (car *specpdl*)))
+                   (vals (cdr (car *specpdl*))))
+          (if (pair? vars)
+              (let ((var (car vars))
+                    (val (car vals)))
+                (set-car! vals (%symbol-value-no-error var))
+                (if (eq? val +unbound+)
+                    (%set-symbol-unbound! var)
+                    (%set-symbol-value! var val))
+                (loop (cdr vars) (cdr vals)))))
+        (set! *specpdl* (cdr *specpdl*))
+        ;; Unwind previous states.
+        (%unwind! saved-state)
+        unspecific)))
+\f
 ;;;; Exported definitions
 
 (declare (integrate-operator %symbol?))
@@ -206,6 +262,18 @@ Emacs symbol. |#
       ;; Assume it's the empty list.
       (error:%signal Qsetting-constant (list '()))))
 
+(declare (integrate-operator %symbol-value-no-error))
+(define (%symbol-value-no-error symbol)
+  (if (%%symbol? symbol)
+      (let ((%value (%symbol/value symbol)))
+       (cond ((eq? %value +not-global+)
+              (if ((%symbol/bound? symbol))
+                  ((%symbol/get-value symbol))
+                  +unbound+))
+             (else %value)))
+      ;; Assume it's the empty list.
+      '()))
+
 (declare (integrate-operator %symbol-value))
 (define (%symbol-value symbol)
   (if (%%symbol? symbol)

diff --git a/src/elisp/callint.scm b/src/elisp/callint.scm
index 3de35173f9e3a798a45e34ef850ca3020ffdf3b9..11e5ed60517319795e7beeb7492e01fab7732b78 100644 (file)
--- a/src/elisp/callint.scm
+++ b/src/elisp/callint.scm
@@ -141,11 +141,21 @@ Otherwise, this is done only if an arg is read using the minibuffer."
   ;; interactively!
   ;; THIS is how to call a command interactively -- as though from
   ;; command dispatch.
-  (%with-current-buffer
-   buffer
+  ;; Remove any local bindings still active.  These are probably
+  ;; bogus, perhaps from calling Emacs Lisp functions via the
+  ;; interpreter and aborting.  Since we're theoretically just inside
+  ;; the top-level command dispatch loop, we should be able to discard
+  ;; these safely and reset the current-buffer.
+  (%unwind! '())
+  ;; Remove any local bindings left over after command execution.
+  (%unwind-protect
    (lambda ()
-     (%set-symbol-value! Qthis-command function)
-     (%funcall function args))))
+     (%with-current-buffer
+      buffer
+      (lambda ()
+       (%set-symbol-value! Qthis-command function)
+       (%funcall function args))))
+   (lambda () unspecific)))
 
 ;;; This is basically (edwin command-reader)interactive-arguments, hacked to
 ;;; record Emacs Lisp command invocations in the command-history as

diff --git a/src/elisp/elisp.pkg b/src/elisp/elisp.pkg
index 47c3f99ed3de55a7cfb978265c095a0685d7eca1..53bc341c4cd5816ef1342bac2ba85bd3aca9982e 100644 (file)
--- a/src/elisp/elisp.pkg
+++ b/src/elisp/elisp.pkg
@@ -93,6 +93,11 @@ Copyright (c) 1993  Matthew Birkholz, All Rights Reserved |#
          %symbol                       ;record type, used by inlined %symbol?
          +unbound+                     ;constant, used by %symbol-fbound?...
          +not-global+                  ;constant, used by %symbol-value...
+         *specpdl*
+         %specbind
+         %wind!
+         %wind-one!                    ;procedure, used by %specbind...
+         %unwind!
          %symbol?
          %make-symbol
          %symbol-name

diff --git a/src/elisp/eval.scm b/src/elisp/eval.scm
index 3541fae3678ecdd0eb6666e3ce094569481000aa..628e1929471382ed4b57d9943bb53ae4c0dca49a 100644 (file)
--- a/src/elisp/eval.scm
+++ b/src/elisp/eval.scm
@@ -315,36 +315,6 @@ All the VALUEFORMs are evalled before any symbols are bound."
                    (cons (%car elt) vars)
                    (cons (%eval (%car (%cdr elt))) inits)))))))
 
-(define (%specbind vars inits thunk)
-  (let ((current-buffer (%current-buffer))
-       (+unbound+ "unbound"))
-    (let ((exchange!
-          (lambda ()
-            ;; When rewinding, (%current-buffer) may not be the same as
-            ;; current-buffer, so set it before establishing bindings and
-            ;; restore it afterwards.
-            (let ((old-buffer (%current-buffer)))
-              (%set-current-buffer! current-buffer)
-              (let loop ((syms vars)
-                         (vals inits))
-                (if (pair? syms)
-                    (let* ((symbol (car syms))
-                           (new-value (car vals))
-                           (old-value (if (%symbol-bound? symbol)
-                                          (%symbol-value symbol)
-                                          +unbound+)))
-                      (if (eq? new-value +unbound+)
-                          (%set-symbol-unbound! symbol)
-                          (%set-symbol-value! symbol new-value))
-                      (set-car! vals old-value)
-                      (loop (cdr syms) (cdr vals)))))
-              (%set-current-buffer! old-buffer))
-            unspecific)))
-      (dynamic-wind
-       exchange!
-       thunk
-       exchange!))))
-
 (DEFUN (el:while &quote test . body)
   "(while TEST BODY...) if TEST yields non-NIL, execute the BODY forms and repeat."
   (let loop ()
@@ -412,14 +382,17 @@ return from  catch."
   (%catch (%eval tag) (lambda () (%progn body))))
 
 (define (%catch tag thunk)
-  (call-with-current-continuation
-   (lambda (exit)
-     (bind-condition-handler
-        (list condition-type:%throw)
-        (lambda (condition)
-          (if (eq? (access-condition condition 'TAG) tag)
-              (exit (access-condition condition 'VALUE))))
-       thunk))))
+  (let ((saved-specpdl *specpdl*))
+    (call-with-current-continuation
+     (lambda (exit)
+       (bind-condition-handler
+          (list condition-type:%throw)
+          (lambda (condition)
+            (if (eq? (access-condition condition 'TAG) tag)
+                (begin
+                  (%unwind! saved-specpdl)
+                  (exit (access-condition condition 'VALUE)))))
+        thunk)))))
 
 (DEFUN (el:throw tag value)
   "(throw TAG VALUE): throw to the catch for TAG and return VALUE from it.
@@ -437,10 +410,22 @@ If BODYFORM exits nonlocally, the UNWINDFORMS are executed anyway."
    (lambda () (%progn unwindforms))))
 
 (define (%unwind-protect protected-thunk unwind-thunk)
-  (dynamic-wind
-   (lambda () unspecific)
-   protected-thunk
-   unwind-thunk))
+  (let (;;(inside-specpdl *specpdl*)
+       (outside-specpdl))
+    (dynamic-wind
+     (lambda ()
+       (set! outside-specpdl *specpdl*)
+       ;; Let whoever caught the cc worry about saving the dynamic state!
+       ;;(%wind! inside-specpdl)
+       ;;(set! inside-specpdl)
+       unspecific)
+     protected-thunk
+     (lambda ()
+       ;;(set! inside-specpdl *specpdl*)
+       (%unwind! outside-specpdl)
+       (set! outside-specpdl)
+       (unwind-thunk)
+       unspecific))))
 
 (define condition-type:%signal
   (make-condition-type 'EL:SIGNAL () '(NAME DATA)
@@ -483,28 +468,30 @@ control returns to the condition-case and the handler BODY... is executed
 with VAR bound to (SIGNALED-CONDITIONS . SIGNAL-DATA).
 The value of the last BODY form is returned from the condition-case.
 See SIGNAL for more info."
-  (call-with-current-continuation
-   (lambda (exit)
-     (bind-condition-handler
-        (list condition-type:%signal)
-        (lambda (condition)
-          (let ((generalizations (%get (access-condition condition 'NAME)
-                                       Qerror-conditions)))
-            (let loop ((handlers handlers))
-              (cond ((null? handlers) false)
-                    ((memq (caar handlers) generalizations)
-                     (exit (if (null? var)
-                               (%progn (CHECK-LIST (cdar handlers)))
-                               (%specbind
-                                (list var)
-                                (list (cons
-                                       (access-condition condition 'NAME)
-                                       (access-condition condition 'DATA)))
-                                (lambda ()
-                                  (%progn (CHECK-LIST (cdar handlers))))))))
-                    (else (loop (cdr handlers)))))))
-       (lambda ()
-        (%eval bodyform))))))
+  (let ((saved-specpdl *specpdl*))
+    (call-with-current-continuation
+     (lambda (exit)
+       (bind-condition-handler
+          (list condition-type:%signal)
+          (lambda (condition)
+            (let ((generalizations (%get (access-condition condition 'NAME)
+                                         Qerror-conditions)))
+              (let loop ((handlers handlers))
+                (cond ((null? handlers) false)
+                      ((memq (caar handlers) generalizations)
+                       (%unwind! saved-specpdl)
+                       (exit (if (null? var)
+                                 (%progn (CHECK-LIST (cdar handlers)))
+                                 (%specbind
+                                  (list var)
+                                  (list (cons
+                                         (access-condition condition 'NAME)
+                                         (access-condition condition 'DATA)))
+                                  (lambda ()
+                                    (%progn (CHECK-LIST (cdar handlers))))))))
+                      (else (loop (cdr handlers)))))))
+        (lambda ()
+          (%eval bodyform)))))))
 
 (DEFUN (el:signal name data)
   "Signal an error.  Args are SIGNAL-NAME, and associated DATA.
@@ -619,10 +606,18 @@ this does nothing and returns nil."
                                                "an alist of Emacs Lisp symbols and values, or the Emacs Lisp symbol \"t\""))
                  (loop autoload-queue)))))
 
-  (let ((outside-queue)
+  (let ((outside-specpdl)
+       (outside-queue)
+       ;;(inside-specpdl *specpdl*)
        (inside-queue Qt))
     (dynamic-wind
      (lambda ()
+       (set! outside-specpdl *specpdl*)
+       ;; Let whoever caught the cc worry about saving the dynamic state!
+       ;;(%wind! inside-specpdl)
+       ;;(set! *specpdl* inside-specpdl)
+       ;;(set! inside-specpdl)
+       ;; Don't make them worry about the autoload-queue!
        (set! outside-queue autoload-queue)
        (set! autoload-queue inside-queue)
        (set! inside-queue)
@@ -636,6 +631,9 @@ this does nothing and returns nil."
        (set! inside-queue autoload-queue)
        (set! autoload-queue outside-queue)
        (set! outside-queue)
+       ;;(set! inside-specpdl *specpdl*)
+       (%unwind! outside-specpdl)
+       (set! outside-specpdl)
        unspecific))))
 
 (DEFUN (el:eval form)