mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 14:00:21 +02:00
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.
This commit is contained in:
Andy Wingo
parent
ac1ef09bfe
commit
d69531e213
8 changed files with 132 additions and 63 deletions
|
|
@ -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 in_guard, SCM thunk, SCM out_guard),
|
||||
"All three arguments must be 0-argument procedures.\n"
|
||||
"@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
|
||||
scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
|
||||
#define FUNC_NAME "dynamic-wind"
|
||||
{
|
||||
SCM ans, old_winds;
|
||||
SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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)));
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
;;; procedures, we define them as closures in terms of the primitive
|
||||
;;; macros @apply and @call-with-current-continuation.
|
||||
(set! apply (lambda (fun . args) (@apply fun (apply:nconc2last args))))
|
||||
(set-procedure-property! apply 'name 'apply)
|
||||
;;; The deal with these is that they are the procedural wrappers around the
|
||||
;;; primitives of Guile's language. There are about 20 different kinds of
|
||||
;;; expression in Guile, and e.g. @apply is one of them. (It has to be that way
|
||||
;;; to preserve tail recursion.)
|
||||
;;;
|
||||
;;; 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
|
||||
|
|
|
|||
|
|
@ -329,9 +329,9 @@
|
|||
,(tree-il->scheme (make-lambda #f '() body))))
|
||||
|
||||
((<dynamic-wind> body winder unwinder)
|
||||
`(dynamic-wind ,(unparse-tree-il winder)
|
||||
(lambda () ,(unparse-tree-il body))
|
||||
,(unparse-tree-il unwinder)))
|
||||
`(dynamic-wind ,(tree-il->scheme winder)
|
||||
(lambda () ,(tree-il->scheme body))
|
||||
,(tree-il->scheme unwinder)))
|
||||
|
||||
((<prompt> tag body handler pre-unwind-handler)
|
||||
`((@ (ice-9 control) prompt)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue