dynwind is now a part of guile's primitive language

* libguile/memoize.h (scm_sym_at_dynamic_wind, SCM_M_DYNWIND)
* libguile/memoize.c (memoized_tags, MAKMEMO_DYNWIND)
  (scm_m_at_dynamic_wind, unmemoize): Add dynwind as a primitive
  expression type.

* libguile/dynwind.c (scm_dynamic_wind): Downgrade to a normal C
  function.

* libguile/eval.c (eval):
* module/ice-9/eval.scm (primitive-eval): Add dynwind support.

* module/ice-9/r4rs.scm: More relevant docs.
  (apply): Define in a more regular way.
  (dynamic-wind): Add to this file, with docs, dispatching to
  @dynamic-wind.

* module/language/tree-il/primitives.scm: Parse @dynamic-wind into a
  tree-il dynamic-wind.

libguile/dynwind.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -50,57 +50,9 @@
 
 
 
-SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
+SCM
-           (SCM in_guard, SCM thunk, SCM out_guard),
+scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
-	    "All three arguments must be 0-argument procedures.\n"
+#define FUNC_NAME "dynamic-wind"
-	    "@var{in_guard} is called, then @var{thunk}, then\n"
-	    "@var{out_guard}.\n"
-	    "\n"
-	    "If, any time during the execution of @var{thunk}, the\n"
-	    "continuation of the @code{dynamic_wind} expression is escaped\n"
-	    "non-locally, @var{out_guard} is called.  If the continuation of\n"
-	    "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
-	    "@var{in_guard} and @var{out_guard} may be called any number of\n"
-	    "times.\n"
-	    "@lisp\n"
-	    "(define x 'normal-binding)\n"
-	    "@result{} x\n"
-	    "(define a-cont  (call-with-current-continuation\n"
-	    "		  (lambda (escape)\n"
-	    "		     (let ((old-x x))\n"
-	    "		       (dynamic-wind\n"
-	    "			  ;; in-guard:\n"
-	    "			  ;;\n"
-	    "			  (lambda () (set! x 'special-binding))\n"
-	    "\n"
-	    "			  ;; thunk\n"
-	    "			  ;;\n"
-	    "		 	  (lambda () (display x) (newline)\n"
-	    "				     (call-with-current-continuation escape)\n"
-	    "				     (display x) (newline)\n"
-	    "				     x)\n"
-	    "\n"
-	    "			  ;; out-guard:\n"
-	    "			  ;;\n"
-	    "			  (lambda () (set! x old-x)))))))\n"
-	    "\n"
-	    ";; Prints:\n"
-	    "special-binding\n"
-	    ";; Evaluates to:\n"
-	    "@result{} a-cont\n"
-	    "x\n"
-	    "@result{} normal-binding\n"
-	    "(a-cont #f)\n"
-	    ";; Prints:\n"
-	    "special-binding\n"
-	    ";; Evaluates to:\n"
-	    "@result{} a-cont  ;; the value of the (define a-cont...)\n"
-	    "x\n"
-	    "@result{} normal-binding\n"
-	    "a-cont\n"
-	    "@result{} special-binding\n"
-	    "@end lisp")
-#define FUNC_NAME s_scm_dynamic_wind
 {
   SCM ans, old_winds;
   SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),

libguile/eval.c

@@ -215,6 +215,20 @@ eval (SCM x, SCM env)
       scm_define (CAR (mx), eval (CDR (mx), env));
       return SCM_UNSPECIFIED;
 
+    case SCM_M_DYNWIND:
+      {
+        SCM in, out, res, old_winds;
+        in = eval (CAR (mx), env);
+        out = eval (CDDR (mx), env);
+        scm_call_0 (in);
+        old_winds = scm_i_dynwinds ();
+        scm_i_set_dynwinds (scm_acons (in, out, old_winds));
+        res = eval (CADR (mx), env);
+        scm_i_set_dynwinds (old_winds);
+        scm_call_0 (out);
+        return res;
+      }
+
     case SCM_M_APPLY:
       /* Evaluate the procedure to be applied.  */
       proc = eval (CAR (mx), env);

libguile/memoize.c

@@ -199,6 +199,8 @@ scm_t_bits scm_tc16_memoized;
   MAKMEMO (SCM_M_QUOTE, exp)
 #define MAKMEMO_DEFINE(var, val) \
   MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_DYNWIND(in, expr, out) \
