mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
This was a pretty big merge involving a fair amount of porting,
especially to peval and its tests.  I did not update psyntax-pp.scm,
that comes in the next commit.

Conflicts:
	module/ice-9/boot-9.scm
	module/ice-9/psyntax-pp.scm
	module/language/ecmascript/compile-tree-il.scm
	module/language/tree-il.scm
	module/language/tree-il/analyze.scm
	module/language/tree-il/inline.scm
	test-suite/tests/tree-il.test
This commit is contained in:
Andy Wingo 2011-09-29 18:02:28 +02:00
commit ca12824581
60 changed files with 3173 additions and 957 deletions
Download patch file Download diff file Expand all files Collapse all files

2
doc/ref/api-compound.texi
View file

@ -3207,7 +3207,7 @@ key is typically a constant-time operation.
The VHash programming interface of @code{(ice-9 vlist)} is mostly the same as
that of association lists found in SRFI-1, with procedure names prefixed by
@code{vhash-} instead of @code{vlist-} (@pxref{SRFI-1 Association Lists}).
@code{vhash-} instead of @code{alist-} (@pxref{SRFI-1 Association Lists}).
In addition, vhashes can be manipulated using VList operations:

27
doc/ref/api-macros.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2009, 2010, 2011
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@ -24,9 +24,15 @@ macro must appear as the first element, like this:
@end lisp
@cindex macro expansion
@cindex domain-specific language
@cindex embedded domain-specific language
@cindex DSL
@cindex EDSL
Macro expansion is a separate phase of evaluation, run before code is
interpreted or compiled. A macro is a program that runs on programs, translating
an embedded language into core Scheme.
an embedded language into core Scheme@footnote{These days such embedded
languages are often referred to as @dfn{embedded domain-specific
languages}, or EDSLs.}.
@menu
* Defining Macros:: Binding macros, globally and locally.
@ -336,6 +342,23 @@ This discussion is mostly relevant in the context of traditional Lisp macros
(@pxref{Defmacros}), which do not preserve referential transparency. Hygiene
adds to the expressive power of Scheme.
@subsubsection Shorthands
One often ends up writing simple one-clause @code{syntax-rules} macros.
There is a convenient shorthand for this idiom, in the form of
@code{define-syntax-rule}.
@deffn {Syntax} define-syntax-rule (keyword . pattern) [docstring] template
Define @var{keyword} as a new @code{syntax-rules} macro with one clause.
@end deffn
Cast into this form, our @code{when} example is significantly shorter:
@example
(define-syntax-rule (when c e ...)
(if c (begin e ...)))
@end example
@subsubsection Further Information
For a formal definition of @code{syntax-rules} and its pattern language, see

62
doc/ref/api-modules.texi
View file

