Fix: Don't cast SCM values to pointer. Use SCM2PTR instead.

[bpt/guile.git] / libguile / dynwind.c

diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index e367a89..304ba77 100644 (file)
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -1,4 +1,4 @@
-/*     Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc.
+/*     Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
  * 
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -49,7 +49,7 @@
 #include "eval.h"
 #include "alist.h"
 #include "fluids.h"
-#include "genio.h"
+#include "ports.h"
 #include "smob.h"
 
 #include "dynwind.h"
@@ -70,9 +70,51 @@
 
 
 
-GUILE_PROC(scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
+SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
            (SCM thunk1, SCM thunk2, SCM thunk3),
-"")
+           "All three arguments must be 0-argument procedures.\n\n"
+           "@var{in-guard} is called, then @var{thunk}, then @var{out-guard}.\n\n"
+           "If, any time during the execution of @var{thunk}, the continuation\n"
+           "of the @code{dynamic-wind} expression is escaped non-locally, @var{out-guard}\n"
+           "is called.   If the continuation of the dynamic-wind is re-entered,\n"
+           "@var{in-guard} is called.   Thus @var{in-guard} and @var{out-guard} may\n"
+           "be called any number of times.\n\n"
+           "@example\n"
+           "(define x 'normal-binding)\n"
+           "@result{} x\n\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\n"
+           "x\n"
+           "@result{} normal-binding\n\n"
+           "(a-cont #f)\n"
+           ";; Prints:\n"
+           "special-binding\n"
+           ";; Evaluates to:\n"
+           "@result{} a-cont  ;; the value of the (define a-cont...)\n\n"
+           "x\n"
+           "@result{} normal-binding\n\n"
+           "a-cont\n"
+           "@result{} special-binding\n"
+           "@end example\n"
+           "")
 #define FUNC_NAME s_scm_dynamic_wind
 {
   SCM ans;
@@ -93,32 +135,18 @@ GUILE_PROC(scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
  * smob.  Objects of this type are pushed onto the dynwind chain.
  */
 
-typedef struct guardsmem {
-  scm_guard_t before;
-  scm_guard_t after;
-  void *data;
-} guardsmem;
-
-#define SCM_GUARDSMEM(obj) ((guardsmem *) SCM_CDR (obj))
-#define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before)
-#define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after)
-#define SCM_GUARD_DATA(obj) (SCM_GUARDSMEM (obj)->data)
-#define SCM_GUARDSP(obj) (SCM_CAR (obj) == tc16_guards)
+#define SCM_GUARDSP(obj) SCM_SMOB_PREDICATE (tc16_guards, obj)
+#define SCM_BEFORE_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 1))
+#define SCM_AFTER_GUARD(obj) ((scm_guard_t) SCM_CELL_WORD (obj, 2))
+#define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3))
 
 static long tc16_guards;
 
-static scm_sizet
-freeguards (SCM guards)
-{
-  scm_must_free ((char *) SCM_CDR (guards));
-  return sizeof (guardsmem);
-}
-
 static int
 printguards (SCM exp, SCM port, scm_print_state *pstate)
 {
   scm_puts ("#<guards ", port);
-  scm_intprint (SCM_CDR (exp), 16, port);
+  scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
   scm_putc ('>', port);
   return 1;
 }
@@ -131,13 +159,8 @@ scm_internal_dynamic_wind (scm_guard_t before,
                           void *guard_data)
 {
   SCM guards, ans;
-  guardsmem *g;
   before (guard_data);
-  g = (guardsmem *) scm_must_malloc (sizeof (*g), "guards");
-  g->before = before;
-  g->after = after;
-  g->data = guard_data;
-  SCM_NEWSMOB (guards, tc16_guards, g);
+  SCM_NEWSMOB3 (guards, tc16_guards, before, after, guard_data);
   scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds);
   ans = inner (inner_data);
   scm_dynwinds = SCM_CDR (scm_dynwinds);
@@ -146,9 +169,9 @@ scm_internal_dynamic_wind (scm_guard_t before,
 }
 
 #ifdef GUILE_DEBUG
-GUILE_PROC (scm_wind_chain, "wind-chain", 0, 0, 0, 
+SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0, 
             (),
-"")
+           "")
 #define FUNC_NAME s_scm_wind_chain
 {
   return scm_dynwinds;
@@ -246,7 +269,13 @@ scm_dowinds (SCM to, long delta)
 void
 scm_init_dynwind ()
 {
-  tc16_guards = scm_make_smob_type_mfpe ("guards", sizeof (struct guardsmem),
-                                        NULL, freeguards, printguards, NULL);
+  tc16_guards = scm_make_smob_type_mfpe ("guards", 0,
+                                         NULL, scm_free0, printguards, NULL);
 #include "dynwind.x"
 }
+
+/*
+  Local Variables:
+  c-file-style: "gnu"
+  End:
+*/