[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-82-g8fc
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-8-82-g8fc43b1 |
|
Date: |
Tue, 09 Mar 2010 21:24:11 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=8fc43b12c71789030d9058fea8b6eff5490dec27
The branch, master has been updated
via 8fc43b12c71789030d9058fea8b6eff5490dec27 (commit)
via a6cd35551023d72703cf05a98e42e9dd6a75d48f (commit)
via 5c606217a4bdd2e918d224b12fe576eff4e561c7 (commit)
from 5af3378aab5b32bd82bd93d9a789c97e553a1356 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 8fc43b12c71789030d9058fea8b6eff5490dec27
Author: Andy Wingo <address@hidden>
Date: Tue Mar 9 22:24:25 2010 +0100
prompt, abort -> call-with-prompt, abort-to-prompt
* module/ice-9/boot-9.scm (default-prompt-tag, make-prompt-tag): New
functions.
(call-with-prompt, abort-to-prompt): Rename from `prompt' and `abort',
respectively. These names are more clear, and allow `prompt' and
`abort' to have more convenient, less general bindings.
(default-throw-handler, custom-throw-handler, catch, %start-stack):
Adapt callers.
* module/ice-9/control.scm: Adapt re-export list.
(control): Remove binding, until we're sure that it is Sitaram's
control.
(abort): New binding, aborts to the nearest prompt with the default
tag.
(%): Use call-with-prompt.
* module/language/tree-il/primitives.scm (*primitive-expand-table*):
(*interesting-primitive-names*): Adapt for prompt/abort changes.
* test-suite/tests/control.test: Take advantage of the defaults for %
and abort.
commit a6cd35551023d72703cf05a98e42e9dd6a75d48f
Author: Andy Wingo <address@hidden>
Date: Sun Mar 7 22:37:57 2010 +0100
%start-stack in Scheme, in terms of prompts
* libguile/debug.h:
* libguile/debug.c (scm_sys_start_stack): Removed, we implement this in
Scheme now.
* libguile/vm.h:
* libguile/vm.c (scm_vm_call_with_new_stack): Likewise removed.
* module/ice-9/boot-9.scm (%start-stack): Implement in terms of prompts.
(%stacks): New fluid, for tracking active stacks.
(start-stack): Implement using syntax-rules.
commit 5c606217a4bdd2e918d224b12fe576eff4e561c7
Author: Andy Wingo <address@hidden>
Date: Sun Mar 7 22:19:13 2010 +0100
fix continuation printing bug
* libguile/programs.c (scm_i_program_print): Fix bug printing
continuations.
-----------------------------------------------------------------------
Summary of changes:
libguile/debug.c | 9 ---
libguile/debug.h | 3 +-
libguile/programs.c | 2 +-
libguile/vm.c | 6 --
libguile/vm.h | 1 -
module/ice-9/boot-9.scm | 56 ++++++++++++++-------
module/ice-9/control.scm | 22 ++++----
module/language/tree-il/primitives.scm | 6 +-
test-suite/tests/control.test | 84 +++++++++++--------------------
9 files changed, 83 insertions(+), 106 deletions(-)
diff --git a/libguile/debug.c b/libguile/debug.c
index 1c86c76..c8e908f 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -208,15 +208,6 @@ scm_reverse_lookup (SCM env, SCM data)
return SCM_BOOL_F;
}
-SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0,
- (SCM id, SCM thunk),
- "Call @var{thunk} on an evaluator stack tagged with @var{id}.")
-#define FUNC_NAME s_scm_sys_start_stack
-{
- return scm_vm_call_with_new_stack (scm_the_vm (), thunk, id);
-}
-#undef FUNC_NAME
-
/* Undocumented debugging procedure */
diff --git a/libguile/debug.h b/libguile/debug.h
index 6a1ee5a..7c1d02f 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -3,7 +3,7 @@
#ifndef SCM_DEBUG_H
#define SCM_DEBUG_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
@@ -42,7 +42,6 @@ typedef union scm_t_debug_info
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
-SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_with_traps (SCM thunk);
diff --git a/libguile/programs.c b/libguile/programs.c
index c80648e..e777e56 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -86,7 +86,7 @@ scm_i_program_print (SCM program, SCM port, scm_print_state
*pstate)
scm_uintprint (SCM_UNPACK (program), 16, port);
scm_putc ('>', port);
}
- if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
+ else if (SCM_PROGRAM_IS_PARTIAL_CONTINUATION (program))
{
/* twingliness */
scm_puts ("#<partial-continuation ", port);
diff --git a/libguile/vm.c b/libguile/vm.c
index 1420611..98df057 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -544,12 +544,6 @@ SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
}
#undef FUNC_NAME
-SCM
-scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id)
-{
- return scm_c_vm_run (vm, thunk, NULL, 0);
-}
-
/* Scheme interface */
SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0,
diff --git a/libguile/vm.h b/libguile/vm.h
index ade4bb6..8e22d02 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -64,7 +64,6 @@ SCM_API SCM scm_the_vm ();
SCM_API SCM scm_make_vm (void);
SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-SCM_API SCM scm_vm_call_with_new_stack (SCM vm, SCM thunk, SCM id);
SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 0b4f83c..49127b0 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -48,13 +48,17 @@
;; Define delimited continuation operators, and implement catch and throw in
;; terms of them.
-(define (prompt tag thunk handler)
+(define (default-prompt-tag)
+ (fluid-ref %default-prompt-tag))
+(define (make-prompt-tag . stem)
+ (gensym (if (pair? stem) (car stem) "prompt")))
+
+(define (call-with-prompt tag thunk handler)
(@prompt tag (thunk) handler))
-(define (abort tag . args)
+(define (abort-to-prompt tag . args)
(@abort tag args))
-
;; Define catch and with-throw-handler, using some common helper routines and a
;; shared fluid. Hide the helpers in a lexical contour.
@@ -92,7 +96,7 @@
(let ((prev (exception-handler)))
(lambda (thrown-k . args)
(if (or (eq? thrown-k catch-k) (eqv? catch-k #t))
- (apply abort prompt-tag thrown-k args)
+ (apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args)))))
(define (custom-throw-handler prompt-tag catch-k pre)
@@ -105,7 +109,7 @@
(apply pre thrown-k args))
;; fall through
(if prompt-tag
- (apply abort prompt-tag thrown-k args)
+ (apply abort-to-prompt prompt-tag thrown-k args)
(apply prev thrown-k args))))
(apply prev thrown-k args)))))
@@ -150,18 +154,19 @@ non-locally, that exit determines the continuation."
(scm-error "catch" 'wrong-type-arg
"Wrong type argument in position ~a: ~a"
(list 1 k) (list k)))
- (let ((tag (gensym)))
- (prompt tag
- (lambda ()
- (with-fluids
- ((%exception-handler
- (if (null? pre-unwind-handler)
- (default-throw-handler tag k)
- (custom-throw-handler tag k
- (car pre-unwind-handler)))))
- (thunk)))
- (lambda (cont k . args)
- (apply handler k args))))))
+ (let ((tag (make-prompt-tag "catch")))
+ (call-with-prompt
+ tag
+ (lambda ()
+ (with-fluids
+ ((%exception-handler
+ (if (null? pre-unwind-handler)
+ (default-throw-handler tag k)
+ (custom-throw-handler tag k
+ (car pre-unwind-handler)))))
+ (thunk)))
+ (lambda (cont k . args)
+ (apply handler k args))))))
(define! 'with-throw-handler
(lambda (k thunk pre-unwind-handler)
@@ -1022,8 +1027,21 @@ If there is no handler at all, Guile prints an error and
then exits."
;;; {The interpreter stack}
;;;
-(defmacro start-stack (tag exp)
- `(%start-stack ,tag (lambda () ,exp)))
+(define %stacks (make-fluid))
+(define (%start-stack tag thunk)
+ (let ((prompt-tag (make-prompt-tag "start-stack")))
+ (call-with-prompt
+ prompt-tag
+ (lambda ()
+ (with-fluids ((%stacks (acons tag prompt-tag
+ (or (fluid-ref %stacks) '()))))
+ (thunk)))
+ (lambda (k . args)
+ (%start-stack tag (lambda () (apply k args)))))))
+(define-syntax start-stack
+ (syntax-rules ()
+ ((_ tag exp)
+ (%start-stack tag (lambda () exp)))))
diff --git a/module/ice-9/control.scm b/module/ice-9/control.scm
index 482a24e..98397a3 100644
--- a/module/ice-9/control.scm
+++ b/module/ice-9/control.scm
@@ -19,20 +19,20 @@
;;; Code:
(define-module (ice-9 control)
- #:re-export (prompt abort)
- #:export (% control))
+ #:re-export (call-with-prompt abort-to-prompt
+ default-prompt-tag make-prompt-tag)
+ #:export (% abort))
-;; the same as abort.
-(define (control tag . args)
- (apply abort tag args))
+(define (abort . args)
+ (apply abort-to-prompt (default-prompt-tag) args))
(define-syntax %
(syntax-rules ()
((_ expr handler)
- (prompt (fluid-ref %default-prompt-tag)
- (lambda () expr)
- handler))
+ (call-with-prompt (default-prompt-tag)
+ (lambda () expr)
+ handler))
((_ tag expr handler)
- (prompt tag
- (lambda () expr)
- handler))))
+ (call-with-prompt tag
+ (lambda () expr)
+ handler))))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 43e53f4..b6953ca 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -63,7 +63,7 @@
fluid-ref fluid-set!
- @prompt prompt @abort abort
+ @prompt call-with-prompt @abort abort-to-prompt
struct? struct-vtable make-struct struct-ref struct-set!
@@ -454,7 +454,7 @@
(else #f)))
(hashq-set! *primitive-expand-table*
- 'prompt
+ 'call-with-prompt
(case-lambda
((src tag thunk handler)
;; Sigh. Until the inliner does its job, manually inline
@@ -482,7 +482,7 @@
(make-abort src tag '() tail-args))
(else #f)))
(hashq-set! *primitive-expand-table*
- 'abort
+ 'abort-to-prompt
(case-lambda
((src tag . args)
(make-abort src tag args (make-const #f '())))
diff --git a/test-suite/tests/control.test b/test-suite/tests/control.test
index e17b584..9937910 100644
--- a/test-suite/tests/control.test
+++ b/test-suite/tests/control.test
@@ -23,9 +23,6 @@
#:use-module (test-suite lib))
-(define default-tag (fluid-ref %default-prompt-tag))
-
-
;; For these, the compiler should be able to prove that "k" is not referenced,
;; so it avoids reifying the continuation. Since that's a slightly different
;; codepath, we test them both.
@@ -34,17 +31,15 @@
(equal? '()
(call-with-values
(lambda ()
- (% default-tag
- (values)
+ (% (values)
(lambda (k . args)
(error "unexpected exit" args))))
list)))
(pass-if "no values, abnormal exit"
(equal? '()
- (% default-tag
- (begin
- (abort default-tag)
+ (% (begin
+ (abort)
(error "unexpected exit"))
(lambda (k . args)
args))))
@@ -53,17 +48,15 @@
(equal? '(foo)
(call-with-values
(lambda ()
- (% default-tag
- 'foo
+ (% 'foo
(lambda (k . args)
(error "unexpected exit" args))))
list)))
(pass-if "single value, abnormal exit"
(equal? '(foo)
- (% default-tag
- (begin
- (abort default-tag 'foo)
+ (% (begin
+ (abort 'foo)
(error "unexpected exit"))
(lambda (k . args)
args))))
@@ -72,17 +65,15 @@
(equal? '(foo bar baz)
(call-with-values
(lambda ()
- (% default-tag
- (values 'foo 'bar 'baz)
+ (% (values 'foo 'bar 'baz)
(lambda (k . args)
(error "unexpected exit" args))))
list)))
(pass-if "multiple values, abnormal exit"
(equal? '(foo bar baz)
- (% default-tag
- (begin
- (abort default-tag 'foo 'bar 'baz)
+ (% (begin
+ (abort 'foo 'bar 'baz)
(error "unexpected exit"))
(lambda (k . args)
args)))))
@@ -93,8 +84,7 @@
(equal? '()
(call-with-values
(lambda ()
- (% default-tag
- (values)
+ (% (values)
(lambda (k . args)
(error "unexpected exit" k args))))
list)))
@@ -102,9 +92,8 @@
(pass-if "no values, abnormal exit"
(equal? '()
(cdr
- (% default-tag
- (begin
- (abort default-tag)
+ (% (begin
+ (abort)
(error "unexpected exit"))
(lambda args
args)))))
@@ -113,8 +102,7 @@
(equal? '(foo)
(call-with-values
(lambda ()
- (% default-tag
- 'foo
+ (% 'foo
(lambda (k . args)
(error "unexpected exit" k args))))
list)))
@@ -122,9 +110,8 @@
(pass-if "single value, abnormal exit"
(equal? '(foo)
(cdr
- (% default-tag
- (begin
- (abort default-tag 'foo)
+ (% (begin
+ (abort 'foo)
(error "unexpected exit"))
(lambda args
args)))))
@@ -133,8 +120,7 @@
(equal? '(foo bar baz)
(call-with-values
(lambda ()
- (% default-tag
- (values 'foo 'bar 'baz)
+ (% (values 'foo 'bar 'baz)
(lambda (k . args)
(error "unexpected exit" k args))))
list)))
@@ -142,9 +128,8 @@
(pass-if "multiple values, abnormal exit"
(equal? '(foo bar baz)
(cdr
- (% default-tag
- (begin
- (abort default-tag 'foo 'bar 'baz)
+ (% (begin
+ (abort 'foo 'bar 'baz)
(error "unexpected exit"))
(lambda args
args))))))
@@ -152,37 +137,32 @@
;; The variants check different cases in the compiler.
(with-test-prefix "restarting partial continuations"
(pass-if "in side-effect position"
- (let ((k (% default-tag
- (begin (abort default-tag) 'foo)
+ (let ((k (% (begin (abort) 'foo)
(lambda (k) k))))
(eq? (k)
'foo)))
(pass-if "passing values to side-effect abort"
- (let ((k (% default-tag
- (begin (abort default-tag) 'foo)
+ (let ((k (% (begin (abort) 'foo)
(lambda (k) k))))
(eq? (k 'qux 'baz 'hello)
'foo)))
(pass-if "called for one value"
- (let ((k (% default-tag
- (+ (abort default-tag) 3)
+ (let ((k (% (+ (abort) 3)
(lambda (k) k))))
(eqv? (k 39)
42)))
(pass-if "called for multiple values"
- (let ((k (% default-tag
- (let-values (((a b . c) (abort default-tag)))
+ (let ((k (% (let-values (((a b . c) (abort)))
(list a b c))
(lambda (k) k))))
(equal? (k 1 2 3 4)
'(1 2 (3 4)))))
(pass-if "in tail position"
- (let ((k (% default-tag
- (abort default-tag)
+ (let ((k (% (abort)
(lambda (k) k))))
(eq? (k 'xyzzy)
'xyzzy))))
@@ -192,20 +172,17 @@
(with-test-prefix "suspend/resume with fluids"
(pass-if "normal"
- (zero? (% default-tag
- (fluid-ref fl)
+ (zero? (% (fluid-ref fl)
error)))
(pass-if "with-fluids normal"
- (equal? (% default-tag
- (with-fluids ((fl (1+ (fluid-ref fl))))
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
(fluid-ref fl))
error)
1))
(pass-if "normal (post)"
(zero? (fluid-ref fl)))
(pass-if "with-fluids and fluid-set!"
- (equal? (% default-tag
- (with-fluids ((fl (1+ (fluid-ref fl))))
+ (equal? (% (with-fluids ((fl (1+ (fluid-ref fl))))
(fluid-set! fl (1+ (fluid-ref fl)))
(fluid-ref fl))
error)
@@ -223,9 +200,8 @@
(fluid-ref fl))
0))
- (let ((k (% default-tag
- (with-fluids ((fl (1+ (fluid-ref fl))))
- (abort default-tag)
+ (let ((k (% (with-fluids ((fl (1+ (fluid-ref fl))))
+ (abort)
(fluid-ref fl))
(lambda (k) k))))
(pass-if "pre"
@@ -240,8 +216,8 @@
(let ((k (% 'a
(% 'b
(begin
- (abort 'a)
- (abort 'b #t))
+ (abort-to-prompt 'a)
+ (abort-to-prompt 'b #t))
(lambda (k x) x))
(lambda (k) k))))
(k))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-8-82-g8fc43b1,
Andy Wingo <=