@ -919,28 +919,28 @@ can also work with modules from C, but it is more cumbersome.
The following procedures are available.
@deftypefn {C Procedure} SCM scm_current_module ()
@deftypefn {C Function} SCM scm_current_module ()
Return the module that is the @emph{current module}.
@end deftypefn
@deftypefn {C Procedure} SCM scm_set_current_module (SCM @var{module})
@deftypefn {C Function} SCM scm_set_current_module (SCM @var{module})
Set the current module to @var{module} and return the previous current
module.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_call_with_current_module (SCM @var{module}, SCM (*@var{func})(void *), void *@var{data})
@deftypefn {C Function} SCM scm_c_call_with_current_module (SCM @var{module}, SCM (*@var{func})(void *), void *@var{data})
Call @var{func} and make @var{module} the current module during the
call. The argument @var{data} is passed to @var{func}. The return
value of @code{scm_c_call_with_current_module} is the return value of
@var{func}.
@end deftypefn
@deftypefn SCM scm_public_variable (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_public_variable (const char * @var{module_name}, const char * @var{name})
@deftypefn {C Function} SCM scm_public_variable (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_public_variable ({const char *}@var{module_name}, {const char *}@var{name})
Find a the variable bound to the symbol @var{name} in the public
interface of the module named @var{module_name}.
@var{module_name} should be a list of symbols, when represented as a
@var{module_name} should be a list of symbols, when represented as a
Scheme object, or a space-separated string, in the @code{const char *}
case. See @code{scm_c_define_module} below, for more examples.
@ -948,17 +948,17 @@ Signals an error if no module was found with the given name. If
@var{name} is not bound in the module, just returns @code{#f}.
@end deftypefn
@deftypefn SCM scm_private_variable (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_private_variable (const char * @var{module_name}, const char * @var{name})
@deftypefn {C Function} SCM scm_private_variable (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_private_variable ({const char *}@var{module_name}, {const char *}@var{name})
Like @code{scm_public_variable}, but looks in the internals of the
module named @var{module_name} instead of the public interface.
Logically, these procedures should only be called on modules you write.
@end deftypefn
@deftypefn SCM scm_public_lookup (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_public_lookup (const char * @var{module_name}, const char * @var{name})
@deftypefnx SCM scm_private_lookup (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_private_lookup (const char * @var{module_name}, const char * @var{name})
@deftypefn {C Function} SCM scm_public_lookup (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_public_lookup ({const char *}@var{module_name}, {const char *}@var{name})
@deftypefnx {C Function} SCM scm_private_lookup (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_private_lookup ({const char *}@var{module_name}, {const char *}@var{name})
Like @code{scm_public_variable} or @code{scm_private_variable}, but if
the @var{name} is not bound in the module, signals an error. Returns a
variable, always.
@ -977,10 +977,10 @@ SCM my_eval_string (SCM str)
@end example
@end deftypefn
@deftypefn SCM scm_public_ref (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_public_ref (const char * @var{module_name}, const char * @var{name})
@deftypefnx SCM scm_private_ref (SCM @var{module_name}, SCM @var{name})
@deftypefnx SCM scm_c_private_ref (const char * @var{module_name}, const char * @var{name})
@deftypefn {C Function} SCM scm_public_ref (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_public_ref ({const char *}@var{module_name}, {const char *}@var{name})
@deftypefnx {C Function} SCM scm_private_ref (SCM @var{module_name}, SCM @var{name})
@deftypefnx {C Function} SCM scm_c_private_ref ({const char *}@var{module_name}, {const char *}@var{name})
Like @code{scm_public_lookup} or @code{scm_private_lookup}, but
additionally dereferences the variable. If the variable object is
unbound, signals an error. Returns the value bound to @var{name} in
@ -991,50 +991,50 @@ In addition, there are a number of other lookup-related procedures. We
suggest that you use the @code{scm_public_} and @code{scm_private_}
family of procedures instead, if possible.
@deftypefn {C Procedure} SCM scm_c_lookup (const char *@var{name})
@deftypefn {C Function} SCM scm_c_lookup ({const char *}@var{name})
Return the variable bound to the symbol indicated by @var{name} in the
current module. If there is no such binding or the symbol is not
bound to a variable, signal an error.
@end deftypefn
@deftypefn {C Procedure} SCM scm_lookup (SCM @var{name})
@deftypefn {C Function} SCM scm_lookup (SCM @var{name})
Like @code{scm_c_lookup}, but the symbol is specified directly.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_module_lookup (SCM @var{module}, const char *@var{name})
@deftypefnx {C Procedure} SCM scm_module_lookup (SCM @var{module}, SCM @var{name})
@deftypefn {C Function} SCM scm_c_module_lookup (SCM @var{module}, {const char *}@var{name})
@deftypefnx {C Function} SCM scm_module_lookup (SCM @var{module}, SCM @var{name})
Like @code{scm_c_lookup} and @code{scm_lookup}, but the specified
module is used instead of the current one.
@end deftypefn
@deftypefn {C Procedure} SCM scm_module_variable (SCM @var{module}, SCM @var{name})
@deftypefn {C Function} SCM scm_module_variable (SCM @var{module}, SCM @var{name})
Like @code{scm_module_lookup}, but if the binding does not exist, just
returns @code{#f} instead of raising an error.
@end deftypefn
To define a value, use @code{scm_define}:
@deftypefn {C Procedure} SCM scm_c_define (const char *@var{name}, SCM @var{val})
@deftypefn {C Function} SCM scm_c_define ({const char *}@var{name}, SCM @var{val})
Bind the symbol indicated by @var{name} to a variable in the current
module and set that variable to @var{val}. When @var{name} is already
bound to a variable, use that. Else create a new variable.
@end deftypefn
@deftypefn {C Procedure} SCM scm_define (SCM @var{name}, SCM @var{val})
@deftypefn {C Function} SCM scm_define (SCM @var{name}, SCM @var{val})
Like @code{scm_c_define}, but the symbol is specified directly.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_module_define (SCM @var{module}, const char *@var{name}, SCM @var{val})
@deftypefnx {C Procedure} SCM scm_module_define (SCM @var{module}, SCM @var{name}, SCM @var{val})
@deftypefn {C Function} SCM scm_c_module_define (SCM @var{module}, {const char *}@var{name}, SCM @var{val})
@deftypefnx {C Function} SCM scm_module_define (SCM @var{module}, SCM @var{name}, SCM @var{val})
Like @code{scm_c_define} and @code{scm_define}, but the specified
module is used instead of the current one.
@end deftypefn
@deftypefn {C Procedure} SCM scm_module_reverse_lookup (SCM @var{module}, SCM @var{variable})
@deftypefn {C Function} SCM scm_module_reverse_lookup (SCM @var{module}, SCM @var{variable})
Find the symbol that is bound to @var{variable} in @var{module}. When no such binding is found, return @var{#f}.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_define_module (const char *@var{name}, void (*@var{init})(void *), void *@var{data})
@deftypefn {C Function} SCM scm_c_define_module ({const char *}@var{name}, void (*@var{init})(void *), void *@var{data})
Define a new module named @var{name} and make it current while
@var{init} is called, passing it @var{data}. Return the module.
@ -1046,25 +1046,25 @@ When there already exists a module named @var{name}, it is used
unchanged, otherwise, an empty module is created.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_resolve_module (const char *@var{name})
@deftypefn {C Function} SCM scm_c_resolve_module ({const char *}@var{name})
Find the module name @var{name} and return it. When it has not
already been defined, try to auto-load it. When it can't be found
that way either, create an empty module. The name is interpreted as
for @code{scm_c_define_module}.
@end deftypefn
@deftypefn {C Procedure} SCM scm_resolve_module (SCM @var{name})
@deftypefn {C Function} SCM scm_resolve_module (SCM @var{name})
Like @code{scm_c_resolve_module}, but the name is given as a real list
of symbols.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_use_module (const char *@var{name})
@deftypefn {C Function} SCM scm_c_use_module ({const char *}@var{name})
Add the module named @var{name} to the uses list of the current
module, as with @code{(use-modules @var{name})}. The name is
interpreted as for @code{scm_c_define_module}.
@end deftypefn
@deftypefn {C Procedure} SCM scm_c_export (const char *@var{name}, ...)
@deftypefn {C Function} SCM scm_c_export ({const char *}@var{name}, ...)
Add the bindings designated by @var{name}, ... to the public interface
of the current module. The list of names is terminated by
@code{NULL}.

6
doc/ref/guile-invoke.texi
View file

@ -156,6 +156,12 @@ interactive session. When executing a script with @option{-s} or
Do not use the debugging VM engine, even when entering an interactive
session.
Note that, despite the name, Guile running with @option{--no-debug}
@emph{does} support the usual debugging facilities, such as printing a
detailed backtrace upon error. The only difference with
@option{--debug} is lack of support for VM hooks and the facilities that
build upon it (see above).
@item -q
@cindex init file, not loading
@cindex @file{.guile} file, not loading

9
doc/ref/guile.texi
View file

@ -17,11 +17,10 @@ Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2009,
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
any later version published by the Free Software Foundation; with
no Invariant Sections, with the Front-Cover Texts being ``A GNU
Manual,'' and with the Back-Cover Text ``You are free to copy and
modify this GNU Manual.''. A copy of the license is included in the
section entitled ``GNU Free Documentation License''.
any later version published by the Free Software Foundation; with no
Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A
copy of the license is included in the section entitled ``GNU Free
Documentation License.''
@end copying

52
doc/ref/match.texi
View file

@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 2010 Free Software Foundation, Inc.
@c Copyright (C) 2010, 2011 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@c
@ -26,7 +26,7 @@ matcher found in many Scheme implementations.
@cindex pattern variable
A pattern matcher can match an object against several patterns and
extract the elements that make it up. Patterns can represent any Scheme
object: lists, strings, symbols, etc. They can optionally contain
object: lists, strings, symbols, records, etc. They can optionally contain
@dfn{pattern variables}. When a matching pattern is found, an
expression associated with the pattern is evaluated, optionally with all
pattern variables bound to the corresponding elements of the object:
@ -43,8 +43,8 @@ In this example, list @var{l} matches the pattern @code{('hello (who))},
because it is a two-element list whose first element is the symbol
@code{hello} and whose second element is a one-element list. Here
@var{who} is a pattern variable. @code{match}, the pattern matcher,
locally binds @var{who} to the value contained in this one-element list,
i.e., the symbol @code{world}.
locally binds @var{who} to the value contained in this one-element
list---i.e., the symbol @code{world}.
The same object can be matched against a simpler pattern:
@ -112,8 +112,8 @@ pat ::= identifier anything, and binds identifier
| #(pat_1 ... pat_n pat_n+1 ooo) vector of n or more, each element
of remainder must match pat_n+1
| #&pat box
| ($ struct-name pat_1 ... pat_n) a structure
| (= field pat) a field of a structure
| ($ record-name pat_1 ... pat_n) a record
| (= field pat) a ``field'' of an object
| (and pat_1 ... pat_n) if all of pat_1 thru pat_n match
| (or pat_1 ... pat_n) if any of pat_1 thru pat_n match
| (not pat_1 ... pat_n) if all pat_1 thru pat_n don't match
@ -122,11 +122,13 @@ pat ::= identifier anything, and binds identifier
| (set! identifier) anything, and binds setter
| (get! identifier) anything, and binds getter
| `qp a quasi-pattern
| (identifier *** pat) matches pat in a tree and binds
identifier to the path leading
to the object that matches pat
ooo ::= ... zero or more
| ___ zero or more
| ..k k or more
| __k k or more
| ..1 1 or more
quasi-patterns: matches:
@ -154,6 +156,40 @@ The names @code{quote}, @code{quasiquote}, @code{unquote},
@code{or}, @code{not}, @code{set!}, @code{get!}, @code{...}, and
@code{___} cannot be used as pattern variables.
Here is a more complex example:
@example
(use-modules (srfi srfi-9))
(let ()
(define-record-type person
(make-person name friends)
person?
(name person-name)
(friends person-friends))
(letrec ((alice (make-person "Alice" (delay (list bob))))
(bob (make-person "Bob" (delay (list alice)))))
(match alice
(($ person name (= force (($ person "Bob"))))
(list 'friend-of-bob name))
(_ #f))))
@result{} (friend-of-bob "Alice")
@end example
@noindent
Here the @code{$} pattern is used to match a SRFI-9 record of type
@var{person} containing two or more slots. The value of the first slot
is bound to @var{name}. The @code{=} pattern is used to apply
@code{force} on the second slot, and then checking that the result
matches the given pattern. In other words, the complete pattern matches
any @var{person} whose second slot is a promise that evaluates to a
one-element list containing a @var{person} whose first slot is
@code{"Bob"}.
Please refer to the @code{ice-9/match.upstream.scm} file in your Guile
installation for more details.
Guile also comes with a pattern matcher specifically tailored to SXML
trees, @xref{sxml-match}.

14
libguile/numbers.c
View file

@ -5436,6 +5436,9 @@ char_decimal_value (scm_t_uint32 c)
return d;
}
/* Parse the substring of MEM starting at *P_IDX for an unsigned integer
in base RADIX. Upon success, return the unsigned integer and update
*P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
static SCM
mem2uinteger (SCM mem, unsigned int *p_idx,
unsigned int radix, enum t_exactness *p_exactness)
@ -5707,7 +5710,16 @@ mem2ureal (SCM mem, unsigned int *p_idx,
/* Cobble up the fractional part. We might want to set the
NaN's mantissa from it. */
idx += 4;
mem2uinteger (mem, &idx, 10, &implicit_x);
if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x), SCM_INUM0))
{
#if SCM_ENABLE_DEPRECATED == 1
scm_c_issue_deprecation_warning
("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
#else
return SCM_BOOL_F;
#endif
}
*p_idx = idx;
return scm_nan ();
}

2
libguile/snarf.h
View file

@ -372,7 +372,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
SCM_PACK (0), \
foreign, \
SCM_BOOL_F, /* the name */ \
}; \
}
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
static SCM_ALIGNED (8) SCM_UNUSED SCM \

10
libguile/strings.c
View file

@ -1779,14 +1779,16 @@ scm_to_latin1_stringn (SCM str, size_t *lenp)
if (scm_i_is_narrow_string (str))
{
if (lenp)
*lenp = scm_i_string_length (str);
size_t len = scm_i_string_length (str);
result = scm_strdup (scm_i_string_data (str));
if (lenp)
*lenp = len;
result = scm_strndup (scm_i_string_data (str), len);
}
else
result = scm_to_stringn (str, lenp, NULL,
SCM_FAILED_CONVERSION_ERROR);
SCM_FAILED_CONVERSION_ERROR);
return result;
}

6
module/Makefile.am
View file

@ -91,10 +91,12 @@ SCHEME_LANG_SOURCES = \
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
language/tree-il/inline.scm \
language/tree-il/peval.scm \
language/tree-il/fix-letrec.scm \
language/tree-il/optimize.scm \
language/tree-il/canonicalize.scm \
language/tree-il/analyze.scm \
language/tree-il/inline.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm

132
module/ice-9/boot-9.scm
View file

@ -410,6 +410,20 @@ If there is no handler at all, Guile prints an error and then exits."
;; The binding for `macroexpand' has now been overridden, making psyntax the
;; expander now.
(define-syntax define-syntax-rule
(lambda (x)
(syntax-case x ()
((_ (name . pattern) template)
#'(define-syntax name
(syntax-rules ()
((_ . pattern) template))))
((_ (name . pattern) docstring template)
(string? (syntax->datum #'docstring))
#'(define-syntax name
(syntax-rules ()
docstring
((_ . pattern) template)))))))
(define-syntax and
(syntax-rules ()
((_) #t)
@ -504,9 +518,8 @@ If there is no handler at all, Guile prints an error and then exits."
((do "step" x y)
y)))
(define-syntax delay
(syntax-rules ()
((_ exp) (make-promise (lambda () exp)))))
(define-syntax-rule (delay exp)
(make-promise (lambda () exp)))
(include-from-path "ice-9/quasisyntax")
@ -517,11 +530,9 @@ If there is no handler at all, Guile prints an error and then exits."
(with-syntax ((s (datum->syntax x (syntax-source x))))
#''s)))))
(define-syntax define-once
(syntax-rules ()
((_ sym val)
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))))
(define-syntax-rule (define-once sym val)
(define sym
(if (module-locally-bound? (current-module) 'sym) sym val)))
;;; The real versions of `map' and `for-each', with cycle detection, and
;;; that use reverse! instead of recursion in the case of `map'.
@ -853,12 +864,10 @@ VALUE."
(define (and=> value procedure) (and value (procedure value)))
(define call/cc call-with-current-continuation)
(define-syntax false-if-exception
(syntax-rules ()
((_ expr)
(catch #t
(lambda () expr)
(lambda (k . args) #f)))))
(define-syntax-rule (false-if-exception expr)
(catch #t
(lambda () expr)
(lambda (k . args) #f)))
@ -877,12 +886,10 @@ VALUE."
;; properties within the object itself.
(define (make-object-property)
(define-syntax with-mutex
(syntax-rules ()
((_ lock exp)
(dynamic-wind (lambda () (lock-mutex lock))
(lambda () exp)
(lambda () (unlock-mutex lock))))))
(define-syntax-rule (with-mutex lock exp)
(dynamic-wind (lambda () (lock-mutex lock))
(lambda () exp)
(lambda () (unlock-mutex lock))))
(let ((prop (make-weak-key-hash-table))
(lock (make-mutex)))
(make-procedure-with-setter
@ -1380,10 +1387,9 @@ VALUE."
(thunk)))
(lambda (k . args)
(%start-stack tag (lambda () (apply k args)))))))
(define-syntax start-stack
(syntax-rules ()
((_ tag exp)
(%start-stack tag (lambda () exp)))))
(define-syntax-rule (start-stack tag exp)
(%start-stack tag (lambda () exp)))
@ -2819,11 +2825,9 @@ module '(ice-9 q) '(make-q q-length))}."
flags)
(interface options)
(interface)))
(define-syntax option-set!
(syntax-rules ()
((_ opt val)
(eval-when (eval load compile expand)
(options (append (options) (list 'opt val)))))))))))
(define-syntax-rule (option-set! opt val)
(eval-when (eval load compile expand)
(options (append (options) (list 'opt val)))))))))
(define-option-interface
(debug-options-interface
@ -3150,10 +3154,8 @@ module '(ice-9 q) '(make-q q-length))}."
(include-from-path "ice-9/r6rs-libraries")
(define-syntax define-private
(syntax-rules ()
((_ foo bar)
(define foo bar))))
(define-syntax-rule (define-private foo bar)
(define foo bar))
(define-syntax define-public
(syntax-rules ()
@ -3164,18 +3166,14 @@ module '(ice-9 q) '(make-q q-length))}."
(define name val)
(export name)))))
(define-syntax defmacro-public
(syntax-rules ()
((_ name args . body)
(begin
(defmacro name args . body)
(export-syntax name)))))
(define-syntax-rule (defmacro-public name args body ...)
(begin
(defmacro name args body ...)
(export-syntax name)))
;; And now for the most important macro.
(define-syntax λ
(syntax-rules ()
((_ formals body ...)
(lambda formals body ...))))
(define-syntax-rule (λ formals body ...)
(lambda formals body ...))
;; Export a local variable
@ -3234,39 +3232,29 @@ module '(ice-9 q) '(make-q q-length))}."
(module-add! public-i external-name var)))))
names)))
(define-syntax export
(syntax-rules ()
((_ name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-export! (current-module) '(name ...))))))))
(define-syntax-rule (export name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-export! (current-module) '(name ...))))))
(define-syntax re-export
(syntax-rules ()
((_ name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-re-export! (current-module) '(name ...))))))))
(define-syntax-rule (re-export name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-re-export! (current-module) '(name ...))))))
(define-syntax export!
(syntax-rules ()
((_ name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-replace! (current-module) '(name ...))))))))
(define-syntax-rule (export! name ...)
(eval-when (eval load compile expand)
(call-with-deferred-observers
(lambda ()
(module-replace! (current-module) '(name ...))))))
(define-syntax export-syntax
(syntax-rules ()
((_ name ...)
(export name ...))))
(define-syntax-rule (export-syntax name ...)
(export name ...))
(define-syntax re-export-syntax
(syntax-rules ()
((_ name ...)
(re-export name ...))))
(define-syntax-rule (re-export-syntax name ...)
(re-export name ...))

10
module/ice-9/command-line.scm
View file

@ -122,8 +122,8 @@ If FILE begins with `-' the -s switch is mandatory.
-e FUNCTION after reading script, apply FUNCTION to
command line arguments
-ds do -s script at this point
--debug start with debugging evaluator and backtraces
--no-debug start with normal evaluator
--debug start with the \"debugging\" VM engine
--no-debug start with the normal VM engine, which also supports debugging
Default is to enable debugging for interactive
use, but not for `-s' and `-c'.
--auto-compile compile source files automatically
@ -331,15 +331,15 @@ If FILE begins with `-' the -s switch is mandatory.
(parse
args
(cons
(let ((where (substring arg 8)))
(let ((where (substring arg 9)))
(cond
((string->number where) ; --listen=PORT
=> (lambda (port)
(if (and (integer? port) (exact? port) (>= port 0))
(error "invalid port for --listen")
`(@@ (system repl server)
(spawn-server
(make-tcp-server-socket #:port ,port))))))
(make-tcp-server-socket #:port ,port)))
(error "invalid port for --listen"))))
((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
`(@@ (system repl server)
(spawn-server

12
module/ice-9/compile-psyntax.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2009, 2010, 2011 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
@ -18,6 +18,7 @@
(use-modules (language tree-il)
(language tree-il optimize)
(language tree-il canonicalize)
(ice-9 pretty-print))
(let ((source (list-ref (command-line) 1))
@ -34,10 +35,11 @@
(close-port in))
(begin
(pretty-print (tree-il->scheme
(optimize!
(macroexpand x 'c '(compile load eval))
(current-module)
'()))
(canonicalize!
(optimize!
(macroexpand x 'c '(compile load eval))
(current-module)
'())))
out)
(newline out)
(loop (read in))))))

22
module/ice-9/control.scm
View file

@ -60,20 +60,16 @@
;; http://okmij.org/ftp/Scheme/delim-control-n.scm, which are in the
;; public domain, as noted at the top of http://okmij.org/ftp/.
;;
(define-syntax reset
(syntax-rules ()
((_ . body)
(call-with-prompt (default-prompt-tag)
(lambda () . body)
(lambda (cont f) (f cont))))))
(define-syntax-rule (reset . body)
(call-with-prompt (default-prompt-tag)
(lambda () . body)
(lambda (cont f) (f cont))))
(define-syntax shift
(syntax-rules ()
((_ var . body)
(abort-to-prompt (default-prompt-tag)
(lambda (cont)
((lambda (var) (reset . body))
(lambda vals (reset (apply cont vals)))))))))
(define-syntax-rule (shift var . body)
(abort-to-prompt (default-prompt-tag)
(lambda (cont)
((lambda (var) (reset . body))
(lambda vals (reset (apply cont vals)))))))
(define (reset* thunk)
(reset (thunk)))

8
module/ice-9/futures.scm
View file

@ -173,8 +173,6 @@ touched."
;;; Syntax.
;;;
(define-syntax future
(syntax-rules ()
"Return a new future for BODY."
((_ body)
(make-future (lambda () body)))))
(define-syntax-rule (future body)
"Return a new future for BODY."
(make-future (lambda () body)))

43
module/ice-9/match.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2010, 2011 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
@ -28,11 +28,50 @@
;; Error procedure for run-time "no matching pattern" errors.
(throw 'match-error "match" msg))
;; Support for record matching.
(define-syntax slot-ref
(syntax-rules ()
((_ rtd rec n)
(struct-ref rec n))))
(define-syntax slot-set!
(syntax-rules ()
((_ rtd rec n value)
(struct-set! rec n value))))
(define-syntax is-a?
(syntax-rules ()
((_ rec rtd)
(and (struct? rec)
(eq? (struct-vtable rec) rtd)))))
;; Compared to Andrew K. Wright's `match', this one lacks `match-define',
;; `match:error-control', `match:set-error-control', `match:error',
;; `match:set-error', and all structure-related procedures. Also,
;; `match' doesn't support clauses of the form `(pat => exp)'.
;; Unmodified public domain code by Alex Shinn retrieved from
;; <http://synthcode.com/scheme/match.scm>.
;; the Chibi-Scheme repository, commit 833:6daa2971f3fe.
;;
;; Note: Make sure to update `match.test.upstream' when updating this
;; file.
(include-from-path "ice-9/match.upstream.scm")
(define-syntax match
(syntax-rules ()
((match)
(match-syntax-error "missing match expression"))
((match atom)
(match-syntax-error "no match clauses"))
((match (app ...) (pat . body) ...)
(let ((v (app ...)))
(match-next v ((app ...) (set! (app ...))) (pat . body) ...)))
((match #(vec ...) (pat . body) ...)
(let ((v #(vec ...)))
(match-next v (v (set! v)) (pat . body) ...)))
((match atom (pat . body) ...)
(let ((v atom))
(match-next v (atom (set! atom)) (pat . body) ...)))
))

307
module/ice-9/match.upstream.scm
View file

@ -1,20 +1,203 @@
;;;; match.scm -- portable hygienic pattern matcher
;;;; -*- coding: utf-8 -*-
;;
;; This code is written by Alex Shinn and placed in the
;; Public Domain. All warranties are disclaimed.
;; This is a full superset of the popular MATCH package by Andrew
;; Wright, written in fully portable SYNTAX-RULES (R5RS only, breaks
;; in R6RS SYNTAX-RULES), and thus preserving hygiene.
;;> @example-import[(srfi 9)]
;; This is a simple generative pattern matcher - each pattern is
;; expanded into the required tests, calling a failure continuation if
;; the tests fail. This makes the logic easy to follow and extend,
;; but produces sub-optimal code in cases where you have many similar
;; clauses due to repeating the same tests. Nonetheless a smart
;; compiler should be able to remove the redundant tests. For
;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
;; hit.
;;> This is a full superset of the popular @hyperlink[
;;> "http://www.cs.indiana.edu/scheme-repository/code.match.html"]{match}
;;> package by Andrew Wright, written in fully portable @scheme{syntax-rules}
;;> and thus preserving hygiene.
;;> The most notable extensions are the ability to use @emph{non-linear}
;;> patterns - patterns in which the same identifier occurs multiple
;;> times, tail patterns after ellipsis, and the experimental tree patterns.
;;> @subsubsection{Patterns}
;;> Patterns are written to look like the printed representation of
;;> the objects they match. The basic usage is
;;> @scheme{(match expr (pat body ...) ...)}
;;> where the result of @var{expr} is matched against each pattern in
;;> turn, and the corresponding body is evaluated for the first to
;;> succeed. Thus, a list of three elements matches a list of three
;;> elements.
;;> @example{(let ((ls (list 1 2 3))) (match ls ((1 2 3) #t)))}
;;> If no patterns match an error is signalled.
;;> Identifiers will match anything, and make the corresponding
;;> binding available in the body.
;;> @example{(match (list 1 2 3) ((a b c) b))}
;;> If the same identifier occurs multiple times, the first instance
;;> will match anything, but subsequent instances must match a value
;;> which is @scheme{equal?} to the first.
;;> @example{(match (list 1 2 1) ((a a b) 1) ((a b a) 2))}
;;> The special identifier @scheme{_} matches anything, no matter how
;;> many times it is used, and does not bind the result in the body.
;;> @example{(match (list 1 2 1) ((_ _ b) 1) ((a b a) 2))}
;;> To match a literal identifier (or list or any other literal), use
;;> @scheme{quote}.
;;> @example{(match 'a ('b 1) ('a 2))}
;;> Analogous to its normal usage in scheme, @scheme{quasiquote} can
;;> be used to quote a mostly literally matching object with selected
;;> parts unquoted.
;;> @example|{(match (list 1 2 3) (`(1 ,b ,c) (list b c)))}|
;;> Often you want to match any number of a repeated pattern. Inside
;;> a list pattern you can append @scheme{...} after an element to
;;> match zero or more of that pattern (like a regexp Kleene star).
;;> @example{(match (list 1 2) ((1 2 3 ...) #t))}
;;> @example{(match (list 1 2 3) ((1 2 3 ...) #t))}
;;> @example{(match (list 1 2 3 3 3) ((1 2 3 ...) #t))}
;;> Pattern variables matched inside the repeated pattern are bound to
;;> a list of each matching instance in the body.
;;> @example{(match (list 1 2) ((a b c ...) c))}
;;> @example{(match (list 1 2 3) ((a b c ...) c))}
;;> @example{(match (list 1 2 3 4 5) ((a b c ...) c))}
;;> More than one @scheme{...} may not be used in the same list, since
;;> this would require exponential backtracking in the general case.
;;> However, @scheme{...} need not be the final element in the list,
;;> and may be succeeded by a fixed number of patterns.
;;> @example{(match (list 1 2 3 4) ((a b c ... d e) c))}
;;> @example{(match (list 1 2 3 4 5) ((a b c ... d e) c))}
;;> @example{(match (list 1 2 3 4 5 6 7) ((a b c ... d e) c))}
;;> @scheme{___} is provided as an alias for @scheme{...} when it is
;;> inconvenient to use the ellipsis (as in a syntax-rules template).
;;> The @scheme{..1} syntax is exactly like the @scheme{...} except
;;> that it matches one or more repetitions (like a regexp "+").
;;> @example{(match (list 1 2) ((a b c ..1) c))}
;;> @example{(match (list 1 2 3) ((a b c ..1) c))}
;;> The boolean operators @scheme{and}, @scheme{or} and @scheme{not}
;;> can be used to group and negate patterns analogously to their
;;> Scheme counterparts.
;;> The @scheme{and} operator ensures that all subpatterns match.
;;> This operator is often used with the idiom @scheme{(and x pat)} to
;;> bind @var{x} to the entire value that matches @var{pat}
;;> (c.f. "as-patterns" in ML or Haskell). Another common use is in
;;> conjunction with @scheme{not} patterns to match a general case
;;> with certain exceptions.
;;> @example{(match 1 ((and) #t))}
;;> @example{(match 1 ((and x) x))}
;;> @example{(match 1 ((and x 1) x))}
;;> The @scheme{or} operator ensures that at least one subpattern
;;> matches. If the same identifier occurs in different subpatterns,
;;> it is matched independently. All identifiers from all subpatterns
;;> are bound if the @scheme{or} operator matches, but the binding is
;;> only defined for identifiers from the subpattern which matched.
;;> @example{(match 1 ((or) #t) (else #f))}
;;> @example{(match 1 ((or x) x))}
;;> @example{(match 1 ((or x 2) x))}
;;> The @scheme{not} operator succeeds if the given pattern doesn't
;;> match. None of the identifiers used are available in the body.
;;> @example{(match 1 ((not 2) #t))}
;;> The more general operator @scheme{?} can be used to provide a
;;> predicate. The usage is @scheme{(? predicate pat ...)} where
;;> @var{predicate} is a Scheme expression evaluating to a predicate
;;> called on the value to match, and any optional patterns after the
;;> predicate are then matched as in an @scheme{and} pattern.
;;> @example{(match 1 ((? odd? x) x))}
;;> The field operator @scheme{=} is used to extract an arbitrary
;;> field and match against it. It is useful for more complex or
;;> conditional destructuring that can't be more directly expressed in
;;> the pattern syntax. The usage is @scheme{(= field pat)}, where
;;> @var{field} can be any expression, and should result in a
;;> procedure of one argument, which is applied to the value to match
;;> to generate a new value to match against @var{pat}.
;;> Thus the pattern @scheme{(and (= car x) (= cdr y))} is equivalent
;;> to @scheme{(x . y)}, except it will result in an immediate error
;;> if the value isn't a pair.
;;> @example{(match '(1 . 2) ((= car x) x))}
;;> @example{(match 4 ((= sqrt x) x))}
;;> The record operator @scheme{$} is used as a concise way to match
;;> records defined by SRFI-9 (or SRFI-99). The usage is
;;> @scheme{($ rtd field ...)}, where @var{rtd} should be the record
;;> type descriptor specified as the first argument to
;;> @scheme{define-record-type}, and each @var{field} is a subpattern
;;> matched against the fields of the record in order. Not all fields
;;> must be present.
;;> @example{
;;> (let ()
;;> (define-record-type employee
;;> (make-employee name title)
;;> employee?
;;> (name get-name)
;;> (title get-title))
;;> (match (make-employee "Bob" "Doctor")
;;> (($ employee n t) (list t n))))
;;> }
;;> The @scheme{set!} and @scheme{get!} operators are used to bind an
;;> identifier to the setter and getter of a field, respectively. The
;;> setter is a procedure of one argument, which mutates the field to
;;> that argument. The getter is a procedure of no arguments which
;;> returns the current value of the field.
;;> @example{(let ((x (cons 1 2))) (match x ((1 . (set! s)) (s 3) x)))}
;;> @example{(match '(1 . 2) ((1 . (get! g)) (g)))}
;;> The new operator @scheme{***} can be used to search a tree for
;;> subpatterns. A pattern of the form @scheme{(x *** y)} represents
;;> the subpattern @var{y} located somewhere in a tree where the path
;;> from the current object to @var{y} can be seen as a list of the
;;> form @scheme{(x ...)}. @var{y} can immediately match the current
;;> object in which case the path is the empty list. In a sense it's
;;> a 2-dimensional version of the @scheme{...} pattern.
;;> As a common case the pattern @scheme{(_ *** y)} can be used to
;;> search for @var{y} anywhere in a tree, regardless of the path
;;> used.
;;> @example{(match '(a (a (a b))) ((x *** 'b) x))}
;;> @example{(match '(a (b) (c (d e) (f g))) ((x *** 'g) x))}
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Notes
;; The implementation is a simple generative pattern matcher - each
;; pattern is expanded into the required tests, calling a failure
;; continuation if the tests fail. This makes the logic easy to
;; follow and extend, but produces sub-optimal code in cases where you
;; have many similar clauses due to repeating the same tests.
;; Nonetheless a smart compiler should be able to remove the redundant
;; tests. For MATCH-LET and DESTRUCTURING-BIND type uses there is no
;; performance hit.
;; The original version was written on 2006/11/29 and described in the
;; following Usenet post:
@ -28,6 +211,9 @@
;; performance can be found at
;; http://synthcode.com/scheme/match-cond-expand.scm
;;
;; 2011/01/27 - fixing bug when matching tail patterns against improper lists
;; 2010/09/26 - adding `..1' patterns (thanks to Ludovic Courtès)
;; 2010/09/07 - fixing identifier extraction in some `...' and `***' patterns
;; 2009/11/25 - adding `***' tree search patterns
;; 2008/03/20 - fixing bug where (a ...) matched non-lists
;; 2008/03/15 - removing redundant check in vector patterns
@ -49,6 +235,21 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;> @subsubsection{Syntax}
;;> @subsubsubsection{@rawcode{(match expr (pattern . body) ...)@br{}
;;> (match expr (pattern (=> failure) . body) ...)}}
;;> The result of @var{expr} is matched against each @var{pattern} in
;;> turn, according to the pattern rules described in the previous
;;> section, until the the first @var{pattern} matches. When a match is
;;> found, the corresponding @var{body}s are evaluated in order,
;;> and the result of the last expression is returned as the result
;;> of the entire @scheme{match}. If a @var{failure} is provided,
;;> then it is bound to a procedure of no arguments which continues,
;;> processing at the next @var{pattern}. If no @var{pattern} matches,
;;> an error is signalled.
;; The basic interface. MATCH just performs some basic syntax
;; validation, binds the match expression to a temporary variable `v',
;; and passes it on to MATCH-NEXT. It's a constant throughout the
@ -165,6 +366,10 @@
(if (pair? v)
(match-one v (p ___) g+s sk fk i)
fk))
((match-two v ($ rec p ...) g+s sk fk i)
(if (is-a? v rec)
(match-record-refs v rec 0 (p ...) g+s sk fk i)
fk))
((match-two v (p . q) g+s sk fk i)
(if (pair? v)
(let ((w (car v)) (x (cdr v)))
@ -240,6 +445,11 @@
(syntax-rules ()
((_ expr ids ...) expr)))
(define-syntax match-tuck-ids
(syntax-rules ()
((_ (letish args (expr ...)) ids ...)
(letish args (expr ... ids ...)))))
(define-syntax match-drop-first-arg
(syntax-rules ()
((_ arg expr) expr)))
@ -309,14 +519,14 @@
r
(let* ((tail-len (length 'r))
(ls v)
(len (length ls)))
(if (< len tail-len)
(len (and (list? ls) (length ls))))
(if (or (not len) (< len tail-len))
fk
(let loop ((ls ls) (n len) (id-ls '()) ...)
(cond
((= n tail-len)
(let ((id (reverse id-ls)) ...)
(match-one ls r (#f #f) (sk ... i) fk i)))
(match-one ls r (#f #f) (sk ...) fk i)))
((pair? ls)
(let ((w (car ls)))
(match-one w p ((car ls) (set-car! ls))
@ -349,21 +559,7 @@
((_ x sk)
(match-syntax-error "dotted tail not allowed after ellipse" x))))
;; Matching a tree search pattern is only slightly more complicated.
;; Here we allow patterns of the form
;;
;; (x *** y)
;;
;; to represent the pattern y located somewhere in a tree where the
;; path from the current object to y can be seen as a list of the form
;; (X ...). Y can immediately match the current object in which case
;; the path is the empty list. In a sense it's a 2-dimensional
;; version of the ... pattern.
;;
;; As a common case the pattern (_ *** y) can be used to search for Y
;; anywhere in a tree, regardless of the path used.
;;
;; To implement the search, we use two recursive procedures. TRY
;; To implement the tree search, we use two recursive procedures. TRY
;; attempts to match Y once, and on success it calls the normal SK on
;; the accumulated list ids as in MATCH-GEN-ELLIPSES. On failure, we
;; call NEXT which first checks if the current value is a list
@ -380,7 +576,7 @@
((match-gen-search v p q g+s sk fk i ((id id-ls) ...))
(letrec ((try (lambda (w fail id-ls ...)
(match-one w q g+s
(match-drop-ids
(match-tuck-ids
(let ((id (reverse id-ls)) ...)
sk))
(next w fail id-ls ...) i)))
@ -475,6 +671,15 @@
(match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
fk i)))))))
(define-syntax match-record-refs
(syntax-rules ()
((_ v rec n (p . q) g+s sk fk i)
(let ((w (slot-ref rec v n)))
(match-one w p ((slot-ref rec v n) (slot-set! rec v n))
(match-record-refs v rec (+ n 1) q g+s sk fk) fk i)))
((_ v rec n () g+s (sk ...) fk i)
(sk ... i))))
;; Extract all identifiers in a pattern. A little more complicated
;; than just looking for symbols, we need to ignore special keywords
;; and non-pattern forms (such as the predicate expression in ?
@ -518,8 +723,8 @@
(match-extract-vars (p ...) . x))
((match-extract-vars _ (k ...) i v) (k ... v))
((match-extract-vars ___ (k ...) i v) (k ... v))
((match-extract-vars ..1 (k ...) i v) (k ... v))
((match-extract-vars *** (k ...) i v) (k ... v))
((match-extract-vars ..1 (k ...) i v) (k ... v))
;; This is the main part, the only place where we might add a new
;; var if it's an unbound symbol.
((match-extract-vars p (k ...) (i ...) v)
@ -527,7 +732,7 @@
((new-sym?
(syntax-rules (i ...)
((new-sym? p sk fk) sk)
((new-sym? x sk fk) fk))))
((new-sym? any sk fk) fk))))
(new-sym? random-sym-to-match
(k ... ((p p-ls) . v))
(k ... v))))
@ -572,24 +777,42 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Gimme some sugar baby.
;;> Shortcut for @scheme{lambda} + @scheme{match}. Creates a
;;> procedure of one argument, and matches that argument against each
;;> clause.
(define-syntax match-lambda
(syntax-rules ()
((_ clause ...) (lambda (expr) (match expr clause ...)))))
((_ (pattern . body) ...) (lambda (expr) (match expr (pattern . body) ...)))))
;;> Similar to @scheme{match-lambda}. Creates a procedure of any
;;> number of arguments, and matches the argument list against each
;;> clause.
(define-syntax match-lambda*
(syntax-rules ()
((_ clause ...) (lambda expr (match expr clause ...)))))
((_ (pattern . body) ...) (lambda expr (match expr (pattern . body) ...)))))
;;> Matches each var to the corresponding expression, and evaluates
;;> the body with all match variables in scope. Raises an error if
;;> any of the expressions fail to match. Syntax analogous to named
;;> let can also be used for recursive functions which match on their
;;> arguments as in @scheme{match-lambda*}.
(define-syntax match-let
(syntax-rules ()
((_ (vars ...) . body)
(match-let/helper let () () (vars ...) . body))
((_ loop . rest)
(match-named-let loop () . rest))))
((_ ((var value) ...) . body)
(match-let/helper let () () ((var value) ...) . body))
((_ loop ((var init) ...) . body)
(match-named-let loop ((var init) ...) . body))))
;;> Similar to @scheme{match-let}, but analogously to @scheme{letrec}
;;> matches and binds the variables with all match variables in scope.
(define-syntax match-letrec
(syntax-rules ()
((_ vars . body) (match-let/helper letrec () () vars . body))))
((_ ((var value) ...) . body)
(match-let/helper letrec () () ((var value) ...) . body))))
(define-syntax match-let/helper
(syntax-rules ()
@ -617,6 +840,12 @@
((_ loop (v ...) ((pat expr) . rest) . body)
(match-named-let loop (v ... (pat expr tmp)) rest . body))))
;;> @subsubsubsection{@rawcode{(match-let* ((var value) ...) body ...)}}
;;> Similar to @scheme{match-let}, but analogously to @scheme{let*}
;;> matches and binds the variables in sequence, with preceding match
;;> variables in scope.
(define-syntax match-let*
(syntax-rules ()
((_ () . body)

12
module/ice-9/optargs.scm
View file

@ -1,6 +1,6 @@
;;;; optargs.scm -- support for optional arguments
;;;;
;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1997, 1998, 1999, 2001, 2002, 2004, 2006, 2009, 2010, 2011 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
@ -278,12 +278,10 @@
#'(define-macro id doc (lambda* args b0 b1 ...)))
((_ id args b0 b1 ...)
#'(define-macro id #f (lambda* args b0 b1 ...))))))
(define-syntax defmacro*-public
(syntax-rules ()
((_ id args b0 b1 ...)
(begin
(defmacro* id args b0 b1 ...)
(export-syntax id)))))
(define-syntax-rule (defmacro*-public id args b0 b1 ...)
(begin
(defmacro* id args b0 b1 ...)
(export-syntax id)))
;;; Support for optional & keyword args with the interpreter.
(define *uninitialized* (list 'uninitialized))

7
module/ice-9/poll.scm
View file

@ -1,6 +1,6 @@
;; poll
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011 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
@ -68,9 +68,8 @@
(ports pset-ports set-pset-ports!)
)
(define-syntax pollfd-offset
(syntax-rules ()
((_ n) (* n 8))))
(define-syntax-rule (pollfd-offset n)
(* n 8))
(define* (make-empty-poll-set #:optional (pre-allocated 4))
(make-poll-set (make-bytevector (pollfd-offset pre-allocated) 0)

87
module/ice-9/psyntax.scm
View file

@ -272,9 +272,8 @@
(lambda (x mod)
(primitive-eval x)))
(define-syntax gensym-hook
(syntax-rules ()
((_) (gensym))))
(define-syntax-rule (gensym-hook)
(gensym))
(define put-global-definition-hook
(lambda (symbol type val)
@ -451,9 +450,8 @@
;; FIXME: use a faster gensym
(define-syntax build-lexical-var
(syntax-rules ()
((_ src id) (gensym (string-append (symbol->string id) " ")))))
(define-syntax-rule (build-lexical-var src id)
(gensym (string-append (symbol->string id) " ")))
(define-structure (syntax-object expression wrap module))
@ -470,11 +468,9 @@
#f)))
(else #f))))
(define-syntax arg-check
(syntax-rules ()
((_ pred? e who)
(let ((x e))
(if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
(define-syntax-rule (arg-check pred? e who)
(let ((x e))
(if (not (pred? x)) (syntax-violation who "invalid argument" x))))
;; compile-time environments
@ -537,12 +533,10 @@
((_ type value) (cons type value))
((_ 'type) '(type))
((_ type) (cons type '()))))
(define-syntax binding-type
(syntax-rules ()
((_ x) (car x))))
(define-syntax binding-value
(syntax-rules ()
((_ x) (cdr x))))
(define-syntax-rule (binding-type x)
(car x))
(define-syntax-rule (binding-value x)
(cdr x))
(define-syntax null-env (identifier-syntax '()))
@ -607,13 +601,11 @@
((syntax-object? x) (symbol? (syntax-object-expression x)))
(else #f))))
(define-syntax id-sym-name
(syntax-rules ()
((_ e)
(let ((x e))
(if (syntax-object? x)
(syntax-object-expression x)
x)))))
(define-syntax-rule (id-sym-name e)
(let ((x e))
(if (syntax-object? x)
(syntax-object-expression x)
x)))
(define id-sym-name&marks
(lambda (x w)
@ -635,12 +627,11 @@
(define-syntax wrap-subst (identifier-syntax cdr))
(define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0))))
(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1))))
(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2))))
(define-syntax make-rename
(syntax-rules ()
((_ old new marks) (vector old new marks))))
(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.
@ -659,9 +650,8 @@
(define-syntax top-wrap (identifier-syntax '((top))))
(define-syntax top-marked?
(syntax-rules ()
((_ w) (memq 'top (wrap-marks w)))))
(define-syntax-rule (top-marked? w)
(memq 'top (wrap-marks w)))
;; Marks must be comparable with "eq?" and distinct from pairs and
;; the symbol top. We do not use integers so that marks will remain
@ -674,15 +664,13 @@
(make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w)))))
(define-syntax new-mark
(syntax-rules ()
((_) (gensym "m"))))
(define-syntax-rule (new-mark)
(gensym "m"))
;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;; internal definitions, in which the ribcages are built incrementally
(define-syntax make-empty-ribcage
(syntax-rules ()
((_) (make-ribcage '() '() '()))))
(define-syntax-rule (make-empty-ribcage)
(make-ribcage '() '() '()))
(define extend-ribcage!
;; must receive ids with complete wraps
@ -751,10 +739,9 @@
(define id-var-name
(lambda (id w)
(define-syntax first
(syntax-rules ()
;; Rely on Guile's multiple-values truncation.
((_ e) e)))
(define-syntax-rule (first e)
;; Rely on Guile's multiple-values truncation.
e)
(define search
(lambda (sym subst marks)
(if (null? subst)
@ -2686,6 +2673,20 @@
((dummy . pattern) #'template)
...))))))
(define-syntax define-syntax-rule
(lambda (x)
(syntax-case x ()
((_ (name . pattern) template)
#'(define-syntax name
(syntax-rules ()
((_ . pattern) template))))
((_ (name . pattern) docstring template)
(string? (syntax->datum #'docstring))
#'(define-syntax name
(syntax-rules ()
docstring
((_ . pattern) template)))))))
(define-syntax let*
(lambda (x)
(syntax-case x ()

14
module/ice-9/receive.scm
View file

@ -1,6 +1,6 @@
;;;; SRFI-8
;;; Copyright (C) 2000, 2001, 2004, 2006, 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2000, 2001, 2004, 2006, 2010, 2011 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
@ -17,14 +17,10 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (ice-9 receive)
:export (receive)
:no-backtrace
)
#:export (receive))
(define-syntax receive
(syntax-rules ()
((receive vars vals . body)
(call-with-values (lambda () vals)
(lambda vars . body)))))
(define-syntax-rule (receive vars vals . body)
(call-with-values (lambda () vals)
(lambda vars . body)))
(cond-expand-provide (current-module) '(srfi-8))

56
module/ice-9/threads.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1996, 1998, 2001, 2002, 2003, 2006, 2010, 2011 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
@ -51,12 +51,10 @@
;;; Macros first, so that the procedures expand correctly.
(define-syntax begin-thread
(syntax-rules ()
((_ e0 e1 ...)
(call-with-new-thread
(lambda () e0 e1 ...)
%thread-handler))))
(define-syntax-rule (begin-thread e0 e1 ...)
(call-with-new-thread
(lambda () e0 e1 ...)
%thread-handler))
(define-syntax parallel
(lambda (x)
@ -67,35 +65,27 @@
...)
(values (touch tmp0) ...)))))))
(define-syntax letpar
(syntax-rules ()
((_ ((v e) ...) b0 b1 ...)
(call-with-values
(lambda () (parallel e ...))
(lambda (v ...)
b0 b1 ...)))))
(define-syntax-rule (letpar ((v e) ...) b0 b1 ...)
(call-with-values
(lambda () (parallel e ...))
(lambda (v ...)
b0 b1 ...)))
(define-syntax make-thread
(syntax-rules ()
((_ proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
%thread-handler))))
(define-syntax-rule (make-thread proc arg ...)
(call-with-new-thread
(lambda () (proc arg ...))
%thread-handler))
(define-syntax with-mutex
(syntax-rules ()
((_ m e0 e1 ...)
(let ((x m))
(dynamic-wind
(lambda () (lock-mutex x))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))))
(define-syntax-rule (with-mutex m e0 e1 ...)
(let ((x m))
(dynamic-wind
(lambda () (lock-mutex x))
(lambda () (begin e0 e1 ...))
(lambda () (unlock-mutex x)))))
(define-syntax monitor
(syntax-rules ()
((_ first rest ...)
(with-mutex (make-mutex)
first rest ...))))
(define-syntax-rule (monitor first rest ...)
(with-mutex (make-mutex)
first rest ...))
(define (par-mapper mapper)
(lambda (proc . arglists)

20
module/ice-9/vlist.scm
View file

@ -70,14 +70,12 @@
(fluid-set! f 2)
f))
(define-syntax define-inline
(define-syntax-rule (define-inline (name formals ...) body ...)
;; Work around the lack of an inliner.
(syntax-rules ()
((_ (name formals ...) body ...)
(define-syntax name
(syntax-rules ()
((_ formals ...)
(begin body ...)))))))
(define-syntax name
(syntax-rules ()
((_ formals ...)
(begin body ...)))))
(define-inline (make-block base offset size hash-tab?)
;; Return a block (and block descriptor) of SIZE elements pointing to BASE
@ -90,11 +88,9 @@
base offset size 0
(and hash-tab? (make-vector size #f))))
(define-syntax define-block-accessor
(syntax-rules ()
((_ name index)
(define-inline (name block)
(vector-ref block index)))))
(define-syntax-rule (define-block-accessor name index)
(define-inline (name block)
(vector-ref block index)))
(define-block-accessor block-content 0)
(define-block-accessor block-base 1)

18
module/language/assembly/compile-bytecode.scm
View file

@ -28,16 +28,14 @@
#:export (compile-bytecode))
(define (compile-bytecode assembly env . opts)
(define-syntax define-inline1
(syntax-rules ()
((_ (proc arg) body body* ...)
(define-syntax proc
(syntax-rules ()
((_ (arg-expr (... ...)))
(let ((x (arg-expr (... ...))))
(proc x)))
((_ arg)
(begin body body* ...)))))))
(define-syntax-rule (define-inline1 (proc arg) body body* ...)
(define-syntax proc
(syntax-rules ()
((_ (arg-expr (... ...)))
(let ((x (arg-expr (... ...))))
(proc x)))
((_ arg)
(begin body body* ...)))))
(define (fill-bytecode bv target-endianness)
(let ((pos 0))

36
module/language/ecmascript/compile-tree-il.scm
View file

@ -25,20 +25,14 @@
#:use-module (srfi srfi-1)
#:export (compile-tree-il))
(define-syntax ->
(syntax-rules ()
((_ (type arg ...))
`(type ,arg ...))))
(define-syntax-rule (-> (type arg ...))
`(type ,arg ...))
(define-syntax @implv
(syntax-rules ()
((_ sym)
(-> (@ '(language ecmascript impl) 'sym)))))
(define-syntax-rule (@implv sym)
(-> (@ '(language ecmascript impl) 'sym)))
(define-syntax @impl
(syntax-rules ()
((_ sym arg ...)
(-> (call (@implv sym) arg ...)))))
(define-syntax-rule (@impl sym arg ...)
(-> (call (@implv sym) arg ...)))
(define (empty-lexical-environment)
'())
@ -67,16 +61,14 @@
;; for emacs:
;; (put 'pmatch/source 'scheme-indent-function 1)
(define-syntax pmatch/source
(syntax-rules ()
((_ x clause ...)
(let ((x x))
(let ((res (pmatch x
clause ...)))
(let ((loc (location x)))
(if loc
(set-source-properties! res (location x))))
res)))))
(define-syntax-rule (pmatch/source x clause ...)
(let ((x x))
(let ((res (pmatch x
clause ...)))
(let ((loc (location x)))
(if loc
(set-source-properties! res (location x))))
res)))
(define (comp x e)
(let ((l (location x)))

2
module/language/glil/compile-assembly.scm
View file

@ -856,7 +856,7 @@
(vector-fold2 (lambda (x codes addr)
(receive (subcode addr) (ref-or-dump x i addr)
(values (cons subcode codes) addr)))
x '() addr)
contents '() addr)
(receive (shape addr) (ref-or-dump (array-shape x) i addr)
(values (fold append
(let ((len (vector-length contents)))

156
module/language/tree-il.scm
View file

@ -344,7 +344,7 @@
`(dynref ,(unparse-tree-il fluid)))
((<dynset> fluid exp)
`(dynref ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
`(dynset ,(unparse-tree-il fluid) ,(unparse-tree-il exp)))
((<prompt> tag body handler)
`(prompt ,(unparse-tree-il tag) ,(unparse-tree-il body) ,(unparse-tree-il handler)))
@ -588,84 +588,82 @@ This is an implementation of `foldts' as described by Andy Wingo in
(leaf tree result))))))
(define-syntax make-tree-il-folder
(syntax-rules ()
((_ seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
(record-case tree
((<lexical-set> exp)
(foldts exp seed ...))
((<module-set> exp)
(foldts exp seed ...))
((<toplevel-set> exp)
(foldts exp seed ...))
((<toplevel-define> exp)
(foldts exp seed ...))
((<conditional> test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<primcall> name args)
(fold-values foldts args seed ...))
((<seq> head tail)
(let-values (((seed ...) (foldts head seed ...)))
(foldts tail seed ...)))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
(let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...))
(foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
((<dynwind> body winder unwinder)
(let*-values (((seed ...) (foldts body seed ...))
((seed ...) (foldts winder seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<dynref> fluid)
(foldts fluid seed ...))
((<dynset> fluid exp)
(let*-values (((seed ...) (foldts fluid seed ...)))
(foldts exp seed ...)))
((<prompt> tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
((<abort> tag args tail)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))))
(define-syntax-rule (make-tree-il-folder seed ...)
(lambda (tree down up seed ...)
(define (fold-values proc exps seed ...)
(if (null? exps)
(values seed ...)
(let-values (((seed ...) (proc (car exps) seed ...)))
(fold-values proc (cdr exps) seed ...))))
(let foldts ((tree tree) (seed seed) ...)
(let*-values
(((seed ...) (down tree seed ...))
((seed ...)
(record-case tree
((<lexical-set> exp)
(foldts exp seed ...))
((<module-set> exp)
(foldts exp seed ...))
((<toplevel-set> exp)
(foldts exp seed ...))
((<toplevel-define> exp)
(foldts exp seed ...))
((<conditional> test consequent alternate)
(let*-values (((seed ...) (foldts test seed ...))
((seed ...) (foldts consequent seed ...)))
(foldts alternate seed ...)))
((<call> proc args)
(let-values (((seed ...) (foldts proc seed ...)))
(fold-values foldts args seed ...)))
((<primcall> name args)
(fold-values foldts args seed ...))
((<seq> head tail)
(let-values (((seed ...) (foldts head seed ...)))
(foldts tail seed ...)))
((<lambda> body)
(foldts body seed ...))
((<lambda-case> inits body alternate)
(let-values (((seed ...) (fold-values foldts inits seed ...)))
(if alternate
(let-values (((seed ...) (foldts body seed ...)))
(foldts alternate seed ...))
(foldts body seed ...))))
((<let> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<letrec> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<fix> vals body)
(let*-values (((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<let-values> exp body)
(let*-values (((seed ...) (foldts exp seed ...)))
(foldts body seed ...)))
((<dynwind> body winder unwinder)
(let*-values (((seed ...) (foldts body seed ...))
((seed ...) (foldts winder seed ...)))
(foldts unwinder seed ...)))
((<dynlet> fluids vals body)
(let*-values (((seed ...) (fold-values foldts fluids seed ...))
((seed ...) (fold-values foldts vals seed ...)))
(foldts body seed ...)))
((<dynref> fluid)
(foldts fluid seed ...))
((<dynset> fluid exp)
(let*-values (((seed ...) (foldts fluid seed ...)))
(foldts exp seed ...)))
((<prompt> tag body handler)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (foldts body seed ...)))
(foldts handler seed ...)))
((<abort> tag args tail)
(let*-values (((seed ...) (foldts tag seed ...))
((seed ...) (fold-values foldts args seed ...)))
(foldts tail seed ...)))
(else
(values seed ...)))))
(up tree seed ...)))))
(define (post-order! f x)
(let lp ((x x))

68
module/language/tree-il/analyze.scm
View file

@ -23,6 +23,7 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (system base syntax)
#:use-module (system base message)
#:use-module (system vm program)
@ -869,25 +870,20 @@ accurate information is missing from a given `tree-il' element."
;; the name of the variable being defined; otherwise return #f. This
;; assumes knowledge of the current implementation of `define-class' et al.
(define (toplevel-define-arg args)
(and (pair? args) (pair? (cdr args)) (null? (cddr args))
(record-case (car args)
((<const> exp)
(and (symbol? exp) exp))
(else #f))))
(match args
((($ <const> _ (and (? symbol?) exp)) _)
exp)
(_ #f)))
(record-case proc
((<module-ref> mod public? name)
(and (equal? mod '(oop goops))
(not public?)
(eq? name 'toplevel-define!)
(toplevel-define-arg args)))
((<toplevel-ref> name)
(match proc
(($ <module-ref> _ '(oop goops) 'toplevel-define! #f)
(toplevel-define-arg args))
(($ <toplevel-ref> _ 'toplevel-define!)
;; This may be the result of expanding one of the GOOPS macros within
;; `oop/goops.scm'.
(and (eq? name 'toplevel-define!)
(eq? env (resolve-module '(oop goops)))
(and (eq? env (resolve-module '(oop goops)))
(toplevel-define-arg args)))
(else #f)))
(_ #f)))
(define unbound-variable-analysis
;; Report possibly unbound variables in the given tree.
@ -1345,24 +1341,17 @@ accurate information is missing from a given `tree-il' element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
;; Return the literal format pattern for X, or #f.
(define (const-fmt x)
(record-case x
((<const> exp)
;; Return the literal format pattern for X, or #f.
(match x
(($ <const> _ exp)
exp)
((<call> proc args)
(($ <call> _
(or ($ <toplevel-ref> _ '_) ($ <module-ref> _ '_))
(($ <const> _ (and (? string?) fmt))))
;; Gettexted literals, like `(_ "foo")'.
(and (record-case proc
((<toplevel-ref> name) (eq? name '_))
((<module-ref> name) (eq? name '_))
(else #f))
(pmatch args
((,fmt)
(record-case fmt
((<const> exp) exp)
(else #f)))
(else #f))))
(else #f)))
fmt)
(_ #f)))
(define format-analysis
;; Report arity mismatches in the given tree.
@ -1413,18 +1402,13 @@ accurate information is missing from a given `tree-il' element."
(and (module? env)
(false-if-exception (module-ref env name))))
(record-case x
((<call> proc args src)
(let ((loc src))
(record-case proc
((<toplevel-ref> name src)
(let ((proc (resolve-toplevel name)))
(and (or (eq? proc format)
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
(else #t)))
#t)
(else #t))
(match x
(($ <call> src ($ <toplevel-ref> _ name) args)
(let ((proc (resolve-toplevel name)))
(and (or (eq? proc format)
(eq? proc (@ (ice-9 format) format)))
(check-format-args args (or src (find pair? locs))))))
(_ #t))
#t)
(lambda (x _ env locs)

76
module/language/tree-il/canonicalize.scm Normal file
View file

@ -0,0 +1,76 @@
;;; Tree-il canonicalizer
;; Copyright (C) 2011 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 as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;; Code:
(define-module (language tree-il canonicalize)
#:use-module (language tree-il)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (canonicalize!))
(define (tree-il-any proc exp)
(tree-il-fold (lambda (exp res)
(or res (proc exp)))
(lambda (exp res)
(or res (proc exp)))
(lambda (exp res) res)
#f exp))
(define (canonicalize! x)
(post-order!
(lambda (x)
(match x
(($ <let> src () () () body)
body)
(($ <letrec> src _ () () () body)
body)
(($ <fix> src () () () body)
body)
(($ <dynlet> src () () body)
body)
(($ <prompt> src tag body handler)
(define (escape-only? handler)
(match handler
(($ <lambda-case> _ (_ . _) _ _ _ _ (cont . _) body #f)
(tree-il-any (lambda (x)
(and (lexical-ref? x)
(eq? (lexical-ref-gensym x) cont)))
body))
(else #f)))
(define (thunk-application? x)
(match x
(($ <call> _
($ <lambda> _ _ ($ <lambda-case> _ () #f #f #f))
()) #t)
(_ #f)))
(define (make-thunk-application body)
(define thunk
(make-lambda #f '()
(make-lambda-case #f '() #f #f #f '() '() body #f)))
(make-call #f thunk '()))
;; This code has a nasty job to do: to ensure that either the
;; handler is escape-only, or the body is the application of a
;; thunk. Sad but true.
(if (or (escape-only? handler)
(thunk-application? body))
#f
(make-prompt src tag (make-thunk-application body) handler)))
(_ #f)))
x))

2
module/language/tree-il/compile-glil.scm
View file

@ -27,6 +27,7 @@
#:use-module (system vm instruction)
#:use-module (language tree-il)
#:use-module (language tree-il optimize)
#:use-module (language tree-il canonicalize)
#:use-module (language tree-il analyze)
#:use-module ((srfi srfi-1) #:select (filter-map))
#:export (compile-glil))
@ -64,6 +65,7 @@
(let* ((x (make-lambda (tree-il-src x) '()
(make-lambda-case #f '() #f #f #f '() '() x #f)))
(x (optimize! x e opts))
(x (canonicalize! x))
(allocation (analyze-lexicals x)))
(with-fluids ((*comp-module* e))

186
module/language/tree-il/inline.scm
View file

@ -17,189 +17,9 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il inline)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:use-module (language tree-il)
#:export (inline!))
;; Possible optimizations:
;; * constant folding, propagation
;; * procedure inlining
;; * always when single call site
;; * always for "trivial" procs
;; * otherwise who knows
;; * dead code elimination
;; * degenerate case optimizations
;; * "fixing letrec"
(define (boolean-value x)
(let ((src (tree-il-src x)))
(record-case x
((<void>)
(make-const src #t))
((<conditional> test consequent alternate)
(record-case (boolean-value test)
((<const> exp)
(case exp
((#t) (boolean-value consequent))
((#f) (boolean-value alternate))
(else x)))
(else x)))
((<primcall> src name args)
(pmatch (cons name args)
((,member ,k ,l) (guard (and (memq member '(memq memv))
(const? k)
(list? (const-exp l))))
(cond
((null? (const-exp l))
(make-const #f #f))
((const? k)
(make-const #f (->bool ((case member
((memq) memq)
((memv) memv)
(else (error "what" member)))
(const-exp k) (const-exp l)))))
(else
(let lp ((elts (const-exp l)))
(let ((test (make-primcall
#f
(case member
((memq) 'eq?)
((memv) 'eqv?)
(else (error "what" member)))
(list k (make-const #f (car elts))))))
(if (null? (cdr elts))
test
(make-conditional
src
test
(make-const #f #t)
(lp (cdr elts)))))))))
(else x)))
((<lambda> meta body)
(make-const src #t))
((<const> exp)
(make-const src (not (not exp))))
(else
x))))
;; This is a completely brain-dead optimization pass whose sole claim to
;; fame is ((lambda () x)) => x.
(define (inline! x)
(define (inline1 x)
(record-case x
((<call> src proc args)
(record-case proc
;; ((lambda (y ...) x) z ...) => (let ((y z) ...) x)
((<lambda> body)
(let lp ((lcase body))
(and lcase
(record-case lcase
((<lambda-case> req opt rest kw inits gensyms body alternate)
(if (and (= (length gensyms) (length req) (length args)))
(let ((x (make-let src req gensyms args body)))
(or (inline1 x) x))
(lp alternate)))))))
(else #f)))
((<primcall> src name args)
(pmatch (cons name args)
;; (call-with-values (lambda () foo) (lambda (a b . c) bar))
;; => (let-values (((a b . c) foo)) bar)
;;
;; Note that this is a singly-binding form of let-values. Also
;; note that Scheme's let-values expands into call-with-values,
;; then here we reduce it to tree-il's let-values.
((@call-with-values ,producer ,consumer)
(guard (lambda? consumer)
(lambda-case? (lambda-body consumer))
(not (lambda-case-opt (lambda-body consumer)))
(not (lambda-case-kw (lambda-body consumer)))
(not (lambda-case-alternate (lambda-body consumer))))
(make-let-values
src
(let ((x (make-call src producer '())))
(or (inline1 x) x))
(lambda-body consumer)))
(else #f)))
((<conditional> test consequent alternate)
(let ((btest (boolean-value test)))
(or (record-case btest
((<const> exp)
(case exp
((#t) consequent)
((#f) alternate)
(else #f)))
(else #f))
(if (eq? test btest)
x
(make-conditional (conditional-src x)
btest consequent alternate)))))
((<let> gensyms body)
(if (null? gensyms) body x))
((<letrec> gensyms body)
(if (null? gensyms) body x))
((<fix> gensyms body)
(if (null? gensyms) body x))
((<lambda-case> req opt rest kw gensyms body alternate)
(define (args-compatible? args gensyms)
(let lp ((args args) (gensyms gensyms))
(cond
((null? args) (null? gensyms))
((null? gensyms) #f)
((and (lexical-ref? (car args))
(eq? (lexical-ref-gensym (car args)) (car gensyms)))
(lp (cdr args) (cdr gensyms)))
(else #f))))
(and (not opt) (not kw) rest (not alternate)
(record-case body
((<primcall> name args)
;; (lambda args (apply (lambda ...) args)) => (lambda ...)
(and (eq? name '@apply)
(pair? args)
(lambda? (car args))
(args-compatible? (cdr args) gensyms)
(lambda-body (car args))))
(else #f))))
;; Actually the opposite of inlining -- if the prompt cannot be proven to
;; be escape-only, ensure that its body is the call of a thunk.
((<prompt> src tag body handler)
(define (escape-only? handler)
(and (pair? (lambda-case-req handler))
(let ((cont (car (lambda-case-gensyms handler))))
(tree-il-fold (lambda (leaf escape-only?)
(and escape-only?
(not
(and (lexical-ref? leaf)
(eq? (lexical-ref-gensym leaf) cont)))))
(lambda (down escape-only?) escape-only?)
(lambda (up escape-only?) escape-only?)
#t
(lambda-case-body handler)))))
(define (make-thunk body)
(make-lambda #f '() (make-lambda-case #f '() #f #f #f '() '() body #f)))
(if (or (and (call? body)
(lambda? (call-proc body))
(null? (call-args body)))
(escape-only? handler))
x
(make-prompt src tag
(make-call #f (make-thunk body) '())
handler)))
(else #f)))
(post-order! inline1 x))
(issue-deprecation-warning
"`inline!' is deprecated. Use (language tree-il peval) instead.")
x)

17
module/language/tree-il/optimize.scm
View file

@ -1,6 +1,6 @@
;;; Tree-il optimizer
;; Copyright (C) 2009 Free Software Foundation, Inc.
;; Copyright (C) 2009, 2011 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
@ -21,12 +21,17 @@
(define-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language tree-il inline)
#:use-module (language tree-il peval)
#:use-module (language tree-il fix-letrec)
#:use-module (ice-9 match)
#:export (optimize!))
(define (optimize! x env opts)
(inline!
(fix-letrec!
(expand-primitives!
(resolve-primitives! x env)))))
(let ((peval (match (memq #:partial-eval? opts)
((#:partial-eval? #f _ ...)
;; Disable partial evaluation.
(lambda (x e) x))
(_ peval))))
(fix-letrec!
(peval (expand-primitives! (resolve-primitives! x env))
env))))

922
module/language/tree-il/peval.scm Normal file
View file

@ -0,0 +1,922 @@
;;; Tree-IL partial evaluator
;; Copyright (C) 2011 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 as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (language tree-il peval)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (ice-9 vlist)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (peval))
;;;
;;; Partial evaluation.
;;;
(define (fresh-gensyms syms)
(map (lambda (x) (gensym (string-append (symbol->string x) " ")))
syms))
(define (alpha-rename exp)
"Alpha-rename EXP. For any lambda in EXP, generate new symbols and
replace all lexical references to the former symbols with lexical
references to the new symbols."
;; XXX: This should be factorized somehow.
(let loop ((exp exp)
(mapping vlist-null)) ; maps old to new gensyms
(match exp
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
;; Create new symbols to replace GENSYMS and propagate them down
;; in BODY and ALT.
(let* ((new (fresh-gensyms
(append req
(or opt '())
(if rest (list rest) '())
(match kw
((aok? (_ name _) ...) name)
(_ '())))))
(mapping (fold vhash-consq mapping gensyms new)))
(make-lambda-case src req opt rest
(match kw
((aok? (kw name old) ...)
(cons aok? (map list
kw
name
(take-right new (length old)))))
(_ #f))
(map (cut loop <> mapping) inits)
new
(loop body mapping)
(and alt (loop alt mapping)))))
(($ <lexical-ref> src name gensym)
;; Possibly replace GENSYM by the new gensym defined in MAPPING.
(let ((val (vhash-assq gensym mapping)))
(if val
(make-lexical-ref src name (cdr val))
exp)))
(($ <lexical-set> src name gensym exp)
(let ((val (vhash-assq gensym mapping)))
(make-lexical-set src name (if val (cdr val) gensym)
(loop exp mapping))))
(($ <lambda> src meta body)
(make-lambda src meta (loop body mapping)))
(($ <let> src names gensyms vals body)
;; As for `lambda-case' rename GENSYMS to avoid any collision.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-let src names new vals body)))
(($ <letrec> src in-order? names gensyms vals body)
;; Likewise.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-letrec src in-order? names new vals body)))
(($ <fix> src names gensyms vals body)
;; Likewise.
(let* ((new (fresh-gensyms names))
(mapping (fold vhash-consq mapping gensyms new))
(vals (map (cut loop <> mapping) vals))
(body (loop body mapping)))
(make-fix src names new vals body)))
(($ <let-values> src exp body)
(make-let-values src (loop exp mapping) (loop body mapping)))
(($ <const>)
exp)
(($ <void>)
exp)
(($ <toplevel-ref>)
exp)
(($ <module-ref>)
exp)
(($ <primitive-ref>)
exp)
(($ <toplevel-set> src name exp)
(make-toplevel-set src name (loop exp mapping)))
(($ <toplevel-define> src name exp)
(make-toplevel-define src name (loop exp mapping)))
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (loop exp mapping)))
(($ <dynlet> src fluids vals body)
(make-dynlet src
(map (cut loop <> mapping) fluids)
(map (cut loop <> mapping) vals)
(loop body mapping)))
(($ <dynwind> src winder body unwinder)
(make-dynwind src
(loop winder mapping)
(loop body mapping)
(loop unwinder mapping)))
(($ <dynref> src fluid)
(make-dynref src (loop fluid mapping)))
(($ <dynset> src fluid exp)
(make-dynset src (loop fluid mapping) (loop exp mapping)))
(($ <conditional> src condition subsequent alternate)
(make-conditional src
(loop condition mapping)
(loop subsequent mapping)
(loop alternate mapping)))
(($ <call> src proc args)
(make-call src (loop proc mapping)
(map (cut loop <> mapping) args)))
(($ <primcall> src name args)
(make-primcall src name (map (cut loop <> mapping) args)))
(($ <seq> src head tail)
(make-seq src (loop head mapping) (loop tail mapping)))
(($ <prompt> src tag body handler)
(make-prompt src (loop tag mapping) (loop body mapping)
(loop handler mapping)))
(($ <abort> src tag args tail)
(make-abort src (loop tag mapping) (map (cut loop <> mapping) args)
(loop tail mapping))))))
(define-syntax-rule (let/ec k e e* ...)
(let ((tag (make-prompt-tag)))
(call-with-prompt
tag
(lambda ()
(let ((k (lambda args (apply abort-to-prompt tag args))))
e e* ...))
(lambda (_ res) res))))
(define (tree-il-any proc exp)
(let/ec k
(tree-il-fold (lambda (exp res)
(let ((res (proc exp)))
(if res (k res) #f)))
(lambda (exp res)
(let ((res (proc exp)))
(if res (k res) #f)))
(lambda (exp res) #f)
#f exp)))
(define (vlist-any proc vlist)
(let ((len (vlist-length vlist)))
(let lp ((i 0))
(and (< i len)
(or (proc (vlist-ref vlist i))
(lp (1+ i)))))))
(define-record-type <var>
(make-var name gensym refcount set?)
var?
(name var-name)
(gensym var-gensym)
(refcount var-refcount set-var-refcount!)
(set? var-set? set-var-set?!))
(define* (build-var-table exp #:optional (table vlist-null))
(tree-il-fold
(lambda (exp res)
(match exp
(($ <lexical-ref> src name gensym)
(let ((var (vhash-assq gensym res)))
(if var
(begin
(set-var-refcount! (cdr var) (1+ (var-refcount (cdr var))))
res)
(vhash-consq gensym (make-var name gensym 1 #f) res))))
(_ res)))
(lambda (exp res)
(match exp
(($ <lexical-set> src name gensym exp)
(let ((var (vhash-assq gensym res)))
(if var
(begin
(set-var-set?! (cdr var) #t)
res)
(vhash-consq gensym (make-var name gensym 0 #t) res))))
(_ res)))
(lambda (exp res) res)
table exp))
(define-record-type <counter>
(%make-counter effort size continuation recursive? data prev)
counter?
(effort effort-counter)
(size size-counter)
(continuation counter-continuation)
(recursive? counter-recursive?)
(data counter-data)
(prev counter-prev))
(define (abort-counter c)
((counter-continuation c)))
(define (record-effort! c)
(let ((e (effort-counter c)))
(if (zero? (variable-ref e))
(abort-counter c)
(variable-set! e (1- (variable-ref e))))))
(define (record-size! c)
(let ((s (size-counter c)))
(if (zero? (variable-ref s))
(abort-counter c)
(variable-set! s (1- (variable-ref s))))))
(define (find-counter data counter)
(and counter
(if (eq? data (counter-data counter))
counter
(find-counter data (counter-prev counter)))))
(define* (transfer! from to #:optional
(effort (variable-ref (effort-counter from)))
(size (variable-ref (size-counter from))))
(define (transfer-counter! from-v to-v amount)
(let* ((from-balance (variable-ref from-v))
(to-balance (variable-ref to-v))
(amount (min amount from-balance)))
(variable-set! from-v (- from-balance amount))
(variable-set! to-v (+ to-balance amount))))
(transfer-counter! (effort-counter from) (effort-counter to) effort)
(transfer-counter! (size-counter from) (size-counter to) size))
(define (make-top-counter effort-limit size-limit continuation data)
(%make-counter (make-variable effort-limit)
(make-variable size-limit)
continuation
#t
data
#f))
(define (make-nested-counter continuation data current)
(let ((c (%make-counter (make-variable 0)
(make-variable 0)
continuation
#f
data
current)))
(transfer! current c)
c))
(define (make-recursive-counter effort-limit size-limit orig current)
(let ((c (%make-counter (make-variable 0)
(make-variable 0)
(counter-continuation orig)
#t
(counter-data orig)
current)))
(transfer! current c effort-limit size-limit)
c))
(define (types-check? primitive-name args)
(case primitive-name
((values) #t)
((not pair? null? list? symbol? vector? struct?)
(= (length args) 1))
((eq? eqv? equal?)
(= (length args) 2))
;; FIXME: add more cases?
(else #f)))
(define* (peval exp #:optional (cenv (current-module)) (env vlist-null)
#:key
(operator-size-limit 40)
(operand-size-limit 20)
(value-size-limit 10)
(effort-limit 500)
(recursive-effort-limit 100))
"Partially evaluate EXP in compilation environment CENV, with
top-level bindings from ENV and return the resulting expression. Since
it does not handle <fix> and <let-values>, it should be called before
`fix-letrec'."
;; This is a simple partial evaluator. It effectively performs
;; constant folding, copy propagation, dead code elimination, and
;; inlining, but not across top-level bindings---there should be a way
;; to allow this (TODO).
;;
;; Unlike a full-blown partial evaluator, it does not emit definitions
;; of specialized versions of lambdas encountered on its way. Also,
;; it's not yet complete: it bails out for `prompt', etc.
(define local-toplevel-env
;; The top-level environment of the module being compiled.
(let ()
(define (env-folder x env)
(match x
(($ <toplevel-define> _ name)
(vhash-consq name #t env))
(($ <seq> _ head tail)
(env-folder tail (env-folder head env)))
(_ env)))
(env-folder exp vlist-null)))
(define (local-toplevel? name)
(vhash-assq name local-toplevel-env))
(define store (build-var-table exp))
(define (assigned-lexical? sym)
(let ((v (vhash-assq sym store)))
(and v (var-set? (cdr v)))))
(define (lexical-refcount sym)
(let ((v (vhash-assq sym store)))
(if v (var-refcount (cdr v)) 0)))
(define (record-source-expression! orig new)
(set! store (vhash-consq new
(source-expression orig)
(build-var-table new store)))
new)
(define (source-expression new)
(let ((x (vhash-assq new store)))
(if x (cdr x) new)))
(define residual-lexical-references (make-hash-table))
(define (record-residual-lexical-reference! sym)
(hashq-set! residual-lexical-references sym #t))
(define (apply-primitive name args)
;; todo: further optimize commutative primitives
(catch #t
(lambda ()
(call-with-values
(lambda ()
(apply (module-ref the-scm-module name) args))
(lambda results
(values #t results))))
(lambda _
(values #f '()))))
(define (inline-values exp src names gensyms body)
(let loop ((exp exp))
(match exp
;; Some expression types are always singly-valued.
((or ($ <const>)
($ <void>)
($ <lambda>)
($ <lexical-ref>)
($ <toplevel-ref>)
($ <module-ref>)
($ <primitive-ref>)
($ <dynref>)
($ <lexical-set>) ; FIXME: these set! expressions
($ <toplevel-set>) ; could return zero values in
($ <toplevel-define>) ; the future
($ <module-set>) ;
($ <dynset>)) ;
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
(($ <primcall> src (? singly-valued-primitive? name))
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
;; Statically-known number of values.
(($ <primcall> src 'values vals)
(and (= (length names) (length vals))
(make-let src names gensyms vals body)))
;; Not going to copy code into both branches.
(($ <conditional>) #f)
;; Bail on other applications.
(($ <call>) #f)
(($ <primcall>) #f)
;; Bail on prompt and abort.
(($ <prompt>) #f)
(($ <abort>) #f)
;; Propagate to tail positions.
(($ <let> src names gensyms vals body)
(let ((body (loop body)))
(and body
(make-let src names gensyms vals body))))
(($ <letrec> src in-order? names gensyms vals body)
(let ((body (loop body)))
(and body
(make-letrec src in-order? names gensyms vals body))))
(($ <fix> src names gensyms vals body)
(let ((body (loop body)))
(and body
(make-fix src names gensyms vals body))))
(($ <let-values> src exp
($ <lambda-case> src2 req opt rest kw inits gensyms body #f))
(let ((body (loop body)))
(and body
(make-let-values src exp
(make-lambda-case src2 req opt rest kw
inits gensyms body #f)))))
(($ <dynwind> src winder body unwinder)
(let ((body (loop body)))
(and body
(make-dynwind src winder body unwinder))))
(($ <dynlet> src fluids vals body)
(let ((body (loop body)))
(and body
(make-dynlet src fluids vals body))))
(($ <seq> src head tail)
(let ((tail (loop tail)))
(and tail (make-seq src head tail)))))))
(define (make-values src values)
(match values
((single) single) ; 1 value
((_ ...) ; 0, or 2 or more values
(make-primcall src 'values values))))
(define (constant-expression? x)
;; Return true if X is constant---i.e., if it is known to have no
;; effects, does not allocate storage for a mutable object, and does
;; not access mutable data (like `car' or toplevel references).
(let loop ((x x))
(match x
(($ <void>) #t)
(($ <const>) #t)
(($ <lambda>) #t)
(($ <lambda-case> _ req opt rest kw inits _ body alternate)
(and (every loop inits) (loop body) (loop alternate)))
(($ <lexical-ref> _ _ gensym)
(not (assigned-lexical? gensym)))
(($ <primitive-ref>) #t)
(($ <conditional> _ condition subsequent alternate)
(and (loop condition) (loop subsequent) (loop alternate)))
(($ <primcall> _ name args)
(and (effect-free-primitive? name)
(not (constructor-primitive? name))
(types-check? name args)
(every loop args)))
(($ <call> _ ($ <lambda> _ _ body) args)
(and (loop body) (every loop args)))
(($ <seq> _ head tail)
(and (loop head) (loop tail)))
(($ <let> _ _ _ vals body)
(and (every loop vals) (loop body)))
(($ <letrec> _ _ _ _ vals body)
(and (every loop vals) (loop body)))
(($ <fix> _ _ _ vals body)
(and (every loop vals) (loop body)))
(($ <let-values> _ exp body)
(and (loop exp) (loop body)))
(($ <prompt> _ tag body handler)
(and (loop tag) (loop body) (loop handler)))
(_ #f))))
(define (prune-bindings names syms vals body for-effect
build-result)
(let lp ((names names) (syms syms) (vals vals)
(names* '()) (syms* '()) (vals* '())
(effects '()))
(match (list names syms vals)
((() () ())
(let ((body (list->seq #f (append effects (list body)))))
(if (null? names*)
body
(build-result (reverse names*) (reverse syms*)
(reverse vals*) body))))
(((name . names) (sym . syms) (val . vals))
(if (hashq-ref residual-lexical-references sym)
(lp names syms vals
(cons name names*) (cons sym syms*) (cons val vals*)
effects)
(let ((effect (for-effect val)))
(lp names syms vals
names* syms* vals*
(if (void? effect)
effects
(cons effect effects)))))))))
(define (small-expression? x limit)
(let/ec k
(tree-il-fold
(lambda (x res) ; leaf
(1+ res))
(lambda (x res) ; down
(1+ res))
(lambda (x res) ; up
(if (< res limit)
res
(k #f)))
0 x)
#t))
(let loop ((exp exp)
(env vlist-null) ; static environment
(counter #f) ; inlined call stack
(ctx 'value)) ; effect, value, test, operator, or operand
(define (lookup var)
(and=> (vhash-assq var env) cdr))
(define (for-value exp)
(loop exp env counter 'value))
(define (for-operand exp)
(loop exp env counter 'operand))
(define (for-test exp)
(loop exp env counter 'test))
(define (for-effect exp)
(loop exp env counter 'effect))
(define (for-tail exp)
(loop exp env counter ctx))
(if counter
(record-effort! counter))
(match exp
(($ <const>)
(case ctx
((effect) (make-void #f))
(else exp)))
(($ <void>)
(case ctx
((test) (make-const #f #t))
(else exp)))
(($ <lexical-ref> _ _ gensym)
(case ctx
((effect) (make-void #f))
(else
(let ((val (lookup gensym)))
(cond
((or (not val)
(assigned-lexical? gensym)
(not (constant-expression? val)))
;; Don't copy-propagate through assigned variables,
;; and don't reorder effects.
(record-residual-lexical-reference! gensym)
exp)
((lexical-ref? val)
(for-tail val))
((or (const? val)
(void? val)
(primitive-ref? val))
;; Always propagate simple values that cannot lead to
;; code bloat.
(for-tail val))
((= 1 (lexical-refcount gensym))
;; Always propagate values referenced only once.
;; There is no need to rename the bindings, as they
;; are only being moved, not copied. However in
;; operator context we do rename it, as that
;; effectively clears out the residualized-lexical
;; flags that may have been set when this value was
;; visited previously as an operand.
(case ctx
((test) (for-test val))
((operator) (record-source-expression! val (alpha-rename val)))
(else val)))
;; FIXME: do demand-driven size accounting rather than
;; these heuristics.
((eq? ctx 'operator)
;; A pure expression in the operator position. Inline
;; if it's a lambda that's small enough.
(if (and (lambda? val)
(small-expression? val operator-size-limit))
(record-source-expression! val (alpha-rename val))
(begin
(record-residual-lexical-reference! gensym)
exp)))
((eq? ctx 'operand)
;; A pure expression in the operand position. Inline
;; if it's small enough.
(if (small-expression? val operand-size-limit)
(record-source-expression! val (alpha-rename val))
(begin
(record-residual-lexical-reference! gensym)
exp)))
(else
;; A pure expression, processed for value. Don't
;; inline lambdas, because they will probably won't
;; fold because we don't know the operator.
(if (and (small-expression? val value-size-limit)
(not (tree-il-any lambda? val)))
(record-source-expression! val (alpha-rename val))
(begin
(record-residual-lexical-reference! gensym)
exp))))))))
(($ <lexical-set> src name gensym exp)
(if (zero? (lexical-refcount gensym))
(let ((exp (for-effect exp)))
(if (void? exp)
exp
(make-seq src exp (make-void #f))))
(begin
(record-residual-lexical-reference! gensym)
(make-lexical-set src name gensym (for-value exp)))))
(($ <let> src names gensyms vals body)
(let* ((vals (map for-operand vals))
(body (loop body
(fold vhash-consq env gensyms vals)
counter
ctx)))
(cond
((const? body)
(for-tail (list->seq src (append vals (list body)))))
((and (lexical-ref? body)
(memq (lexical-ref-gensym body) gensyms))
(let ((sym (lexical-ref-gensym body))
(pairs (map cons gensyms vals)))
;; (let ((x foo) (y bar) ...) x) => (begin bar ... foo)
(for-tail
(list->seq
src
(append (map cdr (alist-delete sym pairs eq?))
(list (assq-ref pairs sym)))))))
(else
;; Only include bindings for which lexical references
;; have been residualized.
(prune-bindings names gensyms vals body for-effect
(lambda (names gensyms vals body)
(if (null? names) (error "what!" names))
(make-let src names gensyms vals body)))))))
(($ <letrec> src in-order? names gensyms vals body)
;; Things could be done more precisely when IN-ORDER? but
;; it's OK not to do it---at worst we lost an optimization
;; opportunity.
(let* ((vals (map for-operand vals))
(body (loop body
(fold vhash-consq env gensyms vals)
counter
ctx)))
(if (and (const? body)
(every constant-expression? vals))
body
(prune-bindings names gensyms vals body for-effect
(lambda (names gensyms vals body)
(make-letrec src in-order?
names gensyms vals body))))))
(($ <fix> src names gensyms vals body)
(let* ((vals (map for-operand vals))
(body (loop body
(fold vhash-consq env gensyms vals)
counter
ctx)))
(if (const? body)
body
(prune-bindings names gensyms vals body for-effect
(lambda (names gensyms vals body)
(make-fix src names gensyms vals body))))))
(($ <let-values> lv-src producer consumer)
;; Peval the producer, then try to inline the consumer into
;; the producer. If that succeeds, peval again. Otherwise
;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-value producer)))
(or (match consumer
(($ <lambda-case> src req #f #f #f () gensyms body #f)
(cond
((inline-values producer src req gensyms body)
=> for-tail)
(else #f)))
(_ #f))
(make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder body unwinder)
(make-dynwind src (for-value winder) (for-tail body)
(for-value unwinder)))
(($ <dynlet> src fluids vals body)
(make-dynlet src (map for-value fluids) (map for-value vals)
(for-tail body)))
(($ <dynref> src fluid)
(make-dynref src (for-value fluid)))
(($ <dynset> src fluid exp)
(make-dynset src (for-value fluid) (for-value exp)))
(($ <toplevel-ref> src (? effect-free-primitive? name))
(if (local-toplevel? name)
exp
(resolve-primitives! exp cenv)))
(($ <toplevel-ref>)
;; todo: open private local bindings.
exp)
(($ <module-ref>)
exp)
(($ <module-set> src mod name public? exp)
(make-module-set src mod name public? (for-value exp)))
(($ <toplevel-define> src name exp)
(make-toplevel-define src name (for-value exp)))
(($ <toplevel-set> src name exp)
(make-toplevel-set src name (for-value exp)))
(($ <primitive-ref>)
(case ctx
((effect) (make-void #f))
((test) (make-const #f #t))
(else exp)))
(($ <conditional> src condition subsequent alternate)
(let ((condition (for-test condition)))
(if (const? condition)
(if (const-exp condition)
(for-tail subsequent)
(for-tail alternate))
(make-conditional src condition
(for-tail subsequent)
(for-tail alternate)))))
(($ <primcall> src '@call-with-values
(producer
($ <lambda> _ _
(and consumer
;; No optional or kwargs.
($ <lambda-case>
_ req #f rest #f () gensyms body #f)))))
(for-tail (make-let-values src (make-call src producer '())
consumer)))
(($ <primcall> src (? constructor-primitive? name) args)
(case ctx
((effect test)
(let ((res (if (eq? ctx 'effect)
(make-void #f)
(make-const #f #t))))
(match (cons name (map for-value args))
(('cons x xs)
(for-tail (make-seq src (make-seq src x xs) res)))
(((or 'list 'vector) . elts)
(for-tail (list->seq src (append elts (list res)))))
(('make-prompt-tag . (or () (($ <const> _ (? string?)))))
res)
((name . args)
(make-primcall src name args)))))
(else
(match (cons name (map for-value args))
(('cons x ($ <const> _ ()))
(make-primcall src 'list (list x)))
(('cons x ($ <primcall> _ 'list elts))
(make-primcall src 'list (cons x elts)))
;; FIXME: these for-tail recursions could take
;; place outside an effort counter.
(('car ($ <primcall> _ 'cons (x xs)))
(for-tail (make-seq src xs x)))
(('cdr ($ <primcall> _ 'cons (x xs)))
(for-tail (make-seq src x xs)))
(('car ($ <primcall> _ 'list (head . rest)))
(for-tail (list->seq src (append rest (list head)))))
(('cdr ($ <primcall> _ 'list (head . rest)))
(for-tail (make-seq src head
(make-primcall src 'list rest))))
(('car ($ <const> _ (head . tail)))
(for-tail (make-const src head)))
(('cdr ($ <const> _ (head . tail)))
(for-tail (make-const src tail)))
((name . args)
(make-primcall src name args))))))
(($ <primcall> src (? effect-free-primitive? name) args)
(let ((args (map for-value args)))
(if (every const? args) ; only simple constants
(let-values (((success? values)
(apply-primitive name
(map const-exp args))))
(if success?
(case ctx
((effect) (make-void #f))
((test)
;; Values truncation: only take the first
;; value.
(if (pair? values)
(make-const #f (car values))
(make-values src '())))
(else
(make-values src (map (cut make-const src <>)
values))))
(make-primcall src name args)))
(cond
((and (eq? ctx 'effect) (types-check? name args))
(make-void #f))
(else
(make-primcall src name args))))))
(($ <primcall> src name args)
(make-primcall src name (map for-value args)))
(($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions
(let ((proc (loop orig-proc env counter 'operator)))
(match proc
(($ <primitive-ref> _ name)
(for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _
($ <lambda-case> _ req opt #f #f inits gensyms body #f))
;; Simple case: no rest, no keyword arguments.
;; todo: handle the more complex cases
(let* ((nargs (length orig-args))
(nreq (length req))
(nopt (if opt (length opt) 0))
(key (source-expression proc)))
(cond
((or (< nargs nreq) (> nargs (+ nreq nopt)))
;; An error, or effecting arguments.
(make-call src (for-value orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?)
(lambda? orig-proc))
;; A recursive call, or a lambda in the operator
;; position of the source expression. Process again in
;; tail context.
(loop (make-let src (append req (or opt '()))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env counter ctx))
(else
;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested
;; integration of a procedure that hasn't been seen
;; yet.
(let/ec k
(define (abort)
(k (make-call src
(for-value orig-proc)
(map for-value orig-args))))
(define new-counter
(cond
;; These first two cases will transfer effort
;; from the current counter into the new
;; counter.
((find-counter key counter)
=> (lambda (prev)
(make-recursive-counter recursive-effort-limit
operand-size-limit
prev counter)))
(counter
(make-nested-counter abort key counter))
;; This case opens a new account, effectively
;; printing money. It should only do so once
;; for each call site in the source program.
(else
(make-top-counter effort-limit operand-size-limit
abort key))))
(define result
(loop (make-let src (append req (or opt '()))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env new-counter ctx))
(if counter
;; The nested inlining attempt succeeded.
;; Deposit the unspent effort and size back
;; into the current counter.
(transfer! new-counter counter))
result)))))
(_
(make-call src proc (map for-value orig-args))))))
(($ <lambda> src meta body)
(case ctx
((effect) (make-void #f))
((test) (make-const #f #t))
((operator) exp)
(else
(make-lambda src meta (for-value body)))))
(($ <lambda-case> src req opt rest kw inits gensyms body alt)
(make-lambda-case src req opt rest kw
(map for-value inits)
gensyms
(for-tail body)
(and alt (for-tail alt))))
(($ <seq> src head tail)
(let ((head (for-effect head))
(tail (for-tail tail)))
(if (void? head)
tail
(make-seq src
(if (and (seq? head)
(void? (seq-tail head)))
(seq-head head)
head)
tail))))
(($ <prompt> src tag body handler)
(define (singly-used-definition x)
(cond
((and (lexical-ref? x)
;; Only fetch definitions with single uses.
(= (lexical-refcount (lexical-ref-gensym x)) 1)
(lookup (lexical-ref-gensym x)))
=> singly-used-definition)
(else x)))
(match (singly-used-definition tag)
(($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
;; There is no way that an <abort> could know the tag
;; for this <prompt>, so we can elide the <prompt>
;; entirely.
(for-tail body))
(_
(make-prompt src (for-value tag) (for-tail body)
(for-value handler)))))
(($ <abort> src tag args tail)
(make-abort src (for-value tag) (map for-value args)
(for-value tail))))))

76
module/language/tree-il/primitives.scm
View file

@ -27,7 +27,8 @@
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives!
effect-free-primitive? effect+exception-free-primitive?))
effect-free-primitive? effect+exception-free-primitive?
constructor-primitive? singly-valued-primitive?))
(define *interesting-primitive-names*
'(apply @apply
@ -106,21 +107,23 @@
(for-each add-interesting-primitive! *interesting-primitive-names*)
(define *primitive-constructors*
;; Primitives that return a fresh object.
'(acons cons cons* list vector make-struct make-struct/no-tail
car cdr vector-ref struct-ref make-prompt-tag))
(define *effect-free-primitives*
'(values
`(values
eq? eqv? equal?
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
not
pair? null? list? symbol? vector? acons cons cons*
list vector
car cdr
pair? null? list? symbol? vector?
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref
struct? struct-vtable make-struct make-struct/no-tail struct-ref
struct? struct-vtable
bytevector-u8-ref bytevector-s8-ref
bytevector-u16-ref bytevector-u16-native-ref
bytevector-s16-ref bytevector-s16-native-ref
@ -129,7 +132,8 @@
bytevector-u64-ref bytevector-u64-native-ref
bytevector-s64-ref bytevector-s64-native-ref
bytevector-ieee-single-ref bytevector-ieee-single-native-ref
bytevector-ieee-double-ref bytevector-ieee-double-native-ref))
bytevector-ieee-double-ref bytevector-ieee-double-native-ref
,@*primitive-constructors*))
;; Like *effect-free-primitives* above, but further restricted in that they
;; cannot raise exceptions.
@ -141,8 +145,55 @@
list vector
struct?))
;; Primitives that only return one value.
(define *singly-valued-primitives*
'(eq? eqv? equal?
memq memv
= < > <= >= zero?
+ * - / 1- 1+ quotient remainder modulo
ash logand logior logxor
not
pair? null? list? symbol? vector? acons cons cons*
list vector
car cdr
set-car! set-cdr!
caar cadr cdar cddr
caaar caadr cadar caddr cdaar cdadr cddar cdddr
caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr
cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr
vector-ref vector-set!
variable-ref variable-set!
variable-bound?
fluid-ref fluid-set!
make-prompt-tag
struct? struct-vtable make-struct struct-ref struct-set!
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
u8vector-ref u8vector-set! s8vector-ref s8vector-set!
bytevector-u16-ref bytevector-u16-set!
bytevector-u16-native-ref bytevector-u16-native-set!
bytevector-s16-ref bytevector-s16-set!
bytevector-s16-native-ref bytevector-s16-native-set!
u16vector-ref u16vector-set! s16vector-ref s16vector-set!
bytevector-u32-ref bytevector-u32-set!
bytevector-u32-native-ref bytevector-u32-native-set!
bytevector-s32-ref bytevector-s32-set!
bytevector-s32-native-ref bytevector-s32-native-set!
u32vector-ref u32vector-set! s32vector-ref s32vector-set!
bytevector-u64-ref bytevector-u64-set!
bytevector-u64-native-ref bytevector-u64-native-set!
bytevector-s64-ref bytevector-s64-set!
bytevector-s64-native-ref bytevector-s64-native-set!
u64vector-ref u64vector-set! s64vector-ref s64vector-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
(define *effect-free-primitive-table* (make-hash-table))
(define *effect+exceptions-free-primitive-table* (make-hash-table))
(define *singly-valued-primitive-table* (make-hash-table))
(for-each (lambda (x)
(hashq-set! *effect-free-primitive-table* x #t))
@ -150,11 +201,18 @@
(for-each (lambda (x)
(hashq-set! *effect+exceptions-free-primitive-table* x #t))
*effect+exception-free-primitives*)
(for-each (lambda (x)
(hashq-set! *singly-valued-primitive-table* x #t))
*singly-valued-primitives*)
(define (constructor-primitive? prim)
(memq prim *primitive-constructors*))
(define (effect-free-primitive? prim)
(hashq-ref *effect-free-primitive-table* prim))
(define (effect+exception-free-primitive? prim)
(hashq-ref *effect+exceptions-free-primitive-table* prim))
(define (singly-valued-primitive? prim)
(hashq-ref *singly-valued-primitive-table* prim))
(define (resolve-primitives! x mod)
(post-order!
@ -247,6 +305,8 @@
(define-primitive-expander zero? (x)
(= x 0))
;; FIXME: All the code that uses `const?' is redundant with `peval'.
(define-primitive-expander +
() 0
(x) (values x)

67
module/oop/goops.scm
View file

@ -347,21 +347,18 @@
#'(define-class-pre-definitions (rest ...)
out ... (define-class-pre-definition (slotopt ...)))))))
(define-syntax define-class
(syntax-rules ()
((_ name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(if (and (defined? 'name)
(is-a? name <class>)
(memq <object> (class-precedence-list name)))
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))))
(define-syntax-rule (define-class name supers slot ...)
(begin
(define-class-pre-definitions (slot ...))
(if (and (defined? 'name)
(is-a? name <class>)
(memq <object> (class-precedence-list name)))
(class-redefinition name
(class supers slot ... #:name 'name))
(toplevel-define! 'name (class supers slot ... #:name 'name)))))
(define-syntax standard-define-class
(syntax-rules ()
((_ arg ...) (define-class arg ...))))
(define-syntax-rule (standard-define-class arg ...)
(define-class arg ...))
;;;
;;; {Generic functions and accessors}
@ -428,13 +425,15 @@
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(cons eg (slot-ref gf 'extended-by))))
gfs))
gfs)
(invalidate-method-cache! eg))
(define (not-extended-by! gfs eg)
(for-each (lambda (gf)
(slot-set! gf 'extended-by
(delq! eg (slot-ref gf 'extended-by))))
gfs))
gfs)
(invalidate-method-cache! eg))
(define* (ensure-generic old-definition #:optional name)
(cond ((is-a? old-definition <generic>) old-definition)
@ -449,13 +448,11 @@
(else (make <generic> #:name name))))
;; same semantics as <generic>
(define-syntax define-accessor
(syntax-rules ()
((_ name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))))
(define-syntax-rule (define-accessor name)
(define name
(cond ((not (defined? 'name)) (ensure-accessor #f 'name))
((is-a? name <accessor>) (make <accessor> #:name 'name))
(else (ensure-accessor name 'name)))))
(define (make-setter-name name)
(string->symbol (string-append "setter:" (symbol->string name))))
@ -505,6 +502,7 @@
(slot-set! method 'generic-function gws))
methods)
(slot-set! gws 'methods methods)
(invalidate-method-cache! gws)
gws))
;;;
@ -669,15 +667,25 @@
methods)
(loop (cdr l)))))))
(define (method-n-specializers m)
(length* (slot-ref m 'specializers)))
(define (calculate-n-specialized gf)
(fold (lambda (m n) (max n (method-n-specializers m)))
0
(generic-function-methods gf)))
(define (invalidate-method-cache! gf)
(%invalidate-method-cache! gf)
(slot-set! gf 'n-specialized (calculate-n-specialized gf))
(for-each (lambda (gf) (invalidate-method-cache! gf))
(slot-ref gf 'extended-by)))
(define internal-add-method!
(method ((gf <generic>) (m <method>))
(slot-set! m 'generic-function gf)
(slot-set! gf 'methods (compute-new-list-of-methods gf m))
(let ((specializers (slot-ref m 'specializers)))
(slot-set! gf 'n-specialized
(max (length* specializers)
(slot-ref gf 'n-specialized))))
(%invalidate-method-cache! gf)
(invalidate-method-cache! gf)
(add-method-in-classes! m)
*unspecified*))
@ -917,6 +925,7 @@
(slot-set! val2
'extended-by
(cons gf (delq! gf (slot-ref val2 'extended-by))))
(invalidate-method-cache! gf)
var)))
(module-define! duplicate-handlers 'merge-generics merge-generics)
@ -1100,7 +1109,7 @@
;; remove the method from its GF
(slot-set! gf 'methods
(delq1! m (slot-ref gf 'methods)))
(%invalidate-method-cache! gf)
(invalidate-method-cache! gf)
;; remove the method from its specializers
(remove-method-in-classes! m))))
(class-direct-methods c)))

8
module/oop/goops/simple.scm
View file

@ -1,6 +1,6 @@
;;; installed-scm-file
;;;; Copyright (C) 2005, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2005, 2006, 2010, 2011 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,10 +23,8 @@
:export (define-class)
:no-backtrace)
(define-syntax define-class
(syntax-rules ()
((_ arg ...)
(define-class-with-accessors-keywords arg ...))))
(define-syntax-rule (define-class arg ...)
(define-class-with-accessors-keywords arg ...))
(module-use! (module-public-interface (current-module))
(resolve-interface '(oop goops)))

8
module/oop/goops/stklos.scm
View file

@ -1,4 +1,4 @@
;;;; Copyright (C) 1999,2002, 2006, 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 1999,2002, 2006, 2010, 2011 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
@ -47,10 +47,8 @@
;;; Enable keyword support (*fixme*---currently this has global effect)
(read-set! keywords 'prefix)
(define-syntax define-class
(syntax-rules ()
((_ name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))))
(define-syntax-rule (define-class name supers (slot ...) rest ...)
(standard-define-class name supers slot ... rest ...))
(define (toplevel-define! name val)
(module-define! (current-module) name val))

8
module/srfi/srfi-1.scm
View file

@ -240,11 +240,9 @@ higher-order procedures."
(scm-error 'wrong-type-arg (symbol->string caller)
"Wrong type argument: ~S" (list arg) '()))
(define-syntax check-arg
(syntax-rules ()
((_ pred arg caller)
(if (not (pred arg))
(wrong-type-arg 'caller arg)))))
(define-syntax-rule (check-arg pred arg caller)
(if (not (pred arg))
(wrong-type-arg 'caller arg)))
(define (out-of-range proc arg)
(scm-error 'out-of-range proc

30
module/srfi/srfi-35.scm
View file

@ -1,6 +1,6 @@
;;; srfi-35.scm --- Conditions -*- coding: utf-8 -*-
;; Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;; Copyright (C) 2007, 2008, 2009, 2010, 2011 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
@ -295,24 +295,20 @@ by C."
;;; Syntax.
;;;
(define-syntax define-condition-type
(syntax-rules ()
((_ name parent pred (field-name field-accessor) ...)
(begin
(define name
(make-condition-type 'name parent '(field-name ...)))
(define (pred c)
(condition-has-type? c name))
(define (field-accessor c)
(condition-ref c 'field-name))
...))))
(define-syntax-rule (define-condition-type name parent pred (field-name field-accessor) ...)
(begin
(define name
(make-condition-type 'name parent '(field-name ...)))
(define (pred c)
(condition-has-type? c name))
(define (field-accessor c)
(condition-ref c 'field-name))
...))
(define-syntax compound-condition
(define-syntax-rule (compound-condition (type ...) (field ...))
;; Create a compound condition using `make-compound-condition-type'.
(syntax-rules ()
((_ (type ...) (field ...))
(condition ((make-compound-condition-type '%compound `(,type ...))
field ...)))))
(condition ((make-compound-condition-type '%compound `(,type ...))
field ...)))
(define-syntax condition-instantiation
;; Build the `(make-condition type ...)' call.

12
module/srfi/srfi-39.scm
View file

@ -1,6 +1,6 @@
;;; srfi-39.scm --- Parameter objects
;; Copyright (C) 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
;; Copyright (C) 2004, 2005, 2006, 2008, 2011 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
@ -69,12 +69,10 @@
((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
(else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
(define-syntax parameterize
(syntax-rules ()
((_ ((?param ?value) ...) ?body ...)
(with-parameters* (list ?param ...)
(list ?value ...)
(lambda () ?body ...)))))
(define-syntax-rule (parameterize ((?param ?value) ...) ?body ...)
(with-parameters* (list ?param ...)
(list ?value ...)
(lambda () ?body ...)))
(define (current-input-port . new-value)
(if (null? new-value)

13
module/srfi/srfi-45.scm
View file

@ -1,6 +1,6 @@
;;; srfi-45.scm -- Primitives for Expressing Iterative Lazy Algorithms
;; Copyright (C) 2010 Free Software Foundation, Inc.
;; Copyright (C) 2010, 2011 Free Software Foundation, Inc.
;; Copyright (C) 2003 André van Tonder. All Rights Reserved.
;; Permission is hereby granted, free of charge, to any person
@ -47,17 +47,14 @@
(tag value-tag value-tag-set!)
(proc value-proc value-proc-set!))
(define-syntax lazy
(syntax-rules ()
((lazy exp)
(make-promise (make-value 'lazy (lambda () exp))))))
(define-syntax-rule (lazy exp)
(make-promise (make-value 'lazy (lambda () exp))))
(define (eager x)
(make-promise (make-value 'eager x)))
(define-syntax delay
(syntax-rules ()
((delay exp) (lazy (eager exp)))))
(define-syntax-rule (delay exp)
(lazy (eager exp)))
(define (force promise)
(let ((content (promise-val promise)))

189
module/srfi/srfi-67/compare.scm
View file

@ -1,3 +1,4 @@
; Copyright (c) 2011 Free Software Foundation, Inc.
; Copyright (c) 2005 Sebastian Egner and Jens Axel S{\o}gaard.
;
; Permission is hereby granted, free of charge, to any person obtaining
@ -88,14 +89,12 @@
; 3-sided conditional
(define-syntax if3
(syntax-rules ()
((if3 c less equal greater)
(case c
((-1) less)
(( 0) equal)
(( 1) greater)
(else (error "comparison value not in {-1,0,1}"))))))
(define-syntax-rule (if3 c less equal greater)
(case c
((-1) less)
(( 0) equal)
(( 1) greater)
(else (error "comparison value not in {-1,0,1}"))))
; 2-sided conditionals for comparisons
@ -110,51 +109,37 @@
(a-cases alternate)
(else (error "comparison value not in {-1,0,1}"))))))
(define-syntax if=?
(syntax-rules ()
((if=? arg ...)
(compare:if-rel? (0) (-1 1) arg ...))))
(define-syntax-rule (if=? arg ...)
(compare:if-rel? (0) (-1 1) arg ...))
(define-syntax if<?
(syntax-rules ()
((if<? arg ...)
(compare:if-rel? (-1) (0 1) arg ...))))
(define-syntax-rule (if<? arg ...)
(compare:if-rel? (-1) (0 1) arg ...))
(define-syntax if>?
(syntax-rules ()
((if>? arg ...)
(compare:if-rel? (1) (-1 0) arg ...))))
(define-syntax-rule (if>? arg ...)
(compare:if-rel? (1) (-1 0) arg ...))
(define-syntax if<=?
(syntax-rules ()
((if<=? arg ...)
(compare:if-rel? (-1 0) (1) arg ...))))
(define-syntax-rule (if<=? arg ...)
(compare:if-rel? (-1 0) (1) arg ...))
(define-syntax if>=?
(syntax-rules ()
((if>=? arg ...)
(compare:if-rel? (0 1) (-1) arg ...))))
(define-syntax-rule (if>=? arg ...)
(compare:if-rel? (0 1) (-1) arg ...))
(define-syntax if-not=?
(syntax-rules ()
((if-not=? arg ...)
(compare:if-rel? (-1 1) (0) arg ...))))
(define-syntax-rule (if-not=? arg ...)
(compare:if-rel? (-1 1) (0) arg ...))
; predicates from compare procedures
(define-syntax compare:define-rel?
(syntax-rules ()
((compare:define-rel? rel? if-rel?)
(define rel?
(case-lambda
(() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
((x y) (if-rel? (default-compare x y) #t #f))
((compare x y)
(if (procedure? compare)
(if-rel? (compare x y) #t #f)
(error "not a procedure (Did you mean rel/rel??): " compare))))))))
(define-syntax-rule (compare:define-rel? rel? if-rel?)
(define rel?
(case-lambda
(() (lambda (x y) (if-rel? (default-compare x y) #t #f)))
((compare) (lambda (x y) (if-rel? (compare x y) #t #f)))
((x y) (if-rel? (default-compare x y) #t #f))
((compare x y)
(if (procedure? compare)
(if-rel? (compare x y) #t #f)
(error "not a procedure (Did you mean rel/rel??): " compare))))))
(compare:define-rel? =? if=?)
(compare:define-rel? <? if<?)
@ -166,29 +151,27 @@
; chains of length 3
(define-syntax compare:define-rel1/rel2?
(syntax-rules ()
((compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
(define rel1/rel2?
(case-lambda
(()
(lambda (x y z)
(if-rel1? (default-compare x y)
(if-rel2? (default-compare y z) #t #f)
(compare:checked #f default-compare z))))
((compare)
(lambda (x y z)
(if-rel1? (compare x y)
(if-rel2? (compare y z) #t #f)
(compare:checked #f compare z))))
((x y z)
(if-rel1? (default-compare x y)
(if-rel2? (default-compare y z) #t #f)
(compare:checked #f default-compare z)))
((compare x y z)
(if-rel1? (compare x y)
(if-rel2? (compare y z) #t #f)
(compare:checked #f compare z))))))))
(define-syntax-rule (compare:define-rel1/rel2? rel1/rel2? if-rel1? if-rel2?)
(define rel1/rel2?
(case-lambda
(()
(lambda (x y z)
(if-rel1? (default-compare x y)
(if-rel2? (default-compare y z) #t #f)
(compare:checked #f default-compare z))))
((compare)
(lambda (x y z)
(if-rel1? (compare x y)
(if-rel2? (compare y z) #t #f)
(compare:checked #f compare z))))
((x y z)
(if-rel1? (default-compare x y)
(if-rel2? (default-compare y z) #t #f)
(compare:checked #f default-compare z)))
((compare x y z)
(if-rel1? (compare x y)
(if-rel2? (compare y z) #t #f)
(compare:checked #f compare z))))))
(compare:define-rel1/rel2? </<? if<? if<?)
(compare:define-rel1/rel2? </<=? if<? if<=?)
@ -202,31 +185,29 @@
; chains of arbitrary length
(define-syntax compare:define-chain-rel?
(syntax-rules ()
((compare:define-chain-rel? chain-rel? if-rel?)
(define chain-rel?
(case-lambda
((compare)
#t)
((compare x1)
(compare:checked #t compare x1))
((compare x1 x2)
(if-rel? (compare x1 x2) #t #f))
((compare x1 x2 x3)
(if-rel? (compare x1 x2)
(if-rel? (compare x2 x3) #t #f)
(compare:checked #f compare x3)))
((compare x1 x2 . x3+)
(if-rel? (compare x1 x2)
(let chain? ((head x2) (tail x3+))
(if (null? tail)
#t
(if-rel? (compare head (car tail))
(chain? (car tail) (cdr tail))
(apply compare:checked #f
compare (cdr tail)))))
(apply compare:checked #f compare x3+))))))))
(define-syntax-rule (compare:define-chain-rel? chain-rel? if-rel?)
(define chain-rel?
(case-lambda
((compare)
#t)
((compare x1)
(compare:checked #t compare x1))
((compare x1 x2)
(if-rel? (compare x1 x2) #t #f))
((compare x1 x2 x3)
(if-rel? (compare x1 x2)
(if-rel? (compare x2 x3) #t #f)
(compare:checked #f compare x3)))
((compare x1 x2 . x3+)
(if-rel? (compare x1 x2)
(let chain? ((head x2) (tail x3+))
(if (null? tail)
#t
(if-rel? (compare head (car tail))
(chain? (car tail) (cdr tail))
(apply compare:checked #f
compare (cdr tail)))))
(apply compare:checked #f compare x3+))))))
(compare:define-chain-rel? chain=? if=?)
(compare:define-chain-rel? chain<? if<?)
@ -468,19 +449,17 @@
(begin (compare:type-check type? type-name x)
(compare:type-check type? type-name y)))))
(define-syntax compare:define-by=/<
(syntax-rules ()
((compare:define-by=/< compare = < type? type-name)
(define compare
(let ((= =) (< <))
(lambda (x y)
(if (type? x)
(if (eq? x y)
0
(if (type? y)
(if (= x y) 0 (if (< x y) -1 1))
(error (string-append "not " type-name ":") y)))
(error (string-append "not " type-name ":") x))))))))
(define-syntax-rule (compare:define-by=/< compare = < type? type-name)
(define compare
(let ((= =) (< <))
(lambda (x y)
(if (type? x)
(if (eq? x y)
0
(if (type? y)
(if (= x y) 0 (if (< x y) -1 1))
(error (string-append "not " type-name ":") y)))
(error (string-append "not " type-name ":") x))))))
(define (boolean-compare x y)
(compare:type-check boolean? "boolean" x y)

37
module/sxml/match.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2010, 2011 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 as published by
@ -40,34 +40,27 @@
;;; PLT compatibility layer.
;;;
(define-syntax syntax-object->datum
(syntax-rules ()
((_ stx)
(syntax->datum stx))))
(define-syntax-rule (syntax-object->datum stx)
(syntax->datum stx))
(define-syntax void
(syntax-rules ()
((_) *unspecified*)))
(define-syntax-rule (void)
*unspecified*)
(define %call/ec-prompt
(make-prompt-tag))
(define-syntax call/ec
(define-syntax-rule (call/ec proc)
;; aka. `call-with-escape-continuation'
(syntax-rules ()
((_ proc)
(call-with-prompt %call/ec-prompt
(lambda ()
(proc (lambda args
(apply abort-to-prompt
%call/ec-prompt args))))
(lambda (_ . args)
(apply values args))))))
(call-with-prompt %call/ec-prompt
(lambda ()
(proc (lambda args
(apply abort-to-prompt
%call/ec-prompt args))))
(lambda (_ . args)
(apply values args))))
(define-syntax let/ec
(syntax-rules ()
((_ cont body ...)
(call/ec (lambda (cont) body ...)))))
(define-syntax-rule (let/ec cont body ...)
(call/ec (lambda (cont) body ...)))
(define (raise-syntax-error x msg obj sub)
(throw 'sxml-match-error x msg obj sub))

6
module/system/repl/error-handling.scm
View file

@ -182,7 +182,5 @@
(apply (if (memq k pass-keys) throw on-error) k args))
(error "Unknown on-error strategy" on-error)))))))
(define-syntax with-error-handling
(syntax-rules ()
((_ form)
(call-with-error-handling (lambda () form)))))
(define-syntax-rule (with-error-handling form)
(call-with-error-handling (lambda () form)))

16
module/system/repl/repl.scm
View file

@ -135,15 +135,13 @@
(run-repl (make-repl lang debug)))
;; (put 'abort-on-error 'scheme-indent-function 1)
(define-syntax abort-on-error
(syntax-rules ()
((_ string exp)
(catch #t
(lambda () exp)
(lambda (key . args)
(format #t "While ~A:~%" string)
(print-exception (current-output-port) #f key args)
(abort))))))
(define-syntax-rule (abort-on-error string exp)
(catch #t
(lambda () exp)
(lambda (key . args)
(format #t "While ~A:~%" string)
(print-exception (current-output-port) #f key args)
(abort))))
(define (run-repl repl)
(define (with-stack-and-prompt thunk)

21
module/system/vm/inspect.scm
View file

@ -1,6 +1,6 @@
;;; Guile VM debugging facilities
;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;; Copyright (C) 2001, 2009, 2010, 2011 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
@ -81,16 +81,15 @@
;;;
(define (inspect x)
(define-syntax define-command
(syntax-rules ()
((_ ((mod cname alias ...) . args) body ...)
(define cname
(let ((c (lambda* args body ...)))
(set-procedure-property! c 'name 'cname)
(module-define! mod 'cname c)
(module-add! mod 'alias (module-local-variable mod 'cname))
...
c)))))
(define-syntax-rule (define-command ((mod cname alias ...) . args)
body ...)
(define cname
(let ((c (lambda* args body ...)))
(set-procedure-property! c 'name 'cname)
(module-define! mod 'cname c)
(module-add! mod 'alias (module-local-variable mod 'cname))
...
c)))
(let ((commands (make-module)))
(define (prompt)

20
module/texinfo.scm
View file

@ -77,6 +77,7 @@
#:use-module (sxml transform)
#:use-module (sxml ssax input-parse)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-13)
#:export (call-with-file-and-dir
texi-command-specs
@ -103,25 +104,6 @@ files by relative path name."
(call-with-input-file (basename filename) proc))
(lambda () (chdir current-dir)))))
;; Define this version here, because (srfi srfi-11)'s definition uses
;; syntax-rules, which is really damn slow
(define-macro (let*-values bindings . body)
(if (null? bindings) (cons 'begin body)
(apply
(lambda (vars initializer)
(let ((cont
(cons 'let*-values
(cons (cdr bindings) body))))
(cond
((not (pair? vars)) ; regular let case, a single var
`(let ((,vars ,initializer)) ,cont))
((null? (cdr vars)) ; single var, see the prev case
`(let ((,(car vars) ,initializer)) ,cont))
(else ; the most generic case
`(call-with-values (lambda () ,initializer)
(lambda ,vars ,cont))))))
(car bindings))))
;;========================================================================
;; Reflection on the XML vocabulary

28
module/web/http.scm
View file

@ -702,15 +702,25 @@ ordered alist."
;; 0 1 2
(define (parse-rfc-822-date str)
;; We could verify the day of the week but we don't.
(if (not (string-match? str "aaa, dd aaa dddd dd:dd:dd GMT"))
(bad-header 'date str))
(let ((date (parse-non-negative-integer str 5 7))
(month (parse-month str 8 11))
(year (parse-non-negative-integer str 12 16))
(hour (parse-non-negative-integer str 17 19))
(minute (parse-non-negative-integer str 20 22))
(second (parse-non-negative-integer str 23 25)))
(make-date 0 second minute hour date month year 0)))
(cond ((string-match? str "aaa, dd aaa dddd dd:dd:dd GMT")
(let ((date (parse-non-negative-integer str 5 7))
(month (parse-month str 8 11))
(year (parse-non-negative-integer str 12 16))
(hour (parse-non-negative-integer str 17 19))
(minute (parse-non-negative-integer str 20 22))
(second (parse-non-negative-integer str 23 25)))
(make-date 0 second minute hour date month year 0)))
((string-match? str "aaa, d aaa dddd dd:dd:dd GMT")
(let ((date (parse-non-negative-integer str 5 6))
(month (parse-month str 7 10))
(year (parse-non-negative-integer str 11 15))
(hour (parse-non-negative-integer str 16 18))
(minute (parse-non-negative-integer str 19 21))
(second (parse-non-negative-integer str 22 24)))
(make-date 0 second minute hour date month year 0)))
(else
(bad-header 'date str) ; prevent tail call
#f)))
;; RFC 850, updated by RFC 1036
;; Sunday, 06-Nov-94 08:49:37 GMT

8
module/web/server.scm
View file

@ -118,11 +118,9 @@
(write server-impl-write)
(close server-impl-close))
(define-syntax define-server-impl
(syntax-rules ()
((_ name open read write close)
(define name
(make-server-impl 'name open read write close)))))
(define-syntax-rule (define-server-impl name open read write close)
(define name
(make-server-impl 'name open read write close)))
(define (lookup-server-impl impl)
"Look up a server implementation. If @var{impl} is a server

1
test-suite/Makefile.am
View file

@ -67,6 +67,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/list.test \
tests/load.test \
tests/match.test \
tests/match.test.upstream \
tests/modules.test \
tests/multilingual.nottest \
tests/net-db.test \

7
test-suite/standalone/Makefile.am
View file

@ -178,6 +178,13 @@ test_scm_take_u8vector_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-scm-take-u8vector
TESTS += test-scm-take-u8vector
# test-scm-take-u8vector
test_scm_to_latin1_string_SOURCES = test-scm-to-latin1-string.c
test_scm_to_latin1_string_CFLAGS = ${test_cflags}
test_scm_to_latin1_string_LDADD = $(LIBGUILE_LDADD)
check_PROGRAMS += test-scm-to-latin1-string
TESTS += test-scm-to-latin1-string
if HAVE_SHARED_LIBRARIES
# test-extensions

78
test-suite/standalone/test-scm-to-latin1-string.c Normal file
View file

@ -0,0 +1,78 @@
/* Copyright (C) 2011 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
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif
#include <libguile.h>
#include <stdlib.h>
/*
This outputs:
dhansen@localhorst ~/tmp $ ./a.out
foo,bar
bar
*/
#define TEST(x) \
if (!(x)) abort()
static void
inner_main (void *data, int argc, char **argv)
{
char *cstr;
SCM string, tokens, tok;
string = scm_from_latin1_string ("foo,bar");
tokens = scm_string_split (string, SCM_MAKE_CHAR (','));
TEST (scm_is_pair (tokens));
tok = scm_car (tokens);
TEST (scm_is_string (tok));
cstr = scm_to_latin1_string (tok);
TEST (strcmp (cstr, "foo") == 0);
free (cstr);
tokens = scm_cdr (tokens);
TEST (scm_is_pair (tokens));
tok = scm_car (tokens);
TEST (scm_is_string (tok));
cstr = scm_to_latin1_string (tok);
TEST (strcmp (cstr, "bar") == 0);
free (cstr);
tokens = scm_cdr (tokens);
TEST (scm_is_null (tokens));
}
int
main (int argc, char **argv)
{
scm_boot_guile (argc, argv, inner_main, NULL);
return EXIT_SUCCESS;
}
/* Local Variables: */
/* compile-command: "gcc `pkg-config --cflags --libs guile-2.0` main.c" */
/* End: */

14
test-suite/tests/gc.test
View file

@ -1,5 +1,6 @@
;;;; gc.test --- test guile's garbage collection -*- scheme -*-
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;;;; Copyright (C) 2000, 2001, 2004, 2006, 2007, 2008, 2009,
;;;; 2011 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
@ -46,6 +47,13 @@
;;;
;;;
(define (stack-cleanup depth)
;; Clean up stack space for DEPTH words. This is defined here so that
;; `peval' doesn't inline it.
(let cleanup ((i depth))
(and (> i 0)
(begin (cleanup (1- i)) i))))
(with-test-prefix "gc"
(pass-if "after-gc-hook gets called"
@ -65,9 +73,7 @@
(for-each (lambda (x) (guard (make-module))) (iota total))
;; Avoid false references to the modules on the stack.
(let cleanup ((i 20))
(and (> i 0)
(begin (cleanup (1- i)) i)))
(stack-cleanup 20)
(gc)
(gc) ;; twice: have to kill the weak vectors.

106
test-suite/tests/match.test
View file

@ -1,6 +1,6 @@
;;;; match.test --- (ice-9 match) -*- mode: scheme; coding: utf-8; -*-
;;;;
;;;; Copyright (C) 2010 Free Software Foundation, Inc.
;;;; Copyright (C) 2010, 2011 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
@ -18,11 +18,25 @@
(define-module (test-match)
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (test-suite lib))
(define exception:match-error
(cons 'match-error "^.*$"))
(define-record-type rtd-2-slots
(make-2-slot-record a b)
two-slot-record?
(a slot-first)
(b slot-second))
(define-record-type rtd-3-slots
(make-3-slot-record a b c)
three-slot-record?
(a slot-one)
(b slot-two)
(c slot-three))
(with-test-prefix "matches"
@ -86,7 +100,61 @@
(let ((tree '(one (two 2) (three 3 (and 4 (and 5))))))
(match tree
(('one ('two x) ('three y ('and z '(and 5))))
(equal? (list x y z) '(2 3 4)))))))
(equal? (list x y z) '(2 3 4))))))
(pass-if "and, unique names"
(let ((tree '(1 2)))
(match tree
((and (a 2) (1 b))
(equal? 3 (+ a b))))))
(pass-if "and, same names"
(let ((a '(1 2)))
(match a
((and (a 2) (1 b))
(equal? 3 (+ a b))))))
(with-test-prefix "records"
(pass-if "all slots, bind"
(let ((r (make-3-slot-record 1 2 3)))
(match r
(($ rtd-3-slots a b c)
(equal? (list a b c) '(1 2 3))))))
(pass-if "all slots, literals"
(let ((r (make-3-slot-record 1 2 3)))
(match r
(($ rtd-3-slots 1 2 3)
#t))))
(pass-if "2 slots"
(let ((r (make-3-slot-record 1 2 3)))
(match r
(($ rtd-3-slots x y)
(equal? (list x y) '(1 2))))))
(pass-if "RTD correctly checked"
(let ((r (make-2-slot-record 1 2)))
(match r
(($ rtd-3-slots a b)
#f)
(($ rtd-2-slots a b)
(equal? (list a b) '(1 2))))))
(pass-if "getter"
(match (make-2-slot-record 1 2)
(($ rtd-2-slots (get! first) (get! second))
(equal? (list (first) (second)) '(1 2)))))
(pass-if "setter"
(let ((r (make-2-slot-record 1 2)))
(match r
(($ rtd-2-slots (set! set-first!) (set! set-second!))
(set-first! 'one)
(set-second! 'two)
(equal? (list (slot-first r) (slot-second r))
'(one two))))))))
(with-test-prefix "doesn't match"
@ -105,4 +173,36 @@
exception:match-error
(match '(a 0)
(((and x (? symbol?)) ..1)
(equal? x '(a b c))))))
(equal? x '(a b c)))))
(with-test-prefix "records"
(pass-if "not a record"
(match "hello"
(($ rtd-2-slots) #f)
(_ #t)))
(pass-if-exception "too many slots"
exception:out-of-range
(let ((r (make-3-slot-record 1 2 3)))
(match r
(($ rtd-3-slots a b c d)
#f))))))
;;;
;;; Upstream tests, from Chibi-Scheme (3-clause BSD license).
;;;
(let-syntax ((load (syntax-rules ()
((_ file) #t)))
(test (syntax-rules ()
((_ name expected expr)
(pass-if name
(equal? expected expr)))))
(test-begin (syntax-rules ()
((_ name) #t)))
(test-end (syntax-rules ()
((_) #t))))
(with-test-prefix "upstream tests"
(include-from-path "test-suite/tests/match.test.upstream")))

168
test-suite/tests/match.test.upstream Normal file
View file

@ -0,0 +1,168 @@
(cond-expand
(modules (import (chibi match) (only (chibi test) test-begin test test-end)))
(else (load "lib/chibi/match/match.scm")))
(test-begin "match")
(test "any" 'ok (match 'any (_ 'ok)))
(test "symbol" 'ok (match 'ok (x x)))
(test "number" 'ok (match 28 (28 'ok)))
(test "string" 'ok (match "good" ("bad" 'fail) ("good" 'ok)))
(test "literal symbol" 'ok (match 'good ('bad 'fail) ('good 'ok)))
(test "null" 'ok (match '() (() 'ok)))
(test "pair" 'ok (match '(ok) ((x) x)))
(test "vector" 'ok (match '#(ok) (#(x) x)))
(test "any doubled" 'ok (match '(1 2) ((_ _) 'ok)))
(test "and empty" 'ok (match '(o k) ((and) 'ok)))
(test "and single" 'ok (match 'ok ((and x) x)))
(test "and double" 'ok (match 'ok ((and (? symbol?) y) 'ok)))
(test "or empty" 'ok (match '(o k) ((or) 'fail) (else 'ok)))
(test "or single" 'ok (match 'ok ((or x) 'ok)))
(test "or double" 'ok (match 'ok ((or (? symbol? y) y) y)))
(test "not" 'ok (match 28 ((not (a . b)) 'ok)))
(test "pred" 'ok (match 28 ((? number?) 'ok)))
(test "named pred" 29 (match 28 ((? number? x) (+ x 1))))
(test "duplicate symbols pass" 'ok (match '(ok . ok) ((x . x) x)))
(test "duplicate symbols fail" 'ok (match '(ok . bad) ((x . x) 'bad) (else 'ok)))
(test "duplicate symbols samth" 'ok (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)))
(test "ellipses" '((a b c) (1 2 3))
(match '((a . 1) (b . 2) (c . 3))
(((x . y) ___) (list x y))))
(test "real ellipses" '((a b c) (1 2 3))
(match '((a . 1) (b . 2) (c . 3))
(((x . y) ...) (list x y))))
(test "vector ellipses" '(1 2 3 (a b c) (1 2 3))
(match '#(1 2 3 (a . 1) (b . 2) (c . 3))
(#(a b c (hd . tl) ...) (list a b c hd tl))))
(test "pred ellipses" '(1 2 3)
(match '(1 2 3)
(((? odd? n) ___) n)
(((? number? n) ___) n)))
(test "failure continuation" 'ok
(match '(1 2)
((a . b) (=> next) (if (even? a) 'fail (next)))
((a . b) 'ok)))
(test "let" '(o k)
(match-let ((x 'ok) (y '(o k))) y))
(test "let*" '(f o o f)
(match-let* ((x 'f) (y 'o) ((z w) (list y x))) (list x y z w)))
(test "getter car" '(1 2)
(match '(1 . 2) (((get! a) . b) (list (a) b))))
(test "getter cdr" '(1 2)
(match '(1 . 2) ((a . (get! b)) (list a (b)))))
(test "getter vector" '(1 2 3)
(match '#(1 2 3) (#((get! a) b c) (list (a) b c))))
(test "setter car" '(3 . 2)
(let ((x (cons 1 2)))
(match x (((set! a) . b) (a 3)))
x))
(test "setter cdr" '(1 . 3)
(let ((x (cons 1 2)))
(match x ((a . (set! b)) (b 3)))
x))
(test "setter vector" '#(1 0 3)
(let ((x (vector 1 2 3)))
(match x (#(a (set! b) c) (b 0)))
x))
(test "single tail" '((a b) (1 2) (c . 3))
(match '((a . 1) (b . 2) (c . 3))
(((x . y) ... last) (list x y last))))
(test "single tail 2" '((a b) (1 2) 3)
(match '((a . 1) (b . 2) 3)
(((x . y) ... last) (list x y last))))
(test "multiple tail" '((a b) (1 2) (c . 3) (d . 4) (e . 5))
(match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
(((x . y) ... u v w) (list x y u v w))))
(test "tail against improper list" #f
(match '(a b c d e f . g)
((x ... y u v w) (list x y u v w))
(else #f)))
(test "Riastradh quasiquote" '(2 3)
(match '(1 2 3) (`(1 ,b ,c) (list b c))))
(test "trivial tree search" '(1 2 3)
(match '(1 2 3) ((_ *** (a b c)) (list a b c))))
(test "simple tree search" '(1 2 3)
(match '(x (1 2 3)) ((_ *** (a b c)) (list a b c))))
(test "deep tree search" '(1 2 3)
(match '(x (x (x (1 2 3)))) ((_ *** (a b c)) (list a b c))))
(test "non-tail tree search" '(1 2 3)
(match '(x (x (x a b c (1 2 3) d e f))) ((_ *** (a b c)) (list a b c))))
(test "restricted tree search" '(1 2 3)
(match '(x (x (x a b c (1 2 3) d e f))) (('x *** (a b c)) (list a b c))))
(test "fail restricted tree search" #f
(match '(x (y (x a b c (1 2 3) d e f)))
(('x *** (a b c)) (list a b c))
(else #f)))
(test "sxml tree search" '(((href . "http://synthcode.com/")) ("synthcode"))
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(else #f)))
(test "failed sxml tree search" #f
(match '(p (ol (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((or 'p 'ul 'li 'b) *** ('a ('^ attrs ...) text ...))
(list attrs text))
(else #f)))
(test "collect tree search"
'((p ul li) ((href . "http://synthcode.com/")) ("synthcode"))
(match '(p (ul (li a (b c) (a (^ (href . "http://synthcode.com/")) "synthcode") d e f)))
(((and tag (or 'p 'ul 'li 'b)) *** ('a ('^ attrs ...) text ...))
(list tag attrs text))
(else #f)))
(test "anded tail pattern" '(1 2)
(match '(1 2 3) ((and (a ... b) x) a)))
(test "anded search pattern" '(a b c)
(match '(a (b (c d))) ((and (p *** 'd) x) p)))
(test "joined tail" '(1 2)
(match '(1 2 3) ((and (a ... b) x) a)))
(test "list ..1" '(a b c)
(match '(a b c) ((x ..1) x)))
(test "list ..1 failed" #f
(match '()
((x ..1) x)
(else #f)))
(test "list ..1 with predicate" '(a b c)
(match '(a b c)
(((and x (? symbol?)) ..1) x)))
(test "list ..1 with failed predicate" #f
(match '(a b 3)
(((and x (? symbol?)) ..1) x)
(else #f)))
(test-end)

11
test-suite/tests/statprof.test
View file

@ -40,8 +40,11 @@
;; make sure these are compiled so we're not swamped in `eval'
(define (make-func)
;; Disable partial evaluation so that `(+ i i)' doesn't get
;; stripped.
(compile '(lambda (n)
(do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))))
(do ((i 0 (+ i 1))) ((= 200 i)) (+ i i)))
#:opts '(#:partial-eval? #f)))
(define run-test
(compile '(lambda (num-calls funcs)
(let loop ((x num-calls) (funcs funcs))
@ -50,11 +53,11 @@
((car funcs) x)
(loop (- x 1) (cdr funcs))))))))
(let ((num-calls 40000)
(let ((num-calls 80000)
(funcs (circular-list (make-func) (make-func) (make-func))))
;; Run test. 10000 us == 100 Hz.
(statprof-reset 0 10000 #f #f)
;; Run test. 20000 us == 200 Hz.
(statprof-reset 0 20000 #f #f)
(statprof-start)
(run-test num-calls funcs)
(statprof-stop)

11
test-suite/tests/threads.test
View file

@ -36,6 +36,13 @@
(equal? '(a b c) '(a b c))
a))
(define (stack-cleanup depth)
;; Clean up stack space for DEPTH words. This is defined here so that
;; `peval' doesn't inline it.
(let cleanup ((i depth))
(and (> i 0)
(begin (cleanup (1- i)) i))))
(if (provided? 'threads)
(begin
@ -403,9 +410,7 @@
(g (let ((m (make-mutex))) (lock-mutex m) m))
;; Avoid false references to M on the stack.
(let cleanup ((i 20))
(and (> i 0)
(begin (cleanup (1- i)) i)))
(stack-cleanup 20)
(gc) (gc)
(let ((m (g)))

779
test-suite/tests/tree-il.test
View file

@ -23,6 +23,7 @@
#:use-module (system base pmatch)
#:use-module (system base message)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
#:use-module (language glil)
#:use-module (srfi srfi-13))
@ -34,26 +35,28 @@
(post-order! (lambda (x) (set! (tree-il-src x) #f))
x))
(define-syntax assert-scheme->glil
(syntax-rules ()
((_ in out)
(let ((tree-il (strip-source
(compile 'in #:from 'scheme #:to 'tree-il))))
(pass-if 'in
(equal? (unparse-glil (compile tree-il #:from 'tree-il #:to 'glil))
'out))))))
(define-syntax assert-tree-il->glil
(syntax-rules ()
((_ in pat test ...)
(syntax-rules (with-partial-evaluation without-partial-evaluation
with-options)
((_ with-partial-evaluation in pat test ...)
(assert-tree-il->glil with-options (#:partial-eval? #t)
in pat test ...))
((_ without-partial-evaluation in pat test ...)
(assert-tree-il->glil with-options (#:partial-eval? #f)
in pat test ...))
((_ with-options opts in pat test ...)
(let ((exp 'in))
(pass-if 'in
(let ((glil (unparse-glil
(compile (strip-source (parse-tree-il exp))
#:from 'tree-il #:to 'glil))))
#:from 'tree-il #:to 'glil
#:opts 'opts))))
(pmatch glil
(pat (guard test ...) #t)
(else #f))))))))
(else #f))))))
((_ in pat test ...)
(assert-tree-il->glil with-partial-evaluation
in pat test ...))))
(define-syntax pass-if-tree-il->scheme
(syntax-rules ()
@ -66,6 +69,39 @@
(pat (guard guard-exp) #t)
(_ #f))))))
(define peval
;; The partial evaluator.
(@@ (language tree-il optimize) peval))
(define-syntax pass-if-peval
(syntax-rules (resolve-primitives)
((_ in pat)
(pass-if-peval in pat
(compile 'in #:from 'scheme #:to 'tree-il)))
((_ resolve-primitives in pat)
(pass-if-peval in pat
(expand-primitives!
(resolve-primitives!
(compile 'in #:from 'scheme #:to 'tree-il)
(current-module)))))
((_ in pat code)
(pass-if 'in
(let ((evaled (unparse-tree-il (peval code))))
(pmatch evaled
(pat #t)
(_ (pk 'peval-mismatch)
((@ (ice-9 pretty-print) pretty-print)
'in)
(newline)
((@ (ice-9 pretty-print) pretty-print)
evaled)
(newline)
((@ (ice-9 pretty-print) pretty-print)
'pat)
(newline)
#f)))))))
(with-test-prefix "tree-il->scheme"
(pass-if-tree-il->scheme
(case-lambda ((a) a) ((b c) (list b c)))
@ -107,8 +143,8 @@
(const 1) (call return 1)
(label ,l2) (const 2) (call return 1))
(eq? l1 l2))
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(begin (if (toplevel foo) (const 1) (const 2)) (const #f))
(program () (std-prelude 0 0 #f) (label _) (toplevel ref foo) (branch br-if-not ,l1) (branch br ,l2)
(label ,l3) (label ,l4) (const #f) (call return 1))
@ -137,21 +173,21 @@
(call return 1))))
(with-test-prefix "lexical refs"
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (lexical x y))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(lexical #t #f ref 0) (call return 1)
(unbind)))
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (begin (lexical x y) (const #f)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
(const #f) (call return 1)
(unbind)))
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1)) (primcall null? (lexical x y)))
(program () (std-prelude 0 1 #f) (label _)
(const 1) (bind (x #f 0)) (lexical #t #f set 0)
@ -270,7 +306,7 @@
(toplevel ref bar)
(call return 1)))
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(begin (toplevel bar) (const #f))
(program () (std-prelude 0 0 #f) (label _)
(toplevel ref bar) (call drop 1)
@ -332,13 +368,14 @@
(const #f) (call return 1)))
(assert-tree-il->glil
;; This gets simplified by `peval'.
(primcall null? (const 2))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(const #f) (call return 1))))
(with-test-prefix "letrec"
;; simple bindings -> let
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((const 10) (const 20))
(call (toplevel foo) (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
@ -351,7 +388,7 @@
(unbind)))
;; complex bindings -> box and set! within let
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(letrec (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 4 #f) (label _)
@ -367,7 +404,7 @@
(call add 2) (call return 1) (unbind)))
;; complex bindings in letrec* -> box and set! in order
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(letrec* (x y) (x1 y1) ((call (toplevel foo)) (call (toplevel bar)))
(primcall + (lexical x x1) (lexical y y1)))
(program () (std-prelude 0 2 #f) (label _)
@ -383,7 +420,7 @@
(call add 2) (call return 1) (unbind)))
;; simple bindings in letrec* -> equivalent to letrec
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(letrec* (x y) (xx yy) ((const 1) (const 2))
(lexical y yy))
(program () (std-prelude 0 1 #f) (label _)
@ -487,9 +524,10 @@
(const #t) (call return 1)))
(assert-tree-il->glil
;; This gets simplified by `peval'.
(primcall null? (begin (const #f) (const 2)))
(program () (std-prelude 0 0 #f) (label _)
(const 2) (call null? 1) (call return 1))))
(const #f) (call return 1))))
(with-test-prefix "values"
(assert-tree-il->glil
@ -514,7 +552,7 @@
;; FIXME: binding info for or-hacked locals might bork the disassembler,
;; and could be tightened in any case
(with-test-prefix "the or hack"
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
@ -532,7 +570,7 @@
(eq? l1 l2))
;; second bound var is unreferenced
(assert-tree-il->glil
(assert-tree-il->glil without-partial-evaluation
(let (x) (y) ((const 1))
(if (lexical x y)
(lexical x y)
@ -586,6 +624,693 @@
(toplevel ref bar) (call call/cc 1)
(call tail-call 1))))
(with-test-prefix "partial evaluation"
(pass-if-peval
;; First order, primitive.
(let ((x 1) (y 2)) (+ x y))
(const 3))
(pass-if-peval
;; First order, thunk.
(let ((x 1) (y 2))
(let ((f (lambda () (+ x y))))
(f)))
(const 3))
(pass-if-peval resolve-primitives
;; First order, let-values (requires primitive expansion for
;; `call-with-values'.)
(let ((x 0))
(call-with-values
(lambda () (if (zero? x) (values 1 2) (values 3 4)))
(lambda (a b)
(+ a b))))
(const 3))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
(primcall list
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, mutability preserved.
(cons 0 (cons 1 (cons 2 (list 3 4 5))))
;; This must not be a constant.
(primcall list
(const 0) (const 1) (const 2) (const 3) (const 4) (const 5)))
(pass-if-peval
;; First order, coalesced, immutability preserved.
(cons 0 (cons 1 (cons 2 '(3 4 5))))
(primcall cons (const 0)
(primcall cons (const 1)
(primcall cons (const 2)
(const (3 4 5))))))
;; These two tests doesn't work any more because we changed the way we
;; deal with constants -- now the algorithm will see a construction as
;; being bound to the lexical, so it won't propagate it. It can't
;; even propagate it in the case that it is only referenced once,
;; because:
;;
;; (let ((x (cons 1 2))) (lambda () x))
;;
;; is not the same as
;;
;; (lambda () (cons 1 2))
;;
;; Perhaps if we determined that not only was it only referenced once,
;; it was not closed over by a lambda, then we could propagate it, and
;; re-enable these two tests.
;;
#;
(pass-if-peval
;; First order, mutability preserved.
(let loop ((i 3) (r '()))
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
(primcall list
(primcall cons (const 1) (const 1))
(primcall cons (const 2) (const 2))
(primcall cons (const 3) (const 3))))
;;
;; See above.
#;
(pass-if-peval
;; First order, evaluated.
(let loop ((i 7)
(r '()))
(if (<= i 0)
(car r)
(loop (1- i) (cons i r))))
(const 1))
;; Instead here are tests for what happens for the above cases: they
;; unroll but they don't fold.
(pass-if-peval
(let loop ((i 3) (r '()))
(if (zero? i)
r
(loop (1- i) (cons (cons i i) r))))
(letrec (loop) (_) (_)
(let (r) (_)
((primcall list
(primcall cons (const 3) (const 3))))
(let (r) (_)
((primcall cons
(primcall cons (const 2) (const 2))
(lexical r _)))
(primcall cons
(primcall cons (const 1) (const 1))
(lexical r _))))))
;; See above.
(pass-if-peval
(let loop ((i 4)
(r '()))
(if (<= i 0)
(car r)
(loop (1- i) (cons i r))))
(letrec (loop) (_) (_)
(let (r) (_)
((primcall list (const 4)))
(let (r) (_)
((primcall cons
(const 3)
(lexical r _)))
(let (r) (_)
((primcall cons
(const 2)
(lexical r _)))
(let (r) (_)
((primcall cons
(const 1)
(lexical r _)))
(primcall car
(lexical r _))))))))
;; Static sums.
(pass-if-peval
(let loop ((l '(1 2 3 4)) (sum 0))
(if (null? l)
sum
(loop (cdr l) (+ sum (car l)))))
(const 10))
(pass-if-peval
;; Mutability preserved.
((lambda (x y z) (list x y z)) 1 2 3)
(primcall list (const 1) (const 2) (const 3)))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on mutable
;; objects.
(let* ((x (list 1))
(y (car x)))
(set-car! x 0)
y)
(let (x) (_) ((primcall list (const 1)))
(let (y) (_) ((primcall car (lexical x _)))
(seq
(call (toplevel set-car!) (lexical x _) (const 0))
(lexical y _)))))
(pass-if-peval
;; Don't propagate effect-free expressions that operate on objects we
;; don't know about.
(let ((y (car x)))
(set-car! x 0)
y)
(let (y) (_) ((primcall car (toplevel x)))
(seq
(call (toplevel set-car!) (toplevel x) (const 0))
(lexical y _))))
(pass-if-peval
;; Infinite recursion
((lambda (x) (x x)) (lambda (x) (x x)))
(let (x) (_)
((lambda _
(lambda-case
(((x) _ _ _ _ _)
(call (lexical x _) (lexical x _))))))
(call (lexical x _) (lexical x _))))
(pass-if-peval
;; First order, aliased primitive.
(let* ((x *) (y (x 1 2))) y)
(const 2))
(pass-if-peval
;; First order, shadowed primitive.
(begin
(define (+ x y) (pk x y))
(+ 1 2))
(seq
(define +
(lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
(call (toplevel pk) (lexical x _) (lexical y _))))))
(call (toplevel +) (const 1) (const 2))))
(pass-if-peval
;; First-order, effects preserved.
(let ((x 2))
(do-something!)
x)
(seq
(call (toplevel do-something!))
(const 2)))
(pass-if-peval
;; First order, residual bindings removed.
(let ((x 2) (y 3))
(* (+ x y) z))
(primcall * (const 5) (toplevel z)))
(pass-if-peval
;; First order, with lambda.
(define (foo x)
(define (bar z) (* z z))
(+ x (bar 3)))
(define foo
(lambda (_)
(lambda-case
(((x) #f #f #f () (_))
(primcall + (lexical x _) (const 9)))))))
(pass-if-peval
;; First order, with lambda inlined & specialized twice.
(let ((f (lambda (x y)
(+ (* x top) y)))
(x 2)
(y 3))
(+ (* x (f x y))
(f something x)))
(primcall +
(primcall *
(const 2)
(primcall + ; (f 2 3)
(primcall *
(const 2)
(toplevel top))
(const 3)))
(let (x) (_) ((toplevel something)) ; (f something 2)
;; `something' is not const, so preserve order of
;; effects with a lexical binding.
(primcall +
(primcall *
(lexical x _)
(toplevel top))
(const 2)))))
(pass-if-peval
;; First order, with lambda inlined & specialized 3 times.
(let ((f (lambda (x y) (if (> x 0) y x))))
(+ (f -1 0)
(f 1 0)
(f -1 y)
(f 2 y)
(f z y)))
(primcall +
(const -1) ; (f -1 0)
(const 0) ; (f 1 0)
(seq (toplevel y) (const -1)) ; (f -1 y)
(toplevel y) ; (f 2 y)
(let (x y) (_ _) ((toplevel z) (toplevel y)) ; (f z y)
(if (primcall > (lexical x _) (const 0))
(lexical y _)
(lexical x _)))))
(pass-if-peval
;; First order, conditional.
(let ((y 2))
(lambda (x)
(if (> y 0)
(display x)
'never-reached)))
(lambda ()
(lambda-case
(((x) #f #f #f () (_))
(call (toplevel display) (lexical x _))))))
(pass-if-peval
;; First order, recursive procedure.
(letrec ((fibo (lambda (n)
(if (<= n 1)
n
(+ (fibo (- n 1))
(fibo (- n 2)))))))
(fibo 4))
(const 3))
(pass-if-peval
;; Don't propagate toplevel references, as intervening expressions
;; could alter their bindings.
(let ((x top))
(foo)
x)
(let (x) (_) ((toplevel top))
(seq
(call (toplevel foo))
(lexical x _))))
(pass-if-peval
;; Higher order.
((lambda (f x)
(f (* (car x) (cadr x))))
(lambda (x)
(+ x 1))
'(2 3))
(const 7))
(pass-if-peval
;; Higher order with optional argument (default value).
((lambda* (f x #:optional (y 0))
(+ y (f (* (car x) (cadr x)))))
(lambda (x)
(+ x 1))
'(2 3))
(const 7))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
((lambda* (f x #:optional (y 0))
(+ y (f (* (car x) (cadr x)))))
(lambda (x)
(+ x 1))
'(2 3)
35)
(const 42))
(pass-if-peval
;; Higher order with optional argument (side-effecting default
;; value).
((lambda* (f x #:optional (y (foo)))
(+ y (f (* (car x) (cadr x)))))
(lambda (x)
(+ x 1))
'(2 3))
(let (y) (_) ((call (toplevel foo)))
(primcall + (lexical y _) (const 7))))
(pass-if-peval
;; Higher order with optional argument (caller-supplied value).
((lambda* (f x #:optional (y (foo)))
(+ y (f (* (car x) (cadr x)))))
(lambda (x)
(+ x 1))
'(2 3)
35)
(const 42))
(pass-if-peval
;; Higher order.
((lambda (f) (f x)) (lambda (x) x))
(toplevel x))
(pass-if-peval
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html>.
(let ((fold (lambda (f g) (f (g top)))))
(fold 1+ (lambda (x) x)))
(primcall 1+ (toplevel top)))
(pass-if-peval
;; Procedure not inlined when residual code contains recursive calls.
;; <http://debbugs.gnu.org/9542>
(letrec ((fold (lambda (f x3 b null? car cdr)
(if (null? x3)
b
(f (car x3) (fold f (cdr x3) b null? car cdr))))))
(fold * x 1 zero? (lambda (x1) x1) (lambda (x2) (- x2 1))))
(letrec (fold) (_) (_)
(call (lexical fold _)
(primitive *)
(toplevel x)
(const 1)
(primitive zero?)
(lambda ()
(lambda-case
(((x1) #f #f #f () (_))
(lexical x1 _))))
(lambda ()
(lambda-case
(((x2) #f #f #f () (_))
(primcall - (lexical x2 _) (const 1))))))))
(pass-if "inlined lambdas are alpha-renamed"
;; In this example, `make-adder' is inlined more than once; thus,
;; they should use different gensyms for their arguments, because
;; the various optimization passes assume uniquely-named variables.
;;
;; Bug reported at
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00019.html> and
;; <https://lists.gnu.org/archive/html/bug-guile/2011-09/msg00029.html>.
(pmatch (unparse-tree-il
(peval (compile
'(let ((make-adder
(lambda (x) (lambda (y) (+ x y)))))
(cons (make-adder 1) (make-adder 2)))
#:to 'tree-il)))
((primcall cons
(lambda ()
(lambda-case
(((y) #f #f #f () (,gensym1))
(primcall +
(const 1)
(lexical y ,ref1)))))
(lambda ()
(lambda-case
(((y) #f #f #f () (,gensym2))
(primcall +
(const 2)
(lexical y ,ref2))))))
(and (eq? gensym1 ref1)
(eq? gensym2 ref2)
(not (eq? gensym1 gensym2))))
(_ #f)))
(pass-if-peval
;; Higher order, mutually recursive procedures.
(letrec ((even? (lambda (x)
(or (= 0 x)
(odd? (- x 1)))))
(odd? (lambda (x)
(not (even? (- x 1))))))
(and (even? 4) (odd? 7)))
(const #t))
;;
;; Below are cases where constant propagation should bail out.
;;
(pass-if-peval
;; Non-constant lexical is not propagated.
(let ((v (make-vector 6 #f)))
(lambda (n)
(vector-set! v n n)))
(let (v) (_)
((call (toplevel make-vector) (const 6) (const #f)))
(lambda ()
(lambda-case
(((n) #f #f #f () (_))
(call (toplevel vector-set!)
(lexical v _) (lexical n _) (lexical n _)))))))
(pass-if-peval
;; Mutable lexical is not propagated.
(let ((v (vector 1 2 3)))
(lambda ()
v))
(let (v) (_)
((primcall vector (const 1) (const 2) (const 3)))
(lambda ()
(lambda-case
((() #f #f #f () ())
(lexical v _))))))
(pass-if-peval
;; Lexical that is not provably pure is not inlined nor propagated.
(let* ((x (if (> p q) (frob!) (display 'chbouib)))
(y (* x 2)))
(+ x x y))
(let (x) (_) ((if (primcall > (toplevel p) (toplevel q))
(call (toplevel frob!))
(call (toplevel display) (const chbouib))))
(let (y) (_) ((primcall * (lexical x _) (const 2)))
(primcall +
(lexical x _) (lexical x _) (lexical y _)))))
(pass-if-peval
;; Non-constant arguments not propagated to lambdas.
((lambda (x y z)
(vector-set! x 0 0)
(set-car! y 0)
(set-cdr! z '()))
(vector 1 2 3)
(make-list 10)
(list 1 2 3))
(let (x y z) (_ _ _)
((primcall vector (const 1) (const 2) (const 3))
(call (toplevel make-list) (const 10))
(primcall list (const 1) (const 2) (const 3)))
(seq
(call (toplevel vector-set!)
(lexical x _) (const 0) (const 0))
(seq (call (toplevel set-car!)
(lexical y _) (const 0))
(call (toplevel set-cdr!)
(lexical z _) (const ()))))))
(pass-if-peval
(let ((foo top-foo) (bar top-bar))
(let* ((g (lambda (x y) (+ x y)))
(f (lambda (g x) (g x x))))
(+ (f g foo) (f g bar))))
(let (foo bar) (_ _) ((toplevel top-foo) (toplevel top-bar))
(primcall +
(primcall + (lexical foo _) (lexical foo _))
(primcall + (lexical bar _) (lexical bar _)))))
(pass-if-peval
;; Fresh objects are not turned into constants, nor are constants
;; turned into fresh objects.
(let* ((c '(2 3))
(x (cons 1 c))
(y (cons 0 x)))
y)
(let (x) (_) ((primcall cons (const 1) (const (2 3))))
(primcall cons (const 0) (lexical x _))))
(pass-if-peval
;; Bindings mutated.
(let ((x 2))
(set! x 3)
x)
(let (x) (_) ((const 2))
(seq
(set! (lexical x _) (const 3))
(lexical x _))))
(pass-if-peval
;; Bindings mutated.
(letrec ((x 0)
(f (lambda ()
(set! x (+ 1 x))
x)))
(frob f) ; may mutate `x'
x)
(letrec (x) (_) ((const 0))
(seq
(call (toplevel frob) (lambda _ _))
(lexical x _))))
(pass-if-peval
;; Bindings mutated.
(letrec ((f (lambda (x)
(set! f (lambda (_) x))
x)))
(f 2))
(letrec _ . _))
(pass-if-peval
;; Bindings possibly mutated.
(let ((x (make-foo)))
(frob! x) ; may mutate `x'
x)
(let (x) (_) ((call (toplevel make-foo)))
(seq
(call (toplevel frob!) (lexical x _))
(lexical x _))))
(pass-if-peval
;; Inlining stops at recursive calls with dynamic arguments.
(let loop ((x x))
(if (< x 0) x (loop (1- x))))
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x) #f #f #f () (_))
(if _ _
(call (lexical loop _)
(primcall 1-
(lexical x _))))))))
(call (lexical loop _) (toplevel x))))
(pass-if-peval
;; Recursion on the 2nd argument is fully evaluated.
(let ((x (top)))
(let loop ((x x) (y 10))
(if (> y 0)
(loop x (1- y))
(foo x y))))
(let (x) (_) ((call (toplevel top)))
(letrec (loop) (_) (_)
(call (toplevel foo) (lexical x _) (const 0)))))
(pass-if-peval
;; Inlining aborted when residual code contains recursive calls.
;;
;; <http://debbugs.gnu.org/9542>
(let loop ((x x) (y 0))
(if (> y 0)
(loop (1- x) (1- y))
(if (< x 0)
x
(loop (1+ x) (1+ y)))))
(letrec (loop) (_) ((lambda (_)
(lambda-case
(((x y) #f #f #f () (_ _))
(if (primcall >
(lexical y _) (const 0))
_ _)))))
(call (lexical loop _) (toplevel x) (const 0))))
(pass-if-peval
;; Infinite recursion: `peval' gives up and leaves it as is.
(letrec ((f (lambda (x) (g (1- x))))
(g (lambda (x) (h (1+ x))))
(h (lambda (x) (f x))))
(f 0))
(letrec _ . _))
(pass-if-peval
;; Constant folding: cons
(begin (cons 1 2) #f)
(const #f))
(pass-if-peval
;; Constant folding: cons
(begin (cons (foo) 2) #f)
(seq (call (toplevel foo)) (const #f)))
(pass-if-peval
;; Constant folding: cons
(if (cons 0 0) 1 2)
(const 1))
(pass-if-peval
;; Constant folding: car+cons
(car (cons 1 0))
(const 1))
(pass-if-peval
;; Constant folding: cdr+cons
(cdr (cons 1 0))
(const 0))
(pass-if-peval
;; Constant folding: car+cons, impure
(car (cons 1 (bar)))
(seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+cons, impure
(cdr (cons (bar) 0))
(seq (call (toplevel bar)) (const 0)))
(pass-if-peval
;; Constant folding: car+list
(car (list 1 0))
(const 1))
(pass-if-peval
;; Constant folding: cdr+list
(cdr (list 1 0))
(primcall list (const 0)))
(pass-if-peval
;; Constant folding: car+list, impure
(car (list 1 (bar)))
(seq (call (toplevel bar)) (const 1)))
(pass-if-peval
;; Constant folding: cdr+list, impure
(cdr (list (bar) 0))
(seq (call (toplevel bar)) (primcall list (const 0))))
(pass-if-peval
resolve-primitives
;; Prompt is removed if tag is unreferenced
(let ((tag (make-prompt-tag)))
(call-with-prompt tag
(lambda () 1)
(lambda args args)))
(const 1))
(pass-if-peval
resolve-primitives
;; Prompt is removed if tag is unreferenced, with explicit stem
(let ((tag (make-prompt-tag "foo")))
(call-with-prompt tag
(lambda () 1)
(lambda args args)))
(const 1))
(pass-if-peval
resolve-primitives
;; `while' without `break' or `continue' has no prompts and gets its
;; condition folded. Unfortunately the outer `lp' does not yet get
;; elided.
(while #t #t)
(letrec (lp) (_)
((lambda _
(lambda-case
((() #f #f #f () ())
(letrec (loop) (_)
((lambda _
(lambda-case
((() #f #f #f () ())
(call (lexical loop _))))))
(call (lexical loop _)))))))
(call (lexical lp _)))))
(with-test-prefix "tree-il-fold"

3
test-suite/tests/web-http.test
View file

@ -89,6 +89,9 @@
(pass-if-parse date "Tue, 15 Nov 1994 08:12:31 GMT"
(string->date "Tue, 15 Nov 1994 08:12:31 +0000"
"~a, ~d ~b ~Y ~H:~M:~S ~z"))
(pass-if-parse date "Wed, 7 Sep 2011 11:25:00 GMT"
(string->date "Wed, 7 Sep 2011 11:25:00 +0000"
"~a,~e ~b ~Y ~H:~M:~S ~z"))
(pass-if-parse-error date "Tue, 15 Nov 1994 08:12:31 EST" date)
(pass-if-any-error date "Tue, 15 Qux 1994 08:12:31 EST")

2
test-suite/vm/t-match.scm
View file

@ -12,7 +12,7 @@
(define (matches? obj)
; (format #t "matches? ~a~%" obj)
(match obj
(($ stuff) #t)
(($ <stuff>) #t)
; (blurps #t)
("hello" #t)
(else #f)))