[Bese-devel] Continuations in Lispworks v5.0

[szergling]

Hi all,

Searching on the net, I've not been able to find too many fix for
arnesi in Lispwork's (approx v5 onwards) environment access function
changes. So...

Hopefully without replicating anyone's effort, I've gone through and
updated the functions to the new environment API (if you can call it
that, it's internal, and I hope it doesn't change anytime soon). It
works enough to get UCW to run on Windows Lispworks Personal Edition
v5.0. Attached are the diffs I made. They are probably not suitable to
go in as patches yet because:

  I've simply replaced/upgraded the old environment functions, when I
  should conditionalise on the Lispworks version (and OS?)

  Insufficient refactoring?

  Insufficient testing (I would suggest at a minimum, the forms in the
  second attachment). I also need to (but haven't) get the test suite to run.

  General confidence -- if anyone's interested, please try it and kick
  it around, then turn into a proper patch?


For completeness, I should mention that I have also made a few other
minor patches to get my version of the ucw-boxset-01-2009 to run (I
believe they are orthogonal/largely unrelated to this environment
issue, but might be needed to get things to run). They are variously
slime.el, components/option-dialog.lisp, components/range-view.lisp,
components/template.lisp (mostly renaming make-standard-environment to
the new make-standard-tal-environment), examples/wiki.lisp etc. The
changes might already be in the newest patches. If there're sufficient
interest, I can look into them and show diffs, or submit patches for
the ones that some are mostly trivial (and haven't been fixed yet).

I'm also using the version of arnesi in the boxset, not the most
current in darcs (couldn't get this one to load, it keeps recursively
(infinite recursion) loading arnesi.asd). asdf is just too hard (will
take too long to debug/figure out), so I haven't ran any tests.
(Err forget that, found out the problem, clock skew, I'm sending
this email anyway).

I'll be keen to hear about any shortfalls or any feedback in general.

Cheers!
-------------- next part --------------
--- lexenv.lisp	2009-05-10 16:54:39.000000000 +1200
+++ /home/tyc20/public_html/stuff/lexenv.lisp	2009-05-10 16:49:10.000000000 +1200
@@ -302,7 +302,7 @@
                      (slot-value environment 'compiler::fenv))))
 
 #+(and lispworks (or win32 linux))
-(defmethod environment-p ((environment lexical::environment))
+(defmethod environment-p ((environment compiler::environment))
   t)
 
 #+(and lispworks (or win32 linux))
@@ -311,29 +311,38 @@
        (eq (symbol-package value) nil)))
 
 #+(and lispworks (or win32 linux))
-(defmethod lexical-variables ((environment lexical::environment))
-  (loop for candidate in (slot-value environment 'lexical::variables)
-        if (lexical-runtime-p (cdr candidate))
-        collect (car candidate)))
+(defmethod lexical-variables ((environment compiler::environment))
+  (loop for candidate in (slot-value environment 'compiler::venv)
+        when (eq (slot-value candidate 'compiler::kind) nil) 
+        collect (slot-value candidate 'compiler::name)))
 
 #+(and lispworks (or win32 linux))
-(defmethod lexical-functions ((environment lexical::environment))
-  (loop for candidate in (slot-value environment 'lexical::functions)
-        if (lexical-runtime-p (cdr candidate))
-        collect (car candidate)))
+(defun inline-function-p (finfo)
+  (and (listp finfo)
+       (equal finfo '(inline t))))
 
+#+(and lispworks (or win32 linux))
+(defmethod lexical-functions ((environment compiler::environment))
+  (loop for (name . finfo)  in (slot-value environment 'compiler::fenv)
+        when (and (not (inline-function-p finfo))
+                  (eq (slot-value finfo 'compiler::function-or-macro)
+                      'compiler::function))
+        collect name))
 
 #+(and lispworks (or win32 linux))
-(defmethod lexical-symbol-macros ((environment lexical::environment))
-  (loop for candidate in (slot-value environment 'lexical::variables)
-        unless (lexical-runtime-p (cdr candidate))
-        collect candidate))
+(defmethod lexical-symbol-macros ((environment compiler::environment))
+  (loop for candidate in (slot-value environment 'compiler::venv)
+        when (eq (slot-value candidate 'compiler::kind) 'compiler::symbol-macro) 
+        collect (cons (slot-value candidate 'compiler::name)
+                      (slot-value candidate 'compiler::lambda))))
 
 #+(and lispworks (or win32 linux))
-(defmethod lexical-macros ((environment lexical::environment))
-  (loop for candidate in (slot-value environment 'lexical::functions)
-        unless (lexical-runtime-p (cdr candidate))
-        collect candidate))
+(defmethod lexical-macros ((environment compiler::environment))
+  (loop for (name . finfo) in (slot-value environment 'compiler::fenv)
+        when (and (not (inline-function-p finfo))
+                  (eq (slot-value finfo 'compiler::function-or-macro)
+                      'compiler::macro))
+        collect (cons name (slot-value finfo 'compiler::lambda))))
 
 ;;;; ** Allegro
 
@@ -482,26 +491,48 @@
 			    (cons symmac 
 				  (system::make-symbol-macro def))))
 
+(defun raw-extend-environment (val slot-name env)
+  (let ((new (compiler::copy-environment env)))
+    (push val (slot-value new slot-name))
+    new))
 
 #+(and lispworks (or win32 linux))
-(defmethod augment-with-variable ((env lexical::environment) var)
-  (harlequin-common-lisp:augment-environment
-   env :variable (list var)))
+(defmethod augment-with-variable ((env compiler::environment) var)
+  (raw-extend-environment (compiler::make-venv :name var :kind nil)
+                          'compiler::venv
+                          env))
+
+(defun no-call (&rest junk)
+  "The call/cc interpreter overwrites and evaluates internal
+flet/labels and macrolets. Lispworks interpreter/compiler shouldn't
+have to do anything."
+  (declare (ignore junk))
+  (error "This shouldn't get called!"))
 
 #+(and lispworks (or win32 linux))
-(defmethod augment-with-function ((env lexical::environment) fun)
-  (harlequin-common-lisp:augment-environment
-   env :function (list fun)))
+(defmethod augment-with-function ((env compiler::environment) fun)
+  (raw-extend-environment (cons fun (compiler::make-flet-info
+                                     :function-or-macro 'function
+                                     :lambda #'no-call))
+                          'compiler::fenv
+                          env))
 
 #+(and lispworks (or win32 linux))
-(defmethod augment-with-macro ((env lexical::environment) mac def)
-  (harlequin-common-lisp:augment-environment
-   env :macro (list (list mac def))))
+(defmethod augment-with-macro ((env compiler::environment) mac def)
+  (raw-extend-environment (cons mac (compiler::make-flet-info
+                                     :function-or-macro 'compiler::macro
+                                     :lambda def))
+                          'compiler::fenv
+                          env))
 
 #+(and lispworks (or win32 linux))
-(defmethod augment-with-symbol-macro ((env lexical::environment) symmac def)
-  (harlequin-common-lisp:augment-environment
-   env :symbol-macro (list (list symmac def))))
+(defmethod augment-with-symbol-macro ((env compiler::environment) symmac def)
+  (raw-extend-environment
+   (compiler::make-venv :name symmac
+                        :kind 'compiler::symbol-macro
+                        :lambda def)
+   'compiler::venv
+   env))
 
 #+(and allegro (version>= 7 0))
 (defmethod augment-with-variable ((env sys::augmentable-environment) var)
-------------- next part --------------
A non-text attachment was scrubbed...
Name: tests.lisp
Type: application/x-extension-lisp
Size: 1443 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/bese-devel/attachments/20090510/a7465ac2/attachment.bin>