+  MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out)))
 #define MAKMEMO_APPLY(exp) \
   MAKMEMO (SCM_M_APPLY, exp)
 #define MAKMEMO_CONT(proc) \
@@ -231,6 +233,7 @@ static const char *const memoized_tags[] =
   "let",
   "quote",
   "define",
+  "dynwind",
   "apply",
   "call/cc",
   "call-with-values",
@@ -261,6 +264,7 @@ static SCM scm_m_cont (SCM xorig, SCM env);
 static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
 static SCM scm_m_cond (SCM xorig, SCM env);
 static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_at_dynamic_wind (SCM xorig, SCM env);
 static SCM scm_m_eval_when (SCM xorig, SCM env);
 static SCM scm_m_if (SCM xorig, SCM env);
 static SCM scm_m_lambda (SCM xorig, SCM env);
@@ -393,6 +397,7 @@ SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_m_cont);
 SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_m_at_call_with_values);
 SCM_SYNTAX (s_cond, "cond", scm_m_cond);
 SCM_SYNTAX (s_define, "define", scm_m_define);
+SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind);
 SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
 SCM_SYNTAX (s_if, "if", scm_m_if);
 SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
@@ -416,6 +421,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
 SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
 SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
 SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
+SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
 SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
 SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
 SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
@@ -615,6 +621,17 @@ scm_m_define (SCM expr, SCM env)
   return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
 }
 
+static SCM
+scm_m_at_dynamic_wind (SCM expr, SCM env)
+{
+  const SCM cdr_expr = CDR (expr);
+  ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_bad_expression, expr);
+
+  return MAKMEMO_DYNWIND (memoize (CADR (expr), env),
+                          memoize (CADDR (expr), env),
+                          memoize (CADDDR (expr), env));
+}
+
 static SCM
 scm_m_eval_when (SCM expr, SCM env)
 {
@@ -1058,6 +1075,11 @@ unmemoize (const SCM expr)
                          unmemoize (CAR (args)), unmemoize (CDR (args)));
     case SCM_M_DEFINE:
       return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+    case SCM_M_DYNWIND:
+      return scm_list_4 (scm_sym_at_dynamic_wind,
+                         unmemoize (CAR (args)),
+                         unmemoize (CADR (args)),
+                         unmemoize (CDDR (args)));
     case SCM_M_IF:
       return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
                          unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));

libguile/memoize.h

@@ -3,7 +3,7 @@
 #ifndef SCM_MEMOIZE_H
 #define SCM_MEMOIZE_H
 
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2004,2008,2009,2010
  * Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
@@ -51,6 +51,7 @@ SCM_API SCM scm_sym_atapply;
 SCM_API SCM scm_sym_atcall_cc;
 SCM_API SCM scm_sym_at_call_with_values;
 SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_at_dynamic_wind;
 SCM_API SCM scm_sym_eval_when;
 SCM_API SCM scm_sym_arrow;
 SCM_API SCM scm_sym_else;
@@ -75,6 +76,7 @@ enum
     SCM_M_LET,
     SCM_M_QUOTE,
     SCM_M_DEFINE,
+    SCM_M_DYNWIND,
     SCM_M_APPLY,
     SCM_M_CONT,
     SCM_M_CALL_WITH_VALUES,

module/ice-9/eval.scm

@@ -1,6 +1,6 @@
 ;;; -*- mode: scheme; coding: utf-8; -*-
 
-;;;; Copyright (C) 2009
+;;;; Copyright (C) 2009, 2010
 ;;;; Free Software Foundation, Inc.
 ;;;;
 ;;;; This library is free software; you can redistribute it and/or
