[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-179-gbc61280
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. v2.1.0-179-gbc61280 |
|
Date: |
Thu, 08 Mar 2012 14:25:55 +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=bc612809929b85fdcb39bc17a15a53c88b43a8bd
The branch, master has been updated
via bc612809929b85fdcb39bc17a15a53c88b43a8bd (commit)
via f740445a9b5bf0a5e5090f0a2ddaffb2b803bab7 (commit)
via 75ba64d6797f5857cc9885eb753126119a8c8b68 (commit)
via 7b327550e20967b0a8f89182bcf9a04543db3a0f (commit)
via c46fee438cf9f4a3449e8d04e7a54805517fd092 (commit)
via 42d691ee16c7f6fd102d93f9e76d436f14198f2c (commit)
via 46163e52e5513cf882dafe2bbd05ffbd2b03a755 (commit)
via be79627c21ba0848af3ac7bea25293170fec6480 (commit)
via da35d2eaa9dbc1d3cf098c9a1c9bc62dcb2515bd (commit)
via 3658a3744bcc7c75db24143db1dae1bd13554515 (commit)
via 1fa0fde4955e39891142eb5d09bb195b37409937 (commit)
via 1a4d765381904a3b8afeec1a6d0f746626a49967 (commit)
via 07bc8e7c339fb43664e17a6e016702bc13760a14 (commit)
via 3fafc52afbfc9ef398946a7ec4d96d01adc02aa1 (commit)
via 1948b38d8818d2154f4f9292adfc53537a843126 (commit)
from c336514976ed3f2b2b20c56149ede7f5ec549c52 (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 bc612809929b85fdcb39bc17a15a53c88b43a8bd
Merge: c336514 f740445
Author: Andy Wingo <address@hidden>
Date: Thu Mar 8 13:22:09 2012 +0100
Merge remote-tracking branch 'local-2.0/stable-2.0'
Conflicts:
configure.ac
libguile/finalizers.c
libguile/finalizers.h
libguile/gc.c
libguile/gc.h
libguile/inline.c
libguile/inline.h
libguile/ports.c
libguile/smob.c
libguile/smob.h
module/ice-9/deprecated.scm
module/ice-9/r4rs.scm
-----------------------------------------------------------------------
Summary of changes:
benchmark-suite/benchmarks/ports.bm | 84 +++++++++++----------
configure.ac | 2 +-
doc/ref/api-data.texi | 10 ---
libguile/finalizers.c | 23 +++++--
libguile/gc.c | 2 +
libguile/init.c | 4 +-
libguile/strings.c | 2 +-
libguile/threads.c | 3 +
libguile/vports.c | 20 ++----
module/ice-9/psyntax-pp.scm | 137 -----------------------------------
module/ice-9/psyntax.scm | 22 +++---
11 files changed, 87 insertions(+), 222 deletions(-)
diff --git a/benchmark-suite/benchmarks/ports.bm
b/benchmark-suite/benchmarks/ports.bm
index 166cfa5..630ece2 100644
--- a/benchmark-suite/benchmarks/ports.bm
+++ b/benchmark-suite/benchmarks/ports.bm
@@ -1,6 +1,6 @@
;;; ports.bm --- Port I/O. -*- mode: scheme; coding: utf-8; -*-
;;;
-;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
+;;; Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public License
@@ -21,68 +21,72 @@
#:use-module (ice-9 rdelim)
#:use-module (benchmark-suite lib))
+(define-syntax sequence
+ (lambda (s)
+ ;; Create a sequence `(begin EXPR ...)' with COUNT occurrences of EXPR.
+ (syntax-case s ()
+ ((_ expr count)
+ (number? (syntax->datum #'count))
+ (cons #'begin
+ (make-list (syntax->datum #'count) #'expr))))))
+
+(define (large-string s)
+ (string-concatenate (make-list (* iteration-factor 10000) s)))
+
(define %latin1-port
(with-fluids ((%default-port-encoding #f))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/ascii-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "hello, world")))
+ (open-input-string (large-string "hello, world"))))
(define %utf8/wide-port
(with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string "ìë
íì¸ì")))
+ (open-input-string (large-string "ìë
íì¸ì"))))
(with-benchmark-prefix "peek-char"
- (benchmark "latin-1 port" 700000
- (peek-char %latin1-port))
+ (benchmark "latin-1 port" 700
+ (sequence (peek-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 700000
- (peek-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 700
+ (sequence (peek-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 700000
- (peek-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 700
+ (sequence (peek-char %utf8/wide-port) 1000)))
-(with-benchmark-prefix "read-char"
+(with-benchmark-prefix "char-ready?"
- (benchmark "latin-1 port" 10000000
- (read-char %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (char-ready? %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (read-char %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (char-ready? %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (read-char %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (char-ready? %utf8/wide-port) 1000)))
-(with-benchmark-prefix "char-ready?"
+;; Keep the `read-char' benchmarks last as they consume input from the
+;; ports.
+
+(with-benchmark-prefix "read-char"
- (benchmark "latin-1 port" 10000000
- (char-ready? %latin1-port))
+ (benchmark "latin-1 port" 10000
+ (sequence (read-char %latin1-port) 1000))
- (benchmark "utf-8 port, ascii character" 10000000
- (char-ready? %utf8/ascii-port))
+ (benchmark "utf-8 port, ascii character" 10000
+ (sequence (read-char %utf8/ascii-port) 1000))
- (benchmark "utf-8 port, Korean character" 10000000
- (char-ready? %utf8/wide-port)))
+ (benchmark "utf-8 port, Korean character" 10000
+ (sequence (read-char %utf8/wide-port) 1000)))
(with-benchmark-prefix "rdelim"
- (let-syntax ((sequence (lambda (s)
- ;; Create a sequence `(begin EXPR ...)' with
- ;; COUNT occurrences of EXPR.
- (syntax-case s ()
- ((_ expr count)
- (number? (syntax->datum #'count))
- (cons #'begin
- (make-list
- (syntax->datum #'count)
- #'expr)))))))
- (let ((str (string-concatenate
- (make-list 1000 "one line\n"))))
- (benchmark "read-line" 1000
- (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
- (open-input-string str))))
- (sequence (read-line port) 1000))))))
+ (let ((str (string-concatenate (make-list 1000 "one line\n"))))
+ (benchmark "read-line" 1000
+ (let ((port (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-input-string str))))
+ (sequence (read-line port) 1000)))))
diff --git a/configure.ac b/configure.ac
index 3a5fd0e..f79c671 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1232,7 +1232,7 @@ save_LIBS="$LIBS"
LIBS="$BDW_GC_LIBS $LIBS"
CFLAGS="$BDW_GC_CFLAGS $CFLAGS"
-AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link
GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap
GC_get_unmapped_bytes])
+AC_CHECK_FUNCS([GC_do_blocking GC_call_with_gc_active GC_pthread_exit
GC_pthread_cancel GC_allow_register_threads GC_pthread_sigmask
GC_set_start_callback GC_get_suspend_signal GC_move_disappearing_link
GC_get_heap_usage_safe GC_get_free_space_divisor GC_gcollect_and_unmap
GC_get_unmapped_bytes GC_set_finalizer_notifier])
# Though the `GC_do_blocking ()' symbol is present in GC 7.1, it is not
# declared, and has a different type (returning void instead of
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 4fc11c8..39c9790 100644
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -3405,7 +3405,6 @@ i18n)} module}, for locale-dependent string comparison.
@rnindex string=?
@deffn {Scheme Procedure} string=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_equal_p (s1, s2, rest)
Lexicographic equality predicate; return @code{#t} if all strings are
the same length and contain the same characters in the same positions,
otherwise return @code{#f}.
@@ -3418,7 +3417,6 @@ characters.
@rnindex string<?
@deffn {Scheme Procedure} string<? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_less_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than @var{str_i+1}.
@@ -3426,7 +3424,6 @@ lexicographically less than @var{str_i+1}.
@rnindex string<=?
@deffn {Scheme Procedure} string<=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_leq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically less than or equal to @var{str_i+1}.
@@ -3434,7 +3431,6 @@ lexicographically less than or equal to @var{str_i+1}.
@rnindex string>?
@deffn {Scheme Procedure} string>? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_gr_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than @var{str_i+1}.
@@ -3442,7 +3438,6 @@ lexicographically greater than @var{str_i+1}.
@rnindex string>=?
@deffn {Scheme Procedure} string>=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_geq_p (s1, s2, rest)
Lexicographic ordering predicate; return @code{#t} if, for every pair of
consecutive string arguments @var{str_i} and @var{str_i+1}, @var{str_i} is
lexicographically greater than or equal to @var{str_i+1}.
@@ -3450,7 +3445,6 @@ lexicographically greater than or equal to @var{str_i+1}.
@rnindex string-ci=?
@deffn {Scheme Procedure} string-ci=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_equal_p (s1, s2, rest)
Case-insensitive string equality predicate; return @code{#t} if
all strings are the same length and their component
characters match (ignoring case) at each position; otherwise
@@ -3459,7 +3453,6 @@ return @code{#f}.
@rnindex string-ci<?
@deffn {Scheme Procedure} string-ci<? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_less_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than @var{str_i+1}
@@ -3468,7 +3461,6 @@ regardless of case.
@rnindex string<=?
@deffn {Scheme Procedure} string-ci<=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_leq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically less than or equal to
@@ -3477,7 +3469,6 @@ for every pair of consecutive string arguments
@var{str_i} and
@rnindex string-ci>?
@deffn {Scheme Procedure} string-ci>? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_gr_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than
@@ -3486,7 +3477,6 @@ for every pair of consecutive string arguments
@var{str_i} and
@rnindex string-ci>=?
@deffn {Scheme Procedure} string-ci>=? s1 s2 s3 @dots{}
address@hidden {C Function} scm_i_string_ci_geq_p (s1, s2, rest)
Case insensitive lexicographic ordering predicate; return @code{#t} if,
for every pair of consecutive string arguments @var{str_i} and
@var{str_i+1}, @var{str_i} is lexicographically greater than or equal to
diff --git a/libguile/finalizers.c b/libguile/finalizers.c
index 07d8f07..25aadf4 100644
--- a/libguile/finalizers.c
+++ b/libguile/finalizers.c
@@ -43,6 +43,17 @@ static size_t finalization_count;
+#ifndef HAVE_GC_SET_FINALIZER_NOTIFIER
+static void
+GC_set_finalizer_notifier (void (*notifier) (void))
+{
+ GC_finalizer_notifier = notifier;
+}
+#endif
+
+
+
+
void
scm_i_set_finalizer (void *obj, scm_t_finalizer_proc proc, void *data)
{
@@ -142,10 +153,9 @@ run_finalizers_async_thunk (void)
}
-/* The function queue_after_gc_hook is run by the scm_before_gc_c_hook
- * at the end of the garbage collection. The only purpose of this
- * function is to mark the after_gc_async (which will eventually lead to
- * the execution of the after_gc_async_thunk).
+/* The function queue_finalizer_async is run by the GC when there are
+ * objects to finalize. It will enqueue an asynchronous call to
+ * GC_invoke_finalizers() at the next SCM_TICK in this thread.
*/
static void
queue_finalizer_async (void)
@@ -154,7 +164,10 @@ queue_finalizer_async (void)
static scm_i_pthread_mutex_t lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
scm_i_pthread_mutex_lock (&lock);
- if (scm_is_false (SCM_CDR (finalizer_async_cell)))
+ /* If t is NULL, that could be because we're allocating in
+ threads.c:guilify_self_1. In that case, rely on the
+ GC_invoke_finalizers call there after the thread spins up. */
+ if (t && scm_is_false (SCM_CDR (finalizer_async_cell)))
{
SCM_SETCDR (finalizer_async_cell, t->active_asyncs);
t->active_asyncs = finalizer_async_cell;
diff --git a/libguile/gc.c b/libguile/gc.c
index b33fb0c..df93d32 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -384,6 +384,8 @@ SCM_DEFINE (scm_gc, "gc", 0, 0, 0,
#define FUNC_NAME s_scm_gc
{
scm_i_gc ("call");
+ /* If you're calling scm_gc(), you probably want synchronous
+ finalization. */
GC_invoke_finalizers ();
return SCM_UNSPECIFIED;
}
diff --git a/libguile/init.c b/libguile/init.c
index 90b01ee..684f6eb 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -444,7 +444,8 @@ scm_i_init_guile (void *base)
scm_init_ioext ();
scm_init_keywords (); /* Requires smob_prehistory */
scm_init_list ();
- scm_init_macros (); /* Requires smob_prehistory */
+ scm_init_random (); /* Requires smob_prehistory */
+ scm_init_macros (); /* Requires smob_prehistory and random */
scm_init_mallocs (); /* Requires smob_prehistory */
scm_init_modules (); /* Requires smob_prehistory */
scm_init_numbers ();
@@ -502,7 +503,6 @@ scm_i_init_guile (void *base)
scm_init_eval_in_scheme ();
scm_init_evalext ();
scm_init_debug (); /* Requires macro smobs */
- scm_init_random (); /* Requires smob_prehistory */
scm_init_simpos ();
#if HAVE_MODULES
scm_init_dynamic_linking (); /* Requires smob_prehistory */
diff --git a/libguile/strings.c b/libguile/strings.c
index 9617057..c84c830 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -748,7 +748,7 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
name = SH_STRING_STRING (name);
start += STRING_START (name);
}
- buf = SYMBOL_STRINGBUF (name);
+ buf = STRING_STRINGBUF (name);
if (start == 0 && length == STRINGBUF_LENGTH (buf))
{
diff --git a/libguile/threads.c b/libguile/threads.c
index f9104f9..8e72eaf 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -625,6 +625,9 @@ guilify_self_2 (SCM parent)
t->join_queue = make_queue ();
t->block_asyncs = 0;
+
+ /* See note in finalizers.c:queue_finalizer_async(). */
+ GC_invoke_finalizers ();
}
diff --git a/libguile/vports.c b/libguile/vports.c
index 62f552a..4ff13f2 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -56,21 +56,11 @@ sf_flush (SCM port)
scm_t_port *pt = SCM_PTAB_ENTRY (port);
SCM stream = SCM_PACK (pt->stream);
- if (pt->write_pos > pt->write_buf)
- {
- /* write the byte. */
- scm_call_1 (SCM_SIMPLE_VECTOR_REF (stream, 0),
- SCM_MAKE_CHAR (*pt->write_buf));
- pt->write_pos = pt->write_buf;
-
- /* flush the output. */
- {
- SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+ SCM f = SCM_SIMPLE_VECTOR_REF (stream, 2);
+
+ if (scm_is_true (f))
+ scm_call_0 (f);
- if (scm_is_true (f))
- scm_call_0 (f);
- }
- }
}
static void
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index f82a14c..d1ad7fe 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -2682,83 +2682,6 @@
"source expression failed to match any pattern"
tmp-1)))))))
-(define do
- (make-syntax-transformer
- 'do
- 'macro
- (lambda (orig-x)
- (let ((tmp-1 orig-x))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(_ #(each (any any . any)) (any . each-any) .
each-any))))
- (if tmp
- (apply (lambda (var init step e0 e1 c)
- (let ((tmp-1 (map (lambda (v s)
- (let ((tmp-1 s))
- (let ((tmp ($sc-dispatch tmp-1
'())))
- (if tmp
- (apply (lambda () v) tmp)
- (let ((tmp ($sc-dispatch tmp-1
'(any))))
- (if tmp
- (apply (lambda (e) e) tmp)
- (syntax-violation 'do "bad
step expression" orig-x s)))))))
- var
- step)))
- (let ((tmp ($sc-dispatch tmp-1 'each-any)))
- (if tmp
- (apply (lambda (step)
- (let ((tmp e1))
- (let ((tmp-1 ($sc-dispatch tmp '())))
- (if tmp-1
- (apply (lambda ()
- (list '#(syntax-object let
((top)) (hygiene guile))
- '#(syntax-object
doloop ((top)) (hygiene guile))
- (map list var init)
- (list
'#(syntax-object if ((top)) (hygiene guile))
- (list
'#(syntax-object not ((top)) (hygiene guile)) e0)
- (cons
'#(syntax-object begin ((top)) (hygiene guile))
- (append
- c
- (list
(cons '#(syntax-object
-
doloop
-
((top))
-
(hygiene guile))
-
step)))))))
- tmp-1)
- (let ((tmp-1 ($sc-dispatch tmp '(any
. each-any))))
- (if tmp-1
- (apply (lambda (e1 e2)
- (list '#(syntax-object
let ((top)) (hygiene guile))
- '#(syntax-object
doloop ((top)) (hygiene guile))
- (map list var
init)
- (list
'#(syntax-object if ((top)) (hygiene guile))
- e0
- (cons
'#(syntax-object begin ((top)) (hygiene guile))
- (cons
e1 e2))
- (cons
'#(syntax-object begin ((top)) (hygiene guile))
-
(append
- c
-
(list (cons '#(syntax-object
-
doloop
-
((top))
-
(hygiene guile))
-
step)))))))
- tmp-1)
- (syntax-violation
- #f
- "source expression failed to
match any pattern"
- tmp)))))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define quasiquote
(make-syntax-transformer
'quasiquote
@@ -3163,66 +3086,6 @@
"expression not valid outside of quasiquote"
x))))
-(define case
- (make-syntax-transformer
- 'case
- 'macro
- (lambda (x)
- (let ((tmp-1 x))
- (let ((tmp ($sc-dispatch tmp-1 '(_ any any . each-any))))
- (if tmp
- (apply (lambda (e m1 m2)
- (let ((tmp (let f ((clause m1) (clauses m2))
- (if (null? clauses)
- (let ((tmp-1 clause))
- (let ((tmp ($sc-dispatch
- tmp-1
- '(#(free-id #(syntax-object
else ((top)) (hygiene guile)))
- any
- .
- each-any))))
- (if tmp
- (apply (lambda (e1 e2)
- (cons '#(syntax-object
begin ((top)) (hygiene guile)) (cons e1 e2)))
- tmp)
- (let ((tmp ($sc-dispatch tmp-1
'(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object
if ((top)) (hygiene guile))
- (list
'#(syntax-object memv ((top)) (hygiene guile))
-
'#(syntax-object t ((top)) (hygiene guile))
- (list
'#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons
'#(syntax-object begin ((top)) (hygiene guile))
- (cons e1
e2))))
- tmp)
- (syntax-violation 'case "bad
clause" x clause))))))
- (let ((tmp (f (car clauses) (cdr
clauses))))
- (let ((rest tmp))
- (let ((tmp clause))
- (let ((tmp ($sc-dispatch tmp
'(each-any any . each-any))))
- (if tmp
- (apply (lambda (k e1 e2)
- (list '#(syntax-object
if ((top)) (hygiene guile))
- (list
'#(syntax-object memv ((top)) (hygiene guile))
-
'#(syntax-object t ((top)) (hygiene guile))
- (list
'#(syntax-object quote ((top)) (hygiene guile))
- k))
- (cons
'#(syntax-object begin ((top)) (hygiene guile))
- (cons e1
e2))
- rest))
- tmp)
- (syntax-violation 'case "bad
clause" x clause))))))))))
- (let ((body tmp))
- (list '#(syntax-object let ((top)) (hygiene guile))
- (list (list '#(syntax-object t ((top)) (hygiene
guile)) e))
- body))))
- tmp)
- (syntax-violation
- #f
- "source expression failed to match any pattern"
- tmp-1)))))))
-
(define make-variable-transformer
(lambda (proc)
(if (procedure? proc)
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 760f825..2cc6386 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -608,22 +608,15 @@
;; syntax object wraps
- ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
- ;; <subst> ::= <shift> | <subs>
- ;; <subs> ::= #(<old name> <label> (<mark> ...))
- ;; <shift> ::= positive fixnum
+ ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
+ ;; <subst> ::= shift | <subs>
+ ;; <subs> ::= #(ribcage #(<sym> ...) #(<mark> ...) #(<label> ...))
+ ;; | #(ribcage (<sym> ...) (<mark> ...) (<label> ...))
(define-syntax make-wrap (identifier-syntax cons))
(define-syntax wrap-marks (identifier-syntax car))
(define-syntax wrap-subst (identifier-syntax cdr))
- (define-syntax subst-rename? (identifier-syntax vector?))
- (define-syntax-rule (rename-old x) (vector-ref x 0))
- (define-syntax-rule (rename-new x) (vector-ref x 1))
- (define-syntax-rule (rename-marks x) (vector-ref x 2))
- (define-syntax-rule (make-rename old new marks)
- (vector old new marks))
-
;; labels must be comparable with "eq?", have read-write invariance,
;; and distinct from symbols.
(define (gen-label)
@@ -2903,6 +2896,9 @@
(binding (car bindings)))
#'(let (binding) body))))))))
+;; This definition of 'do' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm.
+#;
(define-syntax do
(lambda (orig-x)
(syntax-case orig-x ()
@@ -3076,6 +3072,10 @@
"expression not valid outside of quasiquote"
x)))
+;; This definition of 'case' is never used, as it is immediately
+;; replaced by the definition in boot-9.scm. This version lacks
+;; R7RS-mandated support for '=>'.
+#;
(define-syntax case
(lambda (x)
(syntax-case x ()
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. v2.1.0-179-gbc61280,
Andy Wingo <=