@@ -222,6 +222,11 @@
         (('define (name . x))
          (define! name (eval x env)))
       
+        (('dynwind (in exp . out))
+         (dynamic-wind (eval in env)
+                       (lambda () (eval exp env))
+                       (eval out env)))
+        
         (('apply (f args))
          (apply (eval f env) (eval args env)))
 

module/ice-9/r4rs.scm

@@ -1,7 +1,7 @@
 ;;;; r4rs.scm --- definitions needed for libguile to be R4RS compliant
 ;;;; Jim Blandy <jimb@cyclic.com> --- October 1996
 
-;;;; 	Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006 Free Software Foundation, Inc.
+;;;; 	Copyright (C) 1996, 1997, 1998, 2000, 2001, 2006, 2010 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -23,15 +23,71 @@
 
 ;;;; apply and call-with-current-continuation
 
-;;; We want these to be tail-recursive, so instead of using primitive
+;;; The deal with these is that they are the procedural wrappers around the
-;;; procedures, we define them as closures in terms of the primitive
+;;; primitives of Guile's language. There are about 20 different kinds of
-;;; macros @apply and @call-with-current-continuation.
+;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
-(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
+;;; to preserve tail recursion.)
-(set-procedure-property! apply 'name 'apply)
+;;;
+;;; Usually we recognize (apply foo bar) to be an instance of @apply, but in the
+;;; case that apply is passed to apply, or we're bootstrapping, we need a
+;;; trampoline -- and here they are.
+(define (apply fun . args)
+  (@apply fun (apply:nconc2last args)))
 (define (call-with-current-continuation proc)
   (@call-with-current-continuation proc))
 (define (call-with-values producer consumer)
   (@call-with-values producer consumer))
+(define (dynamic-wind in thunk out)
+  "All three arguments must be 0-argument procedures.
+@var{in_guard} is called, then @var{thunk}, then
+@var{out_guard}.
+
+If, any time during the execution of @var{thunk}, the
+continuation of the @code{dynamic_wind} expression is escaped
+non-locally, @var{out_guard} is called.  If the continuation of
+the dynamic-wind is re-entered, @var{in_guard} is called.  Thus
+@var{in_guard} and @var{out_guard} may be called any number of
+times.
+@lisp
+ (define x 'normal-binding)
+@result{} x
+ (define a-cont
+   (call-with-current-continuation
+     (lambda (escape)
+       (let ((old-x x))
+         (dynamic-wind
+           ;; in-guard:
+           ;;
+           (lambda () (set! x 'special-binding))
+
+           ;; thunk
+           ;;
+           (lambda () (display x) (newline)
+                   (call-with-current-continuation escape)
+                   (display x) (newline)
+                   x)
+
+           ;; out-guard:
+           ;;
+           (lambda () (set! x old-x)))))))
+
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont
+x
+@result{} normal-binding
+ (a-cont #f)
+;; Prints:
+special-binding
+;; Evaluates to:
+@result{} a-cont  ;; the value of the (define a-cont...)
+x
+@result{} normal-binding
+a-cont
+@result{} special-binding
+@end lisp"
+  (@dynamic-wind in (thunk) out))
 
 
 ;;;; Basic Port Code

module/language/tree-il.scm

@@ -329,9 +329,9 @@
         ,(tree-il->scheme (make-lambda #f '() body))))
 
     ((<dynamic-wind> body winder unwinder)
-     `(dynamic-wind ,(unparse-tree-il winder)
+     `(dynamic-wind ,(tree-il->scheme winder)
-                    (lambda () ,(unparse-tree-il body))
+                    (lambda () ,(tree-il->scheme body))
-                    ,(unparse-tree-il unwinder)))
+                    ,(tree-il->scheme unwinder)))
     
     ((<prompt> tag body handler pre-unwind-handler)
      `((@ (ice-9 control) prompt) 

module/language/tree-il/primitives.scm

@@ -34,6 +34,7 @@
     call-with-current-continuation @call-with-current-continuation
     call/cc
     dynamic-wind
+    @dynamic-wind
     values
     eq? eqv? equal?
     memq memv
@@ -402,6 +403,23 @@
                      (make-lexical-ref #f 'post POST)))))))
               (else #f)))
 
+(hashq-set! *primitive-expand-table*
+            '@dynamic-wind
+            (case-lambda
+              ((src pre expr post)
+               (let ((PRE (gensym " pre"))
+                     (POST (gensym " post")))
+                 (make-let
+                  src
+                  '(pre post)
+                  (list PRE POST)
+                  (list pre post)
+                  (make-dynamic-wind
+                   src
+                   (make-lexical-ref #f 'pre PRE)
+                   expr
+                   (make-lexical-ref #f 'post POST)))))))
+
 (hashq-set! *primitive-expand-table*
             'prompt
             (case-lambda