Thread: [pure-lang-svn] SF.net SVN: pure-lang:[648] pure/trunk (Page 4)
Status: Beta
Brought to you by:
agraef
Menu
▾
▴
pure-lang-svn
|
From: <ag...@us...> - 2008-08-28 08:39:17
|
Revision: 648
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=648&view=rev
Author: agraef
Date: 2008-08-28 08:39:27 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
Work around failed math tests due to locale-related problems on some systems.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/Makefile.in
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-28 08:14:15 UTC (rev 647)
+++ pure/trunk/ChangeLog 2008-08-28 08:39:27 UTC (rev 648)
@@ -1,5 +1,9 @@
2008-08-28 Albert Graef <Dr....@t-...>
+ * Makefile.in: Set LC_ALL=C, to work around failed math tests due
+ to locale-related problems on some systems. Note: This requires a
+ reconfigure.
+
* lib/system.pure: Add setlocale function.
* runtime.cc (pure_sys_vars): Add NULL and LC_* constants.
Modified: pure/trunk/Makefile.in
===================================================================
--- pure/trunk/Makefile.in 2008-08-28 08:14:15 UTC (rev 647)
+++ pure/trunk/Makefile.in 2008-08-28 08:39:27 UTC (rev 648)
@@ -259,16 +259,21 @@
cleanlogs:
rm -f $(srcdir)/test/*.log
+# Note: Unfortunately, a few tests may produce varying results with different
+# locales, so we have to make sure that we set up a neutral environment
+# here. We therefore set LC_ALL=C below, which should do the job on Linux and
+# other glibc-based systems. Other systems might require some work.
+
$(srcdir)/test/prelude.log: lib/prelude.pure lib/primitives.pure lib/strings.pure
- @LD_LIB_PATH@=. PURELIB=$(srcdir)/lib ./pure -n -v$(level) $< > $@ 2>&1
+ LC_ALL=C @LD_LIB_PATH@=. PURELIB=$(srcdir)/lib ./pure -n -v$(level) $< > $@ 2>&1
%.log: %.pure
- @LD_LIB_PATH@=. PURELIB=$(srcdir)/lib ./pure -v$(level) < $< > $@ 2>&1
+ LC_ALL=C @LD_LIB_PATH@=. PURELIB=$(srcdir)/lib ./pure -v$(level) < $< > $@ 2>&1
check: pure
@ echo Running tests.
- @ (export @LD_LIB_PATH@=.; export PURELIB=$(srcdir)/lib; echo $(ECHO_N) "prelude.pure: $(ECHO_C)"; if ./pure -n -v$(level) $(srcdir)/lib/prelude.pure 2>&1 | diff -q - $(srcdir)/test/prelude.log > /dev/null; then echo "$(ECHO_T)passed"; else echo "$(ECHO_T)FAILED"; fi)
- @ (export @LD_LIB_PATH@=.; export PURELIB=$(srcdir)/lib; for x in $(notdir $(tests)); do echo $(ECHO_N) "$$x: $(ECHO_C)"; if ./pure -v$(level) < $(srcdir)/test/$$x 2>&1 | diff -q - $(srcdir)/test/"`basename $$x .pure`.log" > /dev/null; then echo "$(ECHO_T)passed"; else echo "$(ECHO_T)FAILED"; fi; done)
+ @ (export LC_ALL=C; export @LD_LIB_PATH@=.; export PURELIB=$(srcdir)/lib; echo $(ECHO_N) "prelude.pure: $(ECHO_C)"; if ./pure -n -v$(level) $(srcdir)/lib/prelude.pure 2>&1 | diff -q - $(srcdir)/test/prelude.log > /dev/null; then echo "$(ECHO_T)passed"; else echo "$(ECHO_T)FAILED"; fi)
+ @ (export LC_ALL=C; export @LD_LIB_PATH@=.; export PURELIB=$(srcdir)/lib; for x in $(notdir $(tests)); do echo $(ECHO_N) "$$x: $(ECHO_C)"; if ./pure -v$(level) < $(srcdir)/test/$$x 2>&1 | diff -q - $(srcdir)/test/"`basename $$x .pure`.log" > /dev/null; then echo "$(ECHO_T)passed"; else echo "$(ECHO_T)FAILED"; fi; done)
# DO NOT DELETE
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-28 11:16:45
|
Revision: 649
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=649&view=rev
Author: agraef
Date: 2008-08-28 11:16:52 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
Added sentries a.k.a. expression guards.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-28 08:39:27 UTC (rev 648)
+++ pure/trunk/ChangeLog 2008-08-28 11:16:52 UTC (rev 649)
@@ -1,5 +1,10 @@
2008-08-28 Albert Graef <Dr....@t-...>
+ * runtime.cc/h: Added sentries -- expression "guards" which are
+ applied to the target expression when it is garbage-collected.
+ Only sentries on applications and pointer objects are supported
+ right now.
+
* Makefile.in: Set LC_ALL=C, to work around failed math tests due
to locale-related problems on some systems. Note: This requires a
reconfigure.
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-28 08:39:27 UTC (rev 648)
+++ pure/trunk/runtime.cc 2008-08-28 11:16:52 UTC (rev 649)
@@ -102,6 +102,50 @@
#define SSTK_DEBUG 0
#endif
+static inline pure_expr* pure_apply2(pure_expr *x, pure_expr *y)
+{
+ // Count references and construct a function application.
+ pure_new_args(2, x, y);
+ return pure_apply(x, y);
+}
+
+static inline pure_expr* signal_exception(int sig)
+{
+ if (!interpreter::g_interp) return 0;
+ pure_expr *f = pure_const(interpreter::g_interp->symtab.signal_sym().f);
+ pure_expr *x = pure_int(sig);
+ return pure_apply2(f, x);
+}
+
+static inline pure_expr* stack_exception()
+{
+ if (!interpreter::g_interp) return 0;
+ return pure_const(interpreter::g_interp->symtab.segfault_sym().f);
+}
+
+static inline pure_expr *get_sentry(pure_expr *x)
+{
+ if (x==0)
+ return 0;
+ else if (x->tag == EXPR::APP || x->tag == EXPR::PTR)
+ return x->data.x[2];
+ else
+ return 0;
+}
+
+static inline void free_sentry(pure_expr *x)
+{
+ if (x->tag == EXPR::APP || x->tag == EXPR::PTR) {
+ pure_expr *s = x->data.x[2];
+ if (s) {
+ ++x->refc;
+ pure_freenew(pure_apply2(s, x));
+ pure_free(s);
+ --x->refc;
+ }
+ }
+}
+
// Expression pointers are allocated in larger chunks for better performance.
// NOTE: Only internal fields get initialized by new_expr(), the remaining
// fields *must* be initialized as appropriate by the caller.
@@ -123,6 +167,7 @@
}
x->refc = 0;
x->xp = interp.tmps;
+ x->data.x[2] = 0; // initialize the sentry
interp.tmps = x;
return x;
}
@@ -197,6 +242,7 @@
pure_expr *xp = 0, *y;
loop:
if (--x->refc == 0) {
+ free_sentry(x);
switch (x->tag) {
case EXPR::APP:
y = x->data.x[0];
@@ -242,6 +288,7 @@
void pure_free_internal(pure_expr *x)
{
if (--x->refc == 0) {
+ free_sentry(x);
switch (x->tag) {
case EXPR::APP:
pure_free_internal(x->data.x[0]);
@@ -287,27 +334,6 @@
}
}
-static inline pure_expr* pure_apply2(pure_expr *x, pure_expr *y)
-{
- // Count references and construct a function application.
- pure_new_args(2, x, y);
- return pure_apply(x, y);
-}
-
-static inline pure_expr* signal_exception(int sig)
-{
- if (!interpreter::g_interp) return 0;
- pure_expr *f = pure_const(interpreter::g_interp->symtab.signal_sym().f);
- pure_expr *x = pure_int(sig);
- return pure_apply2(f, x);
-}
-
-static inline pure_expr* stack_exception()
-{
- if (!interpreter::g_interp) return 0;
- return pure_const(interpreter::g_interp->symtab.segfault_sym().f);
-}
-
/* PUBLIC API. **************************************************************/
extern "C"
@@ -812,6 +838,32 @@
}
extern "C"
+pure_expr *pure_sentry(pure_expr *sentry, pure_expr *x)
+{
+ if (x==0)
+ return 0;
+ else if (x->tag == EXPR::APP || x->tag == EXPR::PTR) {
+ if (x->data.x[2])
+ pure_free_internal(x->data.x[2]);
+ x->data.x[2] = sentry?pure_new_internal(sentry):0;
+ return x;
+ } else
+ return 0;
+}
+
+extern "C"
+pure_expr *pure_get_sentry(pure_expr *x)
+{
+ return get_sentry(x);
+}
+
+extern "C"
+pure_expr *pure_clear_sentry(pure_expr *x)
+{
+ return pure_sentry(0, x);
+}
+
+extern "C"
bool pure_let(int32_t sym, pure_expr *x)
{
if (sym <= 0 || !x) return false;
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-08-28 08:39:27 UTC (rev 648)
+++ pure/trunk/runtime.h 2008-08-28 11:16:52 UTC (rev 649)
@@ -38,7 +38,7 @@
int32_t tag; // type tag or symbol, see expr.hh for possible values
uint32_t refc; // reference counter
union {
- struct _pure_expr *x[2]; // application arguments (EXPR::APP)
+ struct _pure_expr *x[3]; // application arguments (EXPR::APP), sentry
int32_t i; // integer (EXPR::INT)
mpz_t z; // GMP bigint (EXPR::BIGINT)
double d; // double (EXPR::DBL)
@@ -217,6 +217,20 @@
void pure_ref(pure_expr *x);
void pure_unref(pure_expr *x);
+/* Sentries. These are expression "guards" which are applied to the target
+ expression when it is garbage-collected. pure_sentry places a sentry at an
+ expression (or removes it if sentry is NULL) and returns the modified
+ expression, pure_get_sentry returns the current sentry of an expression, if
+ any (NULL otherwise). pure_clear_sentry(x) is a convenience function for
+ pure_sentry(NULL, x). NOTE: In the current implementation sentries can only
+ be placed at applications and pointer objects, pure_sentry will return NULL
+ if you apply it to other kinds of expressions. The sentry itself can be any
+ type of object (but usually it's a function). */
+
+pure_expr *pure_sentry(pure_expr *sentry, pure_expr *x);
+pure_expr *pure_get_sentry(pure_expr *x);
+pure_expr *pure_clear_sentry(pure_expr *x);
+
/* Variable and constant definitions. These allow you to directly bind
variable and constant symbols to pure_expr* values, as the 'let' and 'def'
constructs do in the Pure language. The functions return true if
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-28 11:22:07
|
Revision: 650
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=650&view=rev
Author: agraef
Date: 2008-08-28 11:22:17 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
Moved definition of NULL to interpreter initialization.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/runtime.cc
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-08-28 11:16:52 UTC (rev 649)
+++ pure/trunk/interpreter.cc 2008-08-28 11:22:17 UTC (rev 650)
@@ -337,6 +337,8 @@
defn("argv", args);
defn("version", pure_cstring_dup(version.c_str()));
defn("sysinfo", pure_cstring_dup(host.c_str()));
+ // null pointer
+ const_defn("NULL", pure_pointer(0));
}
// Errors and warnings.
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-28 11:16:52 UTC (rev 649)
+++ pure/trunk/runtime.cc 2008-08-28 11:22:17 UTC (rev 650)
@@ -3088,8 +3088,6 @@
df(interp, "stdin", pure_pointer(stdin));
df(interp, "stdout", pure_pointer(stdout));
df(interp, "stderr", pure_pointer(stderr));
- // null pointer
- cdf(interp, "NULL", pure_pointer(0));
// clock
cdf(interp, "CLOCKS_PER_SEC", pure_int(CLOCKS_PER_SEC));
// fnmatch, glob
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-28 11:25:49
|
Revision: 651
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=651&view=rev
Author: agraef
Date: 2008-08-28 11:25:58 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
Moved definition of NULL to primitives.pure.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/lib/primitives.pure
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-08-28 11:22:17 UTC (rev 650)
+++ pure/trunk/interpreter.cc 2008-08-28 11:25:58 UTC (rev 651)
@@ -337,8 +337,6 @@
defn("argv", args);
defn("version", pure_cstring_dup(version.c_str()));
defn("sysinfo", pure_cstring_dup(host.c_str()));
- // null pointer
- const_defn("NULL", pure_pointer(0));
}
// Errors and warnings.
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-08-28 11:22:17 UTC (rev 650)
+++ pure/trunk/lib/primitives.pure 2008-08-28 11:25:58 UTC (rev 651)
@@ -373,6 +373,8 @@
/* Pointer arithmetic. We do this using bigints, so that the code is portable
to 64 bit systems. */
+const NULL = pointer 0; // the null pointer
+
null x::pointer = bigint x==0;
x::pointer-y::pointer = bigint x-bigint y;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-28 11:38:39
|
Revision: 653
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=653&view=rev
Author: agraef
Date: 2008-08-28 11:38:47 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
Add interface to sentries.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/primitives.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-28 11:27:46 UTC (rev 652)
+++ pure/trunk/ChangeLog 2008-08-28 11:38:47 UTC (rev 653)
@@ -1,5 +1,7 @@
2008-08-28 Albert Graef <Dr....@t-...>
+ * lib/primitives.pure: Add interface to sentries (see below).
+
* runtime.cc/h: Added sentries -- expression "guards" which are
applied to the target expression when it is garbage-collected.
Only sentries on applications and pointer objects are supported
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-08-28 11:27:46 UTC (rev 652)
+++ pure/trunk/lib/primitives.pure 2008-08-28 11:38:47 UTC (rev 653)
@@ -23,6 +23,17 @@
extern void pure_throw(expr*) = throw; // IMPURE!
+/* Sentries. These are expression "guards" which are applied to the target
+ expression when it is garbage-collected. The sentry function places a
+ sentry at an expression (and returns the modified expression), clear_sentry
+ removes, get_sentry returns it. NOTE: In the current implementation
+ sentries can only be placed at applications and pointer objects. The sentry
+ itself can be any type of object (but usually it's a function). */
+
+extern expr* pure_sentry(expr*,expr*) = sentry; // IMPURE!
+extern expr* pure_clear_sentry(expr*) = clear_sentry; // IMPURE!
+extern expr* pure_get_sentry(expr*) = get_sentry;
+
/* Syntactic equality. */
extern bool same(expr* x, expr* y);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-28 12:03:40
|
Revision: 654
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=654&view=rev
Author: agraef
Date: 2008-08-28 12:03:49 +0000 (Thu, 28 Aug 2008)
Log Message:
-----------
fopen/popen now take care of closing a file object when it's garbage-collected.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/system.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-28 11:38:47 UTC (rev 653)
+++ pure/trunk/ChangeLog 2008-08-28 12:03:49 UTC (rev 654)
@@ -1,5 +1,9 @@
2008-08-28 Albert Graef <Dr....@t-...>
+ * lib/system.pure: New definitions of fopen/popen and
+ fclose/pclose, using sentries which take care of closing a file
+ object automagically when it's garbage-collected.
+
* lib/primitives.pure: Add interface to sentries (see below).
* runtime.cc/h: Added sentries -- expression "guards" which are
Modified: pure/trunk/lib/system.pure
===================================================================
--- pure/trunk/lib/system.pure 2008-08-28 11:38:47 UTC (rev 653)
+++ pure/trunk/lib/system.pure 2008-08-28 12:03:49 UTC (rev 654)
@@ -157,10 +157,12 @@
routines are actually overridden with more convenient Pure wrappers
below. */
+private c_fopen c_popen c_fclose c_pclose;
+extern FILE* fopen(char* name, char* mode) = c_fopen;
+extern FILE* popen(char* cmd, char* mode) = c_popen;
+extern int fclose(FILE* fp) = c_fclose, int pclose(FILE* fp) = c_pclose;
+extern int fflush(FILE* fp);
private c_fgets c_gets;
-extern FILE* fopen(char* name, char* mode);
-extern FILE* popen(char* cmd, char* mode);
-extern int fflush(FILE* fp), int fclose(FILE* fp), int pclose(FILE* fp);
extern char* fgets(void* buf, int size, FILE* fp) = c_fgets;
extern char* gets(void* buf) = c_gets;
extern int fputs(char* s, FILE* fp), int puts(char* s);
@@ -169,6 +171,22 @@
extern void clearerr(FILE* fp);
extern int feof(FILE* fp), int ferror(FILE* fp);
+/* Pure wrappers for fopen/popen and fclose/pclose which take care of closing
+ a file object automagically when it's garbage-collected. */
+
+fopen name::string mode::string = check (c_fopen name mode) with
+ check fp::pointer = sentry c_fclose fp if not null fp;
+ check fp = fp otherwise;
+end;
+
+popen name::string mode::string = check (c_popen name mode) with
+ check fp::pointer = sentry c_pclose fp if not null fp;
+ check fp = fp otherwise;
+end;
+
+fclose fp::pointer = clear_sentry fp $$ c_fclose fp;
+pclose fp::pointer = clear_sentry fp $$ c_pclose fp;
+
/* Pure wrappers for fgets and gets which handle the necessary buffering
automatically. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-29 21:08:52
|
Revision: 658
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=658&view=rev
Author: agraef
Date: 2008-08-29 21:08:59 +0000 (Fri, 29 Aug 2008)
Log Message:
-----------
Added Eddie Rucker's syntax highlighting for gedit.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/README
pure/trunk/lib/prelude.pure
Added Paths:
-----------
pure/trunk/etc/gpure.lang
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-29 14:55:53 UTC (rev 657)
+++ pure/trunk/ChangeLog 2008-08-29 21:08:59 UTC (rev 658)
@@ -1,3 +1,8 @@
+2008-08-29 Albert Graef <Dr....@t-...>
+
+ * etc/gpure.lang: Added syntax highlighting for gedit. Contributed
+ by Eddie Rucker.
+
2008-08-28 Albert Graef <Dr....@t-...>
* lib/system.pure: New definitions of fopen/popen and
Modified: pure/trunk/README
===================================================================
--- pure/trunk/README 2008-08-29 14:55:53 UTC (rev 657)
+++ pure/trunk/README 2008-08-29 21:08:59 UTC (rev 658)
@@ -69,8 +69,8 @@
Pure scripts are just ordinary text files, which can be created with any text
editor. The distribution contains some language definition files and
programming modes to provide syntax highlighting in various popular text
-editors, such as Emacs, Kate and Vim. The Emacs mode also lets you run the
-Pure interpreter in an Emacs buffer, this is probably the most convenient
+editors, such as Emacs, Gedit, Kate and Vim. The Emacs mode also lets you run
+the Pure interpreter in an Emacs buffer, this is probably the most convenient
interface to the interpreter if you're friends with Emacs. A syntax file for
Andre Simon's highlight program is also included, this lets you pretty-print
Pure source in various output formats such as HTML and LaTeX. You can find all
Added: pure/trunk/etc/gpure.lang
===================================================================
--- pure/trunk/etc/gpure.lang (rev 0)
+++ pure/trunk/etc/gpure.lang 2008-08-29 21:08:59 UTC (rev 658)
@@ -0,0 +1,181 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<!--
+
+ Pure syntax highlighting for gedit. Usage:
+
+ - Rename this file to 'pure.lang' and copy it to the
+ /usr/share/gtksourceview-2.0/language-specs directory.
+
+ - You may also want to add a text/x-pure or text/x-puresrc mime type for
+ *.pure files so that your file manager can recognize them.
+
+ - Fire up gedit on your Pure script and enjoy the syntax highlighting.
+
+ Author: Eddie Rucker (mostly pilfered from Marco Barision and
+ Emanuela Aina's Ada and C packages)
+
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Library General Public
+ License as published by the Free Software Foundation; either
+ version 2 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
+ Library General Public License for more details.
+
+ You should have received a copy of the GNU Library General Public
+ License along with this library; if not, write to the
+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+ Boston, MA 02111-1307, USA.
+
+-->
+<language id="pure" _name="Pure" version="2.0" _section="Sources">
+ <metadata>
+ <property name="mimetypes">text/x-pure;text/x-puresrc</property>
+ <property name="globs">*.pure</property>
+ <property name="line-comment-start">//</property>
+ <property name="block-comment-start">/*</property>
+ <property name="block-comment-end">*/</property>
+ </metadata>
+
+ <styles>
+ <style id="comment" _name="Comment" map-to="def:comment"/>
+ <style id="string" _name="String" map-to="def:string"/>
+ <style id="keyword" _name="Keyword" map-to="def:keyword"/>
+ <style id="storage-class" _name="Storage Class" map-to="def:type"/>
+ <style id="type" _name="Data Type" map-to="def:type"/>
+ <style id="preprocessor" _name="Preprocessor" map-to="def:preprocessor"/>
+ <style id="double" _name="Double" map-to="def:floating-point"/>
+ <style id="hexadecimal" _name="Hexadecimal number" map-to="def:base-n-integer"/>
+ <style id="octal" _name="Octal" map-to="def:base-n-integer"/>
+ <style id="int" _name="Integer" map-to="def:decimal"/>
+ <style id="escaped-character" _name="Escaped Character" map-to="def:special-char"/>
+ </styles>
+
+ <default-regex-options case-sensitive="true"/>
+
+ <definitions>
+
+ <context id="line-comment" style-ref="comment" end-at-line-end="true">
+ <start>//</start>
+ <include>
+ <context ref="def:in-line-comment"/>
+ </include>
+ </context>
+
+ <context id="comment-multiline" style-ref="comment">
+ <start>/\*</start>
+ <end>\*/</end>
+ <include>
+ <context ref="def:in-comment"/>
+ </include>
+ </context>
+
+ <context id="string" style-ref="string" end-at-line-end="true">
+ <start>"</start>
+ <end>"</end>
+ <include>
+ <context id="string-esc" style-ref="escaped-character" extend-parent="true">
+ <match>""</match>
+ </context>
+ </include>
+ </context>
+
+ <context id="preprocessor-keyword" style-ref="preprocessor">
+ <keyword>def</keyword>
+ </context>
+
+ <context id="keyword" style-ref="keyword">
+ <keyword>case</keyword>
+ <keyword>when</keyword>
+ <keyword>with</keyword>
+ <keyword>end</keyword>
+ <keyword>else</keyword>
+ <keyword>if</keyword>
+ <keyword>infix</keyword>
+ <keyword>infixl</keyword>
+ <keyword>infixr</keyword>
+ <keyword>let</keyword>
+ <keyword>nullary</keyword>
+ <keyword>of</keyword>
+ <keyword>otherwise</keyword>
+ <keyword>prefix</keyword>
+ <keyword>postfix</keyword>
+ <keyword>then</keyword>
+ <keyword>catch</keyword>
+ <keyword>throw</keyword>
+ </context>
+
+ <context id="storage-class" style-ref="storage-class">
+ <keyword>const</keyword>
+ <keyword>private</keyword>
+ <keyword>extern</keyword>
+ <keyword>using</keyword>
+ </context>
+
+ <context id="type" style-ref="type">
+ <keyword>char</keyword>
+ <keyword>bool</keyword>
+ <keyword>float</keyword>
+ <keyword>int</keyword>
+ <keyword>double</keyword>
+ <keyword>expr</keyword>
+ <keyword>short</keyword>
+ <keyword>long</keyword>
+ <keyword>void</keyword>
+ <keyword>string</keyword>
+ <keyword>pointer</keyword>
+ </context>
+
+ <!-- http://www.lysator.liu.se/c/ANSI-C-grammar-l.html -->
+ <context id="double" style-ref="double">
+ <match extended="true">
+ (?<![\w\.])
+ ((\.[0-9]+ | [0-9]+\.[0-9]*) ([Ee][+-]?[0-9]*)?)
+ (?![\w\.])
+ </match>
+ </context>
+
+ <context id="hexadecimal" style-ref="hexadecimal">
+ <match extended="true">
+ (?<![\w\.])
+ 0[xX][a-fA-F0-9]+L?
+ (?![\w\.])
+ </match>
+ </context>
+
+ <context id="octal" style-ref="octal">
+ <match extended="true">
+ (?<![\w\.])
+ 0[0-7]+L?
+ (?![\w\.])
+ </match>
+ </context>
+
+ <context id="int" style-ref="int">
+ <match extended="true">
+ (?<![\w\.])
+ [0-9]+L?
+ (?![\w\.])
+ </match>
+ </context>
+
+ <context id="pure">
+ <include>
+ <context ref="line-comment"/>
+ <context ref="comment-multiline"/>
+ <context ref="string"/>
+ <context ref="preprocessor-keyword"/>
+ <context ref="keyword"/>
+ <context ref="storage-class"/>
+ <context ref="type"/>
+ <context ref="double"/>
+ <context ref="hexadecimal"/>
+ <context ref="octal"/>
+ <context ref="int"/>
+ </include>
+ </context>
+
+ </definitions>
+</language>
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-08-29 14:55:53 UTC (rev 657)
+++ pure/trunk/lib/prelude.pure 2008-08-29 21:08:59 UTC (rev 658)
@@ -97,9 +97,9 @@
def f $ x = f x;
def (f . g) x = f (g x);
-/* The following rule is always valid and optimizes the case of list
- comprehensions with throwaway results (useful if a list comprehension is
- evaluated solely for its side effects). */
+/* The following rule is always valid and optimizes the case of "throwaway"
+ list comprehensions (useful if a list comprehension is evaluated solely for
+ its side effects). */
def void (catmap f x) = do f x;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-30 20:08:55
|
Revision: 668
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=668&view=rev
Author: agraef
Date: 2008-08-30 20:09:05 +0000 (Sat, 30 Aug 2008)
Log Message:
-----------
Add expression pointer operations.
Modified Paths:
--------------
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-30 19:51:11 UTC (rev 667)
+++ pure/trunk/runtime.cc 2008-08-30 20:09:05 UTC (rev 668)
@@ -2571,6 +2571,13 @@
}
extern "C"
+pure_expr *pointer_get_expr(void *ptr)
+{
+ pure_expr **p = (pure_expr**)ptr;
+ return *p;
+}
+
+extern "C"
void pointer_put_byte(void *ptr, int32_t x)
{
uint8_t *p = (uint8_t*)ptr;
@@ -2605,6 +2612,13 @@
*p = x;
}
+extern "C"
+void pointer_put_expr(void *ptr, pure_expr *x)
+{
+ pure_expr **p = (pure_expr**)ptr;
+ *p = x;
+}
+
#include <errno.h>
extern "C"
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-08-30 19:51:11 UTC (rev 667)
+++ pure/trunk/runtime.h 2008-08-30 20:09:05 UTC (rev 668)
@@ -553,12 +553,14 @@
double pointer_get_double(void *ptr);
char *pointer_get_string(void *ptr);
void *pointer_get_pointer(void *ptr);
+pure_expr *pointer_get_expr(void *ptr);
void pointer_put_byte(void *ptr, int32_t x);
void pointer_put_int(void *ptr, int32_t x);
void pointer_put_double(void *ptr, double x);
void pointer_put_string(void *ptr, const char *x);
void pointer_put_pointer(void *ptr, void *x);
+void pointer_put_expr(void *ptr, pure_expr *x);
/* Initialize a bunch of variables with useful system constants. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-31 00:15:55
|
Revision: 672
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=672&view=rev
Author: agraef
Date: 2008-08-31 00:16:06 +0000 (Sun, 31 Aug 2008)
Log Message:
-----------
Add expression pointer operations.
Modified Paths:
--------------
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-30 21:31:04 UTC (rev 671)
+++ pure/trunk/runtime.cc 2008-08-31 00:16:06 UTC (rev 672)
@@ -447,6 +447,17 @@
}
extern "C"
+pure_expr *pure_expr_pointer(void)
+{
+ pure_expr **p = (pure_expr**)malloc(sizeof(pure_expr*));
+ if (p) {
+ *p = 0;
+ return pure_pointer(p);
+ } else
+ return 0;
+}
+
+extern "C"
pure_expr *pure_string_dup(const char *s)
{
if (!s) return pure_pointer(0);
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-08-30 21:31:04 UTC (rev 671)
+++ pure/trunk/runtime.h 2008-08-31 00:16:06 UTC (rev 672)
@@ -97,6 +97,12 @@
pure_expr *pure_double(double d);
pure_expr *pure_pointer(void *p);
+/* Expression pointers. The following routine returns a Pure pointer object
+ suitably allocated to hold a Pure expression (pure_expr*). The pointer is
+ initialized to hold a null expression. */
+
+pure_expr *pure_expr_pointer(void);
+
/* String constructors. There are four variations of these, depending on
whether the original string is already in utf-8 (_string routines) or in
the system encoding (_cstring), and whether the string should be copied
@@ -546,7 +552,9 @@
bool lambdap(const pure_expr *x);
bool varp(const pure_expr *x);
-/* Direct memory accesses. */
+/* Direct memory accesses. Use these with care. In particular, note that the
+ pointer_put_expr() routine doesn't do any reference counting by itself, so
+ you'll have to use the memory management routines above to do that. */
int32_t pointer_get_byte(void *ptr);
int32_t pointer_get_int(void *ptr);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-08-31 00:19:41
|
Revision: 673
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=673&view=rev
Author: agraef
Date: 2008-08-31 00:19:52 +0000 (Sun, 31 Aug 2008)
Log Message:
-----------
Added references (expression pointers).
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lib/primitives.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-08-31 00:16:06 UTC (rev 672)
+++ pure/trunk/ChangeLog 2008-08-31 00:19:52 UTC (rev 673)
@@ -1,3 +1,7 @@
+2008-08-31 Albert Graef <Dr....@t-...>
+
+ * lib/primitives.pure: Added references (expression pointers).
+
2008-08-29 Albert Graef <Dr....@t-...>
* etc/gpure.lang: Added syntax highlighting for gedit. Contributed
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-08-31 00:16:06 UTC (rev 672)
+++ pure/trunk/lib/primitives.pure 2008-08-31 00:19:52 UTC (rev 673)
@@ -424,3 +424,38 @@
extern expr* pure_sentry(expr*,expr*) = sentry; // IMPURE!
extern expr* pure_clear_sentry(expr*) = clear_sentry; // IMPURE!
extern expr* pure_get_sentry(expr*) = get_sentry;
+
+/* Expression references. If you need these, then you're doomed. ;-) However,
+ they can be useful as a last resort when you need to keep track of some
+ local state or interface to the messy imperative world. Pure's references
+ are implemented as Pure expression pointers so that you can readily pass
+ them as pointers to a C function which expects a pure_expr** parameter.
+ This may even be useful at times.
+
+ 'ref x' creates a reference pointing to x initially, 'put r x' sets a new
+ value (and returns it), 'get r' retrieves the current value, and 'unref r'
+ purges the referenced object and turns the reference into a dangling
+ pointer. (The latter is used as a sentry on reference objects and shouldn't
+ normally be called directly.) The refp predicate can be used to check for
+ reference values. Note that manually removing the unref sentry turns the
+ reference into just a normal pointer object and renders it unusable as a
+ reference. Doing this will also leak memory, so don't! */
+
+private pure_new pure_free pure_expr_pointer;
+private pointer_get_expr pointer_put_expr;
+extern expr* pure_new(expr*), expr* pure_expr_pointer();
+extern void pure_free(expr*);
+extern expr* pointer_get_expr(void*), void pointer_put_expr(void*, expr*);
+
+ref x = pointer_put_expr r (pure_new x) $$
+ sentry unref r when r::pointer = pure_expr_pointer end;
+
+unref r::pointer = pure_free (pointer_get_expr r) $$
+ clear_sentry r if refp r;
+
+put r::pointer x = pure_free (pointer_get_expr r) $$
+ pointer_put_expr r (pure_new x) $$ x if refp r;
+
+get r::pointer = pointer_get_expr r if refp r;
+
+refp r = case r of _::pointer = get_sentry r===unref; _ = 0 end;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-01 00:53:38
|
Revision: 675
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=675&view=rev
Author: agraef
Date: 2008-09-01 00:53:42 +0000 (Mon, 01 Sep 2008)
Log Message:
-----------
Add basic support for suspended expressions (thunks).
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/lib/prelude.pure
pure/trunk/lib/primitives.pure
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/interpreter.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -1707,8 +1707,13 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = subst(vars, x.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = subst(vars, x.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -1812,8 +1817,13 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = fsubst(funs, x.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = fsubst(funs, x.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -1909,8 +1919,11 @@
return x;
// application:
case EXPR::APP:
- if (x.xval1().tag() == EXPR::APP &&
- x.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (x.xval1().tag() == symtab.amp_sym().f) {
+ expr v = csubst(x.xval2());
+ return expr(symtab.amp_sym().x, v);
+ } else if (x.xval1().tag() == EXPR::APP &&
+ x.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = csubst(x.xval1().xval2()),
v = csubst(x.xval2());
return expr(symtab.catch_sym().x, u, v);
@@ -2203,8 +2216,13 @@
return y;
// application:
case EXPR::APP:
- if (y.xval1().tag() == EXPR::APP &&
- y.xval1().xval1().tag() == symtab.catch_sym().f) {
+ if (y.xval1().tag() == symtab.amp_sym().f) {
+ if (++idx == 0)
+ throw err("error in expression (too many nested closures)");
+ expr v = macred(x, y.xval2(), idx);
+ return expr(symtab.amp_sym().x, v);
+ } else if (y.xval1().tag() == EXPR::APP &&
+ y.xval1().xval1().tag() == symtab.catch_sym().f) {
expr u = macred(x, y.xval1().xval2(), idx);
if (++idx == 0)
throw err("error in expression (too many nested closures)");
@@ -3005,7 +3023,14 @@
case EXPR::APP: {
expr f; uint32_t n = count_args(x, f);
interpreter& interp = *interpreter::g_interp;
- if (n == 2 && f.tag() == interp.symtab.catch_sym().f) {
+ if (n == 1 && f.tag() == interp.symtab.amp_sym().f) {
+ expr y = x.xval2();
+ push("&");
+ Env* eptr = fmap.act()[-x.hash()] = new Env(0, 0, y, true, true);
+ Env& e = *eptr;
+ e.build_map(y); e.promote_map();
+ pop();
+ } else if (n == 2 && f.tag() == interp.symtab.catch_sym().f) {
expr h = x.xval1().xval2(), y = x.xval2();
push("catch");
Env* eptr = fmap.act()[-x.hash()] = new Env(0, 0, y, true, true);
@@ -4778,6 +4803,19 @@
Value *u = codegen(x.xval1().xval2());
act_builder().CreateCall(module->getFunction("pure_freenew"), u);
return codegen(x.xval2());
+ } else if (n == 1 && f.tag() == symtab.amp_sym().f) {
+ // create a thunk (parameterless anonymous closure)
+ expr y = x.xval2();
+ Env& act = act_env();
+ assert(act.fmap.act().find(-x.hash()) != act.fmap.act().end());
+ Env& e = *act.fmap.act()[-x.hash()];
+ push("&", &e);
+ fun_prolog("anonymous");
+ e.CreateRet(codegen(y));
+ fun_finish();
+ pop(&e);
+ Value *body = fbox(e);
+ return body;
} else if (n == 2 && f.tag() == symtab.catch_sym().f) {
// catch an exception; create a little anonymous closure to be called
// through pure_catch()
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/lib/prelude.pure 2008-09-01 00:53:42 UTC (rev 675)
@@ -46,24 +46,25 @@
/* Operators. Note that the parser will automagically give unary minus the
same precedence level as the corresponding binary operator. */
-infixl 0 $$ ; // sequence operator
-infixr 0 $ ; // right-associative application
-infixr 1 , ; // pair (tuple)
-infix 2 => ; // mapsto constructor
-infixr 2 || ; // logical or (short-circuit)
-infixr 3 && ; // logical and (short-circuit)
-prefix 3 not ; // logical negation
-infix 4 < > <= >= == != ; // relations
-infix 4 === !== ; // syntactic equality
-infixr 4 : ; // list cons
-infixl 5 << >> ; // bit shifts
-infixl 6 + - or ; // addition, bitwise or
-infixl 7 * / div mod and ; // multiplication, bitwise and
-prefix 7 ~ ; // bitwise not
-infixr 8 ^ ; // exponentiation
-prefix 8 # ; // size operator
-infixl 9 ! !! ; // indexing, slicing
-infixr 9 . ; // function composition
+infixl 0 $$ ; // sequence operator
+infixr 0 $ ; // right-associative application
+infixr 1 , ; // pair (tuple)
+infix 2 => ; // mapsto constructor
+infixr 2 || ; // logical or (short-circuit)
+infixr 3 && ; // logical and (short-circuit)
+prefix 3 not ; // logical negation
+infix 4 < > <= >= == != ; // relations
+infix 4 === !== ; // syntactic equality
+infixr 4 : ; // list cons
+infixl 5 << >> ; // bit shifts
+infixl 6 + - or ; // addition, bitwise or
+infixl 7 * / div mod and ; // multiplication, bitwise and
+prefix 7 ~ ; // bitwise not
+infixr 8 ^ ; // exponentiation
+prefix 8 # ; // size operator
+infixl 9 ! !! ; // indexing, slicing
+infixr 9 . ; // function composition
+postfix 9 & ; // thunk
/* The truth values. These are just integers in Pure, but sometimes it's
convenient to refer to them using these symbolic constants. */
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/lib/primitives.pure 2008-09-01 00:53:42 UTC (rev 675)
@@ -23,6 +23,11 @@
extern void pure_throw(expr*) = throw; // IMPURE!
+/* Force a thunk (x&). This usually happens automagically when the value of a
+ thunk is needed. */
+
+extern expr* pure_force(expr*) = force;
+
/* Syntactic equality. */
extern bool same(expr* x, expr* y);
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/printer.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -758,8 +758,12 @@
return os << pure_paren(95, u) << " " << pure_paren(100, v);
}
default: {
- if (x->tag == 0)
- return os << "<<closure " << (void*)x << ">>";
+ if (x->data.clos && x->data.clos->xp)
+ return os << x->data.clos->xp;
+ if (x->tag == 0) {
+ const char *s = (x->data.clos && x->data.clos->n==0)?"thunk":"closure";
+ return os << "<<" << s << " " << (void*)x << ">>";
+ }
const symbol& sym = interpreter::g_interp->symtab.sym(x->tag);
if (x->data.clos && x->data.clos->local)
return os << "<<closure " << sym.s << ">>";
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/runtime.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -1196,6 +1196,7 @@
x->data.clos->m = m;
x->data.clos->fp = f;
x->data.clos->ep = e;
+ x->data.clos->xp = 0;
if (e) ((Env*)e)->refc++;
if (m == 0)
x->data.clos->env = 0;
@@ -1322,12 +1323,12 @@
{
char test;
assert(x);
- if (x->tag >= 0 && x->data.clos && x->data.clos->n == 0) {
+ if (x->tag > 0 && x->data.clos && x->data.clos->n == 0) {
void *fp = x->data.clos->fp;
#if DEBUG>1
cerr << "pure_call: calling " << x << " -> " << fp << endl;
#endif
- assert(x->tag > 0 && x->refc > 0 && !x->data.clos->local);
+ assert(x->refc > 0 && !x->data.clos->local);
// parameterless call
checkall(test);
return ((pure_expr*(*)())fp)();
@@ -1343,6 +1344,37 @@
}
}
+extern "C"
+pure_expr *pure_force(pure_expr *x)
+{
+ char test;
+ assert(x);
+ if (x->tag == 0 && x->data.clos && x->data.clos->n == 0) {
+ // parameterless anonymous closure (thunk)
+ if (x->data.clos->xp) return x->data.clos->xp; // memoized value
+ void *fp = x->data.clos->fp;
+#if DEBUG>1
+ cerr << "pure_force: calling " << x << " -> " << fp << endl;
+#endif
+ assert(x->refc > 0);
+ // parameterless call
+ checkall(test);
+ pure_expr *ret = ((pure_expr*(*)())fp)();
+ // memoize the result
+ x->data.clos->xp = pure_new_internal(ret);
+ return ret;
+ } else {
+#if DEBUG>2
+ if (x->tag >= 0 && x->data.clos)
+ cerr << "pure_force: returning " << x << " -> " << x->data.clos->fp
+ << " (" << x->data.clos->n << " args)" << endl;
+ else
+ cerr << "pure_force: returning " << x << endl;
+#endif
+ return x;
+ }
+}
+
static inline void resize_sstk(pure_expr**& sstk, size_t& cap,
size_t sz, size_t n)
{
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/runtime.h 2008-09-01 00:53:42 UTC (rev 675)
@@ -26,6 +26,7 @@
void *ep; // pointer to compile time environment (Env*)
uint32_t n, m; // number of arguments and environment size
struct _pure_expr **env; // captured environment (if m>0, 0 otherwise)
+ struct _pure_expr *xp; // pointer to memoized result
bool local; // local function?
bool thunked; // thunked closure? (kept unevaluated)
} pure_closure;
@@ -353,6 +354,12 @@
pure_expr *pure_call(pure_expr *x);
pure_expr *pure_apply(pure_expr *x, pure_expr *y);
+/* This is like pure_call above, but only executes anonymous parameterless
+ closures (thunks), and returns the result in that case (which is then
+ memoized). */
+
+pure_expr *pure_force(pure_expr *x);
+
/* Exception handling stuff. */
typedef struct { jmp_buf jmp; pure_expr* e; size_t sz; } pure_exception;
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/symtable.cc 2008-09-01 00:53:42 UTC (rev 675)
@@ -40,6 +40,7 @@
failed_cond_sym();
signal_sym();
segfault_sym();
+ amp_sym();
}
symbol* symtable::lookup(const string& s, int32_t modno)
@@ -358,3 +359,12 @@
else
return sym("mod", 7, infixl);
}
+
+symbol& symtable::amp_sym()
+{
+ symbol *_sym = lookup("&");
+ if (_sym)
+ return *_sym;
+ else
+ return sym("&", 9, postfix);
+}
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-08-31 22:34:35 UTC (rev 674)
+++ pure/trunk/symtable.hh 2008-09-01 00:53:42 UTC (rev 675)
@@ -95,6 +95,7 @@
symbol& failed_cond_sym() { return sym("failed_cond"); }
symbol& signal_sym() { return sym("signal"); }
symbol& segfault_sym() { return sym("stack_fault"); }
+ symbol& amp_sym();
};
#endif // ! SYMTABLE_HH
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-01 13:31:00
|
Revision: 677
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=677&view=rev
Author: agraef
Date: 2008-09-01 13:31:10 +0000 (Mon, 01 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/printer.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-01 07:00:29 UTC (rev 676)
+++ pure/trunk/printer.cc 2008-09-01 13:31:10 UTC (rev 677)
@@ -758,8 +758,6 @@
return os << pure_paren(95, u) << " " << pure_paren(100, v);
}
default: {
- if (x->data.clos && x->data.clos->xp)
- return os << x->data.clos->xp;
if (x->tag == 0) {
const char *s = (x->data.clos && x->data.clos->n==0)?"thunk":"closure";
return os << "<<" << s << " " << (void*)x << ">>";
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-01 07:00:29 UTC (rev 676)
+++ pure/trunk/runtime.cc 2008-09-01 13:31:10 UTC (rev 677)
@@ -235,6 +235,27 @@
delete x->data.clos;
}
+static pure_closure *pure_copy_clos(pure_closure *clos)
+{
+ assert(clos);
+ pure_closure *ret = new pure_closure;
+ ret->local = clos->local;
+ ret->thunked = clos->thunked;
+ ret->n = clos->n;
+ ret->m = clos->m;
+ ret->fp = clos->fp;
+ ret->ep = clos->ep;
+ if (clos->ep) ((Env*)clos->ep)->refc++;
+ if (clos->m == 0)
+ ret->env = 0;
+ else {
+ ret->env = new pure_expr*[clos->m];
+ for (size_t i = 0; i < clos->m; i++)
+ ret->env[i] = pure_new_internal(clos->env[i]);
+ }
+ return ret;
+}
+
#if 1
/* This is implemented (mostly) non-recursively to prevent stack overflows,
@@ -1196,7 +1217,6 @@
x->data.clos->m = m;
x->data.clos->fp = f;
x->data.clos->ep = e;
- x->data.clos->xp = 0;
if (e) ((Env*)e)->refc++;
if (m == 0)
x->data.clos->env = 0;
@@ -1365,7 +1385,6 @@
assert(x);
if (x->tag == 0 && x->data.clos && x->data.clos->n == 0) {
// parameterless anonymous closure (thunk)
- if (x->data.clos->xp) return x->data.clos->xp; // memoized value
pure_expr *ret;
interpreter& interp = *interpreter::g_interp;
void *fp = x->data.clos->fp;
@@ -1417,9 +1436,32 @@
#endif
// pop the function object from the shadow stack
--interp.sstk_sz;
+ // check whether the result is again a thunk, then we have to evaluate
+ // that recursively
+ if (ret->tag == 0 && ret->data.clos && ret->data.clos->n == 0)
+ ret = pure_force(pure_new_internal(ret));
// memoize the result
- x->data.clos->xp = pure_new_internal(ret);
- return ret;
+ assert(x!=ret);
+ pure_free_clos(x);
+ x->tag = ret->tag;
+ x->data = ret->data;
+ switch (x->tag) {
+ case EXPR::APP:
+ pure_new_internal(x->data.x[0]);
+ pure_new_internal(x->data.x[1]);
+ case EXPR::PTR:
+ if (x->data.x[2]) pure_new_internal(x->data.x[2]);
+ break;
+ case EXPR::STR:
+ x->data.s = strdup(x->data.s);
+ break;
+ default:
+ if (x->tag >= 0 && x->data.clos)
+ x->data.clos = pure_copy_clos(x->data.clos);
+ break;
+ }
+ pure_freenew(ret);
+ return x;
} else {
#if DEBUG>2
if (x->tag >= 0 && x->data.clos)
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-01 07:00:29 UTC (rev 676)
+++ pure/trunk/runtime.h 2008-09-01 13:31:10 UTC (rev 677)
@@ -26,7 +26,6 @@
void *ep; // pointer to compile time environment (Env*)
uint32_t n, m; // number of arguments and environment size
struct _pure_expr **env; // captured environment (if m>0, 0 otherwise)
- struct _pure_expr *xp; // pointer to memoized result
bool local; // local function?
bool thunked; // thunked closure? (kept unevaluated)
} pure_closure;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-01 15:01:03
|
Revision: 679
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=679&view=rev
Author: agraef
Date: 2008-09-01 15:01:13 +0000 (Mon, 01 Sep 2008)
Log Message:
-----------
Automatic forcing of thunks in pattern matching, syntactic identity checks and C calls.
Modified Paths:
--------------
pure/trunk/interpreter.cc
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/interpreter.cc
===================================================================
--- pure/trunk/interpreter.cc 2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/interpreter.cc 2008-09-01 15:01:13 UTC (rev 679)
@@ -220,6 +220,8 @@
"void*", "void*", "int");
declare_extern((void*)pure_call,
"pure_call", "expr*", 1, "expr*");
+ declare_extern((void*)pure_force,
+ "pure_force", "expr*", 1, "expr*");
declare_extern((void*)pure_const,
"pure_const", "expr*", 1, "int");
declare_extern((void*)pure_int,
@@ -3545,6 +3547,26 @@
bool temps = false;
for (size_t i = 0; i < n; i++) {
Value *x = args[i];
+ // check for thunks which must be forced
+ {
+#if 1
+ // do a quick check on the tag value
+ Value *idx[2] = { Zero, Zero };
+ Value *tagv = b.CreateLoad(b.CreateGEP(x, idx, idx+2), "tag");
+ Value *checkv = b.CreateICmpEQ(tagv, Zero, "check");
+ BasicBlock *forcebb = BasicBlock::Create("force");
+ BasicBlock *skipbb = BasicBlock::Create("skip");
+ b.CreateCondBr(checkv, forcebb, skipbb);
+ f->getBasicBlockList().push_back(forcebb);
+ b.SetInsertPoint(forcebb);
+ b.CreateCall(module->getFunction("pure_force"), x);
+ b.CreateBr(skipbb);
+ f->getBasicBlockList().push_back(skipbb);
+ b.SetInsertPoint(skipbb);
+#else
+ b.CreateCall(module->getFunction("pure_force"), x);
+#endif
+ }
if (argt[i] == Type::Int1Ty) {
BasicBlock *okbb = BasicBlock::Create("ok");
Value *idx[2] = { Zero, Zero };
@@ -5815,6 +5837,25 @@
msg << "simple match " << f.name;
debug(msg.str().c_str()); }
#endif
+ if (t.tag != EXPR::VAR || t.ttag != 0) {
+ // check for thunks which must be forced
+#if 1
+ // do a quick check on the tag value
+ Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
+ Value *checkv = f.builder.CreateICmpEQ(tagv, Zero, "check");
+ BasicBlock *forcebb = BasicBlock::Create("force");
+ BasicBlock *skipbb = BasicBlock::Create("skip");
+ f.builder.CreateCondBr(checkv, forcebb, skipbb);
+ f.f->getBasicBlockList().push_back(forcebb);
+ f.builder.SetInsertPoint(forcebb);
+ call("pure_force", x);
+ f.builder.CreateBr(skipbb);
+ f.f->getBasicBlockList().push_back(skipbb);
+ f.builder.SetInsertPoint(skipbb);
+#else
+ call("pure_force", x);
+#endif
+ }
// match the current symbol
switch (t.tag) {
case EXPR::VAR:
@@ -6036,7 +6077,31 @@
// first check for a literal match
size_t i, n = s->tr.size(), m = 0;
transl::iterator t0 = s->tr.begin();
- while (t0 != s->tr.end() && t0->tag == EXPR::VAR) t0++, m++;
+ bool must_force = false;
+ while (t0 != s->tr.end() && t0->tag == EXPR::VAR) {
+ if (t0->ttag != 0) must_force = true;
+ t0++; m++;
+ }
+ must_force = must_force || t0 != s->tr.end();
+ if (must_force) {
+ // check for thunks which must be forced
+#if 1
+ // do a quick check on the tag value
+ Value *tagv = f.CreateLoadGEP(x, Zero, Zero, "tag");
+ Value *checkv = f.builder.CreateICmpEQ(tagv, Zero, "check");
+ BasicBlock *forcebb = BasicBlock::Create("force");
+ BasicBlock *skipbb = BasicBlock::Create("skip");
+ f.builder.CreateCondBr(checkv, forcebb, skipbb);
+ f.f->getBasicBlockList().push_back(forcebb);
+ f.builder.SetInsertPoint(forcebb);
+ call("pure_force", x);
+ f.builder.CreateBr(skipbb);
+ f.f->getBasicBlockList().push_back(skipbb);
+ f.builder.SetInsertPoint(skipbb);
+#else
+ call("pure_force", x);
+#endif
+ }
if (t0 != s->tr.end()) {
assert(n > m);
// get the tag value
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/runtime.cc 2008-09-01 15:01:13 UTC (rev 679)
@@ -2619,12 +2619,16 @@
}
extern "C"
-bool same(const pure_expr *x, const pure_expr *y)
+bool same(pure_expr *x, pure_expr *y)
{
char test;
if (x == y)
return 1;
- else if (x->tag != y->tag)
+ if (x->tag == 0 && x->data.clos && x->data.clos->n == 0)
+ pure_force(x);
+ if (y->tag == 0 && y->data.clos && y->data.clos->n == 0)
+ pure_force(y);
+ if (x->tag != y->tag)
return 0;
else if (x->tag >= 0 && y->tag >= 0)
if (x->data.clos && y->data.clos)
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-01 14:37:04 UTC (rev 678)
+++ pure/trunk/runtime.h 2008-09-01 15:01:13 UTC (rev 679)
@@ -549,7 +549,7 @@
/* Check whether two objects are the "same" (syntactically). */
-bool same(const pure_expr *x, const pure_expr *y);
+bool same(pure_expr *x, pure_expr *y);
/* Check whether an object is a named function (closure), an anonymous
function (lambda), or a global variable, respectively. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-01 16:23:21
|
Revision: 683
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=683&view=rev
Author: agraef
Date: 2008-09-01 16:23:30 +0000 (Mon, 01 Sep 2008)
Log Message:
-----------
Add thunkp predicate.
Modified Paths:
--------------
pure/trunk/lib/primitives.pure
pure/trunk/runtime.cc
pure/trunk/runtime.h
Modified: pure/trunk/lib/primitives.pure
===================================================================
--- pure/trunk/lib/primitives.pure 2008-09-01 16:09:44 UTC (rev 682)
+++ pure/trunk/lib/primitives.pure 2008-09-01 16:23:30 UTC (rev 683)
@@ -45,7 +45,8 @@
/* Predicates to check for function objects, global (unbound) variables,
function applications, proper lists, list nodes and tuples. */
-extern bool funp(expr*), bool lambdap(expr*), bool varp(expr*);
+extern bool funp(expr*), bool lambdap(expr*), bool thunkp(expr*);
+extern bool varp(expr*);
applp (_ _) = 1;
applp _ = 0 otherwise;
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-01 16:09:44 UTC (rev 682)
+++ pure/trunk/runtime.cc 2008-09-01 16:23:30 UTC (rev 683)
@@ -2673,10 +2673,16 @@
extern "C"
bool lambdap(const pure_expr *x)
{
- return (x->tag == 0 && x->data.clos);
+ return (x->tag == 0 && x->data.clos && x->data.clos->n > 0);
}
extern "C"
+bool thunkp(const pure_expr *x)
+{
+ return (x->tag == 0 && x->data.clos && x->data.clos->n == 0);
+}
+
+extern "C"
bool varp(const pure_expr *x)
{
return (x->tag > 0 && !x->data.clos);
Modified: pure/trunk/runtime.h
===================================================================
--- pure/trunk/runtime.h 2008-09-01 16:09:44 UTC (rev 682)
+++ pure/trunk/runtime.h 2008-09-01 16:23:30 UTC (rev 683)
@@ -552,10 +552,11 @@
bool same(pure_expr *x, pure_expr *y);
/* Check whether an object is a named function (closure), an anonymous
- function (lambda), or a global variable, respectively. */
+ function (lambda or thunk), or a global variable, respectively. */
bool funp(const pure_expr *x);
bool lambdap(const pure_expr *x);
+bool thunkp(const pure_expr *x);
bool varp(const pure_expr *x);
/* Direct memory accesses. Use these with care. In particular, note that the
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-03 07:09:02
|
Revision: 687
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=687&view=rev
Author: agraef
Date: 2008-09-03 07:09:12 +0000 (Wed, 03 Sep 2008)
Log Message:
-----------
Overhaul of prelude (non-strict list operations).
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/lib/strings.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-03 04:48:36 UTC (rev 686)
+++ pure/trunk/lib/prelude.pure 2008-09-03 07:09:12 UTC (rev 687)
@@ -28,16 +28,12 @@
nullary failed_match; // failed pattern match (lambda, case, etc.)
nullary stack_fault; // not enough stack space (PURE_STACK limit)
-/* Other exceptions defined by the prelude. We use exceptions sparingly, to
- not interfere with symbolic evaluation, but in some cases it makes sense to
- raise special kinds of exceptions in response to obvious error conditions.
- In particular, the 'bad_list_value' exception is raised by functions which
- need to work from the end of a list towards its front. */
+/* Other exceptions defined by the prelude. */
nullary malloc_error; // memory allocation error
nullary out_of_bounds; // tuple or list index is out of bounds (!)
// bad_list_value xs; // not a proper list value (reverse, etc.)
- // xs denotes the offending tail of the list
+// bad_tuple_value xs; // not a proper tuple value (unzip, etc.)
/* Other constants. */
@@ -180,22 +176,39 @@
accum n::int xs = n+#xs;
end;
-(x,xs)!n::int = throw out_of_bounds if n<0;
+[]!n::int = throw out_of_bounds;
(x:xs)!0 = x;
-(x:xs)!n::int = xs!(n-1);
-[]!n::int = throw out_of_bounds;
+(x:xs)!n::int = xs!(n-1) if n>0;
+ = throw out_of_bounds otherwise;
+/* List concatenation. For a robust implementation which works with both
+ ordinary lists and streams, we want this to be tail-recursive *and*
+ non-strict. So we first walk down the list, popping elements from the first
+ operand until we find an empty or thunked tail ('tick'), then walk back up
+ again, pushing elements in front of the result list ('tack'). */
+
[]+ys = ys;
-(x:xs)+ys = x : accum ys (reverse xs) with
- accum ys (x:xs) = accum (x:ys) xs;
- accum ys [] = ys;
+xs@(_:_)+ys = tick [] xs ys
+with
+ tick zs (x:xs) ys = tack (x:zs) ((xs+ys)&) if thunkp xs;
+ = tick (x:zs) xs ys;
+ tick zs [] ys = tack zs ys;
+ /* Handle an improper list tail (xs+ys is in normal form here). */
+ tick zs xs ys = tack zs (xs+ys);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
end;
+/* List reversal. This is a strict operation, of course, so it will loop on
+ infinite lists. Also, this is one of the few list operations which throws
+ an exception for improper lists, since in that case there really isn't any
+ meaningful value to return. */
+
reverse [] = [];
reverse (x:xs) = accum [x] xs with
accum ys (x:xs) = accum (x:ys) xs;
accum ys [] = ys;
- accum _ xs = throw (bad_list_value xs);
+ accum ys xs = throw (bad_list_value xs);
end;
/* Convert between lists and tuples. */
@@ -213,12 +226,23 @@
accum ys xs = ys,xs;
end;
+/* Convert between lists and streams. */
+
+list [] = [];
+list (x:xs) = x:list xs;
+
+stream [] = [];
+stream (x:xs) = x:xs if thunkp xs;
+ = x:stream xs& otherwise;
+
/* Slicing. xs!!ns returns the list of xs!n for all members n of the index
- list ns which are in the range 0..#xs-1. xs must be a (proper) list or
- tuple, and the indices must be machine ints. */
+ list ns which are in the valid index range. This is a generic definition
+ which will work with any kind of container data structure which defines (!)
+ in such a manner that it throws an exception when the index is out of
+ bounds. */
-xs!!ns = [xs!n; n=ns; n>=0 && n<m] when m::int = #xs end
- if listp xs || tuplep xs;
+xs!!ns = catmap (nth xs) ns
+ with nth xs n = catch (cst []) [xs!n] end;
/* Arithmetic sequences. */
@@ -231,139 +255,205 @@
/* Common list functions. This mostly comes straight from the Q prelude which
in turn was based on the first edition of the Bird/Wadler book, and is very
similar to what you can find in the Haskell prelude. Some functions have
- slightly different names, though, and some of the definitions were massaged
- to make them tail-recursive. */
+ slightly different names, though, and of course everything is typed
+ dynamically. Some of the definitions aren't exactly pretty, but they are
+ like that because we want them to be both efficient and robust. In
+ particular, we require that they do all the necessary argument checking,
+ are tail-recursive and handle lazy lists as gracefully as possible. */
-all p [] = 1;
-all p (x:xs) = if p x then all p xs else 0;
+all p [] = 1;
+all p (x:xs) = if p x then all p xs else 0;
-any p [] = 0;
-any p (x:xs) = if p x then 1 else any p xs;
+any p [] = 0;
+any p (x:xs) = if p x then 1 else any p xs;
-do f [] = ();
-do f (x:xs) = f x $$ do f xs;
+do f [] = ();
+do f (x:xs) = f x $$ do f xs;
-drop n::int [] = [];
-drop n::int (x:xs)
- = drop (n-1) xs if n>0;
- = x:xs otherwise;
+drop n::int [] = [];
+drop n::int ys@(x:xs) = drop (n-1) xs if n>1;
+ = xs if n==1;
+ = ys otherwise;
-dropwhile p [] = [];
-dropwhile p (x:xs)
- = dropwhile p xs if p x;
- = x:xs otherwise;
+dropwhile p [] = [];
+dropwhile p ys@(x:xs) = dropwhile p xs if p x;
+ = ys otherwise;
-filter p [] = [];
-filter p (x:xs) = accum [] (x:xs) with
- accum ys [] = reverse ys;
- accum ys (x:xs) = accum (x:ys) xs if p x;
- = accum ys xs otherwise;
- accum ys xs = reverse ys+filter p xs;
- end;
+filter p [] = [];
+filter p xs@(_:_) = tick [] xs
+with
+ add p x xs = if p x then x:xs else xs;
+ tick zs (x:xs) = tack (add p x zs) (filter p xs&) if thunkp xs;
+ = tick (add p x zs) xs;
+ tick zs [] = tack zs [];
+ tick _ xs = throw (bad_list_value xs);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
-foldl f a [] = a;
-foldl f a (x:xs)
- = foldl f (f a x) xs;
+foldl f a [] = a;
+foldl f a (x:xs) = foldl f (f a x) xs;
-foldl1 f (x:xs) = foldl f x xs;
+foldl1 f (x:xs) = foldl f x xs;
-foldr f a [] = a;
-foldr f a (x:xs)
- = f x (foldl (flip f) a (reverse xs));
+foldr f a [] = a;
+foldr f a xs@(_:_) = tick [] xs
+with
+ tick zs (x:xs) = tack (x:zs) (foldr f a xs&) if thunkp xs;
+ = tick (x:zs) xs;
+ tick zs [] = tack zs a;
+ tick zs xs = tack zs (foldr f a xs);
+ tack (x:xs) y = tack xs (f x y);
+ tack [] y = y;
+end;
-foldr1 f [x] = x;
-foldr1 f (x:xs) = f x (foldl1 (flip f) (reverse xs));
+foldr1 f [x] = x;
+foldr1 f xs@(_:_) = tick [] xs
+with
+ /* Do the thunkp check first, before probing the tail. Note that the first
+ foldr1 rule above ensures that the topmost tail is already evaluated, so
+ that we always make some progress here. */
+ tick zs ys@(_:xs) = tack zs (foldr1 f ys&) if thunkp xs;
+ tick zs xs = case xs of
+ [x] = tack zs x;
+ x:xs = tick (x:zs) xs;
+ _ = tack zs (foldr1 f xs);
+ end;
+ tack (x:xs) y = tack xs (f x y);
+ tack [] y = y;
+end;
-head (x:xs) = x;
+head (x:xs) = x;
-init [x] = [];
-init (x:xs) = accum [x] xs with
- accum ys [x] = reverse ys;
- accum ys (x:xs) = accum (x:ys) xs;
- accum ys xs = reverse ys+init xs;
- end;
+init [x] = [];
+init xs@(_:_) = tick [] xs
+with
+ tick zs ys@(_:xs) = tack zs (init ys&) if thunkp xs;
+ tick zs xs = case xs of
+ [x] = tack zs [];
+ x:xs = tick (x:zs) xs;
+ _ = tack zs (init xs);
+ end;
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
-last [x] = x;
-last (x:xs) = last xs;
+last [x] = x;
+last (x:xs) = last xs;
-map f [] = [];
-map f (x:xs) = accum [f x] xs with
- accum ys [] = reverse ys;
- accum ys (x:xs) = accum (f x:ys) xs;
- accum ys xs = reverse ys+map f xs;
- end;
+map f [] = [];
+map f xs@(_:_) = tick [] xs
+with
+ tick zs (x:xs) = tack (f x:zs) (map f xs&) if thunkp xs;
+ = tick (f x:zs) xs;
+ tick zs [] = tack zs [];
+ tick zs xs = tack zs (map f xs);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
-scanl f a [] = [a];
-scanl f a (x:xs)
- = accum [a] (f a x) xs with
- accum ys a [] = reverse (a:ys);
- accum ys a (x:xs) = accum (a:ys) (f a x) xs;
- accum _ _ xs = throw (bad_list_value xs);
- end;
+scanl f a [] = [a];
+scanl f a xs@(_:_) = tick a [] xs
+with
+ tick a zs (x:xs) = tack (a:zs) (scanl f (f a x) xs&) if thunkp xs;
+ = tick (f a x) (a:zs) xs;
+ tick a zs [] = tack zs [a];
+ tick a zs xs = tack zs (scanl f a xs);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
-scanl1 f [] = [];
-scanl1 f (x:xs) = accum [] x xs with
- accum ys a [] = reverse (a:ys);
- accum ys a (x:xs) = accum (a:ys) (f a x) xs;
- accum _ _ xs = throw (bad_list_value xs);
- end;
+scanl1 f [] = [];
+scanl1 f (x:xs) = scanl f x xs;
-scanr f a [] = [a];
-scanr f a (x:xs)
- = f x y:ys when
- ys = reverse (scanl (flip f) a (reverse xs));
- y:_ = ys;
- end;
+scanr f a [] = [a];
+scanr f a xs@(_:_) = tick [] xs
+with
+ /* Hack around with thunks to make these matches irrefutable. */
+ tick zs (x:xs) = tack zs (f x (y when y:_ = ys end)&:ys
+ when ys = scanr f a xs& end) if thunkp xs;
+ = tick (x:zs) xs;
+ tick zs [] = tack zs [a];
+ tick zs xs = throw (bad_list_value xs);
+ tack (x:xs) ys = tack xs (f x y:ys) when y:_ = ys end;
+ tack [] ys = ys;
+end;
-scanr1 f [] = [];
-scanr1 f [x] = [x];
-scanr1 f (x:xs) = f x y:ys when
- ys = reverse (scanl1 (flip f) (reverse xs));
- y:_ = ys;
- end;
+scanr1 f [] = [];
+scanr1 f [x] = [x];
+scanr1 f xs@(_:_) = tick [] xs
+with
+ tick zs (x:xs) = tack zs (f x (y when y:_ = ys end)&:ys
+ when ys = scanr1 f xs& end) if thunkp xs;
+ tick zs xs = case xs of
+ [x] = tack zs [x];
+ x:xs = tick (x:zs) xs;
+ _ = throw (bad_list_value xs);
+ end;
+ tack (x:xs) ys = tack xs (f x y:ys) when y:_ = ys end;
+ tack [] ys = ys;
+end;
-tail (x:xs) = xs;
+tail (x:xs) = xs;
-take n::int [] = [];
-take n::int (x:xs)
- = accum n [] (x:xs) with
- accum _ ys [] = reverse ys;
- accum n::int ys _ = reverse ys if n<=0;
- accum n::int ys (x:xs)
- = accum (n-1) (x:ys) xs;
- accum n ys xs = reverse ys+take n xs;
- end;
+take n::int [] = [];
+take n::int xs@(_:_) = tick n [] xs
+with
+ tick n::int zs xs = tack zs [] if n<=0;
+ = case xs of
+ [] = tack zs [];
+ x:xs = tick (n-1) (x:zs) xs;
+ _ = tack zs (take n xs);
+ end;
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
takewhile p [] = [];
-takewhile p (x:xs)
- = accum [] (x:xs) with
- accum ys [] = reverse ys;
- accum ys (x:xs) = accum (x:ys) xs if p x;
- = reverse ys otherwise;
- accum ys xs = reverse ys+takewhile p xs;
- end;
+takewhile p xs@(_:_) = tick [] xs
+with
+ tick zs [] = tack zs [];
+ tick zs (x:xs) = tick (x:zs) xs if p x;
+ = tack zs [];
+ tick zs xs = tack zs (takewhile p xs);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
+end;
/* Concatenate a list of lists. */
-cat [] = [];
-cat [xs] = xs;
-cat (xs:xss) = accum (reverse xs) xss with
- accum xs [] = reverse xs;
- accum xs ([]:yss) = accum xs yss;
- accum xs ((y:ys):yss) = accum (y:xs) (ys:yss);
- accum _ (ys:_) = throw (bad_list_value ys);
- accum _ yss = throw (bad_list_value yss);
+cat [] = [];
+cat xs@(_:_) = foldr (+) [] xs
+with
+ /* Unfortunately, the global list concatenation operator (+) isn't fully
+ lazy in Pure, because it's also used for arithmetic operations. Using it
+ here would make foldr (and hence cat) eager. Therefore we use our own
+ lazy concatenation operation here. */
+ []+ys = ys;
+ xs@(_:_)+ys = tick [] xs ys;
+ tick zs (x:xs) ys = tack (x:zs) ((xs+ys)&) if thunkp xs;
+ = tick (x:zs) xs ys;
+ tick zs [] ys = tack zs ys;
+ tick zs xs ys = tack zs (xs+ys);
+ tack (x:xs) ys = tack xs (x:ys);
+ tack [] ys = ys;
end;
-/* Combine cat and map. This is used by list comprehensions. */
+/* Map a function to a list and concatenate the results. This is used by list
+ comprehensions. */
-catmap f xs = cat (map f xs);
+catmap f [] = [];
+catmap f xs@(_:_) = cat (map f xs);
+/* NOTE: This definition (from the Haskell prelude) is better, but doesn't
+ preserve left-to-right execution order. */
+//catmap f xs@(_:_) = foldr ((+).f) [] xs;
+
/* Search an element in a list. Returns -1 if not found, index of first
occurrence otherwise. */
-index [] _ = -1;
-index (x:xs) y = search 0 (x:xs) with
+index [] _ = -1;
+index (x:xs) y = search 0 (x:xs) with
search _ [] = -1;
search n::int (x:xs) = n if x==y;
= search (n+1) xs;
@@ -372,49 +462,93 @@
/* Some useful list generators. */
-repeat n::int x = accum [] n x with
+repeat n::int x = accum [] n x with
accum xs n::int x = xs if n<=0;
= accum (x:xs) (n-1) x;
end;
-cycle n::int [] = [];
-cycle n::int (x:xs)
- = [] if n<=0;
- = accum [] n with
- accum ys n::int = cat ys+take n xs if n<=m;
- = accum (xs:ys) (n-m) otherwise;
- end when xs = x:xs; m::int = #xs end if listp xs;
+cycle n::int [] = [];
+cycle n::int (x:xs) = [] if n<=0;
+ = accum [] n with
+ accum ys n::int = cat ys+take n xs if n<=m;
+ = accum (xs:ys) (n-m) otherwise;
+ end when xs = x:xs; m::int = #xs end if listp xs;
-while p f a = accum [] p f a with
- accum as p f a = accum (a:as) p f (f a) if p a;
- = reverse as otherwise;
- end;
+while p f a = accum [] p f a with
+ accum as p f a = accum (a:as) p f (f a) if p a;
+ = reverse as otherwise;
+ end;
-until p f a = accum [] p f a with
- accum as p f a = reverse as if p a;
- = accum (a:as) p f (f a) otherwise;
- end;
+until p f a = accum [] p f a with
+ accum as p f a = reverse as if p a;
+ = accum (a:as) p f (f a) otherwise;
+ end;
/* zip, unzip and friends. */
-zip xs ys = accum [] xs ys with
- accum us (x:xs) (y:ys) = accum ((x,y):us) xs ys;
- accum us _ _ = reverse us;
+zip [] _ |
+zip _ [] = [];
+zip xs@(_:_) ys@(_:_) = tick [] xs ys
+with
+ tick us (x:xs) (y:ys) = tack ((x,y):us) (zip xs ys&)
+ if thunkp xs || thunkp ys;
+ = tick ((x,y):us) xs ys;
+ tick us [] _ |
+ tick us _ [] = tack us [];
+ tick us xs ys = tack us (zip xs ys);
+ tack (u:us) vs = tack us (u:vs);
+ tack [] vs = vs;
end;
-zip3 xs ys zs = accum [] xs ys zs with
- accum us (x:xs) (y:ys) (z:zs) = accum ((x,y,z):us) xs ys zs;
- accum us _ _ _ = reverse us;
+zip3 [] _ _ |
+zip3 _ [] _ |
+zip3 _ _ [] = [];
+zip3 xs@(_:_) ys@(_:_) zs@(_:_)
+ = tick [] xs ys zs
+with
+ tick us (x:xs) (y:ys) (z:zs)
+ = tack ((x,y,z):us) (zip3 xs ys zs&)
+ if thunkp xs || thunkp ys || thunkp zs;
+ = tick ((x,y,z):us) xs ys zs;
+ tick us [] _ _ |
+ tick us _ [] _ |
+ tick us _ _ [] = tack us [];
+ tick us xs ys zs = tack us (zip3 xs ys zs);
+ tack (u:us) vs = tack us (u:vs);
+ tack [] vs = vs;
end;
-zipwith f xs ys = accum [] xs ys with
- accum us (x:xs) (y:ys) = accum (f x y:us) xs ys;
- accum us _ _ = reverse us;
+zipwith f [] _ |
+zipwith f _ [] = [];
+zipwith f xs@(_:_) ys@(_:_)
+ = tick [] xs ys
+with
+ tick us (x:xs) (y:ys) = tack (f x y:us) (zipwith f xs ys&)
+ if thunkp xs || thunkp ys;
+ = tick (f x y:us) xs ys;
+ tick us [] _ |
+ tick us _ [] = tack us [];
+ tick us xs ys = tack us (zipwith f xs ys);
+ tack (u:us) vs = tack us (u:vs);
+ tack [] vs = vs;
end;
-zipwith3 f xs ys zs = accum [] xs ys zs with
- accum us (x:xs) (y:ys) (z:zs) = accum (f x y z:us) xs ys zs;
- accum us _ _ _ = reverse us;
+zipwith3 f [] _ _ |
+zipwith3 f _ [] _ |
+zipwith3 f _ _ [] = [];
+zipwith3 f xs@(_:_) ys@(_:_) zs@(_:_)
+ = tick [] xs ys zs
+with
+ tick us (x:xs) (y:ys) (z:zs)
+ = tack (f x y z:us) (zipwith3 f xs ys zs&)
+ if thunkp xs || thunkp ys || thunkp zs;
+ = tick (f x y z:us) xs ys zs;
+ tick us [] _ _ |
+ tick us _ [] _ |
+ tick us _ _ [] = tack us [];
+ tick us xs ys zs = tack us (zipwith3 f xs ys zs);
+ tack (u:us) vs = tack us (u:vs);
+ tack [] vs = vs;
end;
dowith f (x:xs) (y:ys) = f x y $$ dowith f xs ys;
@@ -425,17 +559,20 @@
dowith3 f _ _ _ = () otherwise;
unzip [] = [],[];
-unzip ((x,y):us) = x:xs,y:ys when xs,ys = accum [] [] us end
+unzip us@(_:_) = foldr accum ([],[]) us
with
- accum xs ys [] = reverse xs,reverse ys;
- accum xs ys ((x,y):us) = accum (x:xs) (y:ys) us;
- accum _ _ us = throw (bad_list_value us);
+ accum u@(x,y) us = x:(xs when xs,_ = us end)&,
+ y:(ys when _,ys = us end)& if thunkp us;
+ = x:xs,y:ys when xs,ys = us end;
+ accum u _ = throw (bad_tuple_value u);
end;
unzip3 [] = [],[],[];
-unzip3 ((x,y,z):us) = x:xs,y:ys,z:zs when xs,ys,zs = accum [] [] [] us end
+unzip3 us@(_:_) = foldr accum ([],[],[]) us
with
- accum xs ys zs [] = reverse xs,reverse ys,reverse zs;
- accum xs ys zs ((x,y,z):us) = accum (x:xs) (y:ys) (z:zs) us;
- accum _ _ _ us = throw (bad_list_value us);
+ accum u@(x,y,z) us = x:(xs when xs,_,_ = us end)&,
+ y:(ys when _,ys,_ = us end)&,
+ z:(zs when _,_,zs = us end)& if thunkp us;
+ = x:xs,y:ys,z:zs when xs,ys,zs = us end;
+ accum u _ = throw (bad_tuple_value u);
end;
Modified: pure/trunk/lib/strings.pure
===================================================================
--- pure/trunk/lib/strings.pure 2008-09-03 04:48:36 UTC (rev 686)
+++ pure/trunk/lib/strings.pure 2008-09-03 07:09:12 UTC (rev 687)
@@ -151,19 +151,22 @@
end;
end when m = #delim end if not null delim;
-/* Slicing. */
+/* Conversions between between strings and lists, streams and tuples. */
-s::string!!ns = strcat [s!n; n=ns; n>=0 && n<m]
- when m::int = #s end;
+list s::string = chars s;
+stream s::string = stream (chars s);
+tuple s::string = tuple (chars s);
/* Define the customary list operations on strings, so that these can mostly
be used as if they were lists. */
-list s::string = chars s;
-tuple s::string = tuple (chars s);
+s::string+[] = chars s;
+s::string+xs@(_:_) = chars s+xs;
+[]+s::string+[] = chars s;
+xs@(_:_)+s::string = xs+chars s;
reverse s::string = strcat (reverse (chars s));
-cat (s::string:xs) = cat (chars s:xs);
+catmap f s::string = catmap f (chars s);
cycle n::int "" = "";
cycle n::int s::string = "" if n<=0;
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-03 04:48:36 UTC (rev 686)
+++ pure/trunk/test/prelude.log 2008-09-03 07:09:12 UTC (rev 687)
@@ -134,35 +134,79 @@
state 12: #0 #2
state 13: #1 #2
} end;
-(x/*0:0101*/,xs/*0:011*/)!n/*0:1*/::int = throw out_of_bounds if n/*0:1*/<0;
+[]!n/*0:1*/::int = throw out_of_bounds;
(x/*0:0101*/:xs/*0:011*/)!0 = x/*0:0101*/;
-(x/*0:0101*/:xs/*0:011*/)!n/*0:1*/::int = xs/*0:011*/!(n/*0:1*/-1);
-[]!n/*0:1*/::int = throw out_of_bounds;
+(x/*0:0101*/:xs/*0:011*/)!n/*0:1*/::int = xs/*0:011*/!(n/*0:1*/-1) if n/*0:1*/>0;
+(x/*0:0101*/:xs/*0:011*/)!n/*0:1*/::int = throw out_of_bounds;
[]+ys/*0:1*/ = ys/*0:1*/;
-(x/*0:0101*/:xs/*0:011*/)+ys/*0:1*/ = x/*0:0101*/:accum/*0*/ ys/*0:1*/ (reverse xs/*0:011*/) with accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ [] = ys/*0:01*/ {
- rule #0: accum ys (x:xs) = accum (x:ys) xs
- rule #1: accum ys [] = ys
+xs@(_/*0:0101*/:_/*0:011*/)+ys/*0:1*/ = tick/*0*/ [] xs/*0:01*/ ys/*0:1*/ with tick zs/*0:001*/ (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ (x/*0:0101*/:zs/*0:001*/) ((xs/*1:011*/+ys/*1:1*/)&) if thunkp xs/*0:011*/; tick zs/*0:001*/ (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tick/*1*/ (x/*0:0101*/:zs/*0:001*/) xs/*0:011*/ ys/*0:1*/; tick zs/*0:001*/ [] ys/*0:1*/ = tack/*1*/ zs/*0:001*/ ys/*0:1*/; tick zs/*0:001*/ xs/*0:01*/ ys/*0:1*/ = tack/*1*/ zs/*0:001*/ (xs/*0:01*/+ys/*0:1*/) {
+ rule #0: tick zs (x:xs) ys = tack (x:zs) ((xs+ys)&) if thunkp xs
+ rule #1: tick zs (x:xs) ys = tick (x:zs) xs ys
+ rule #2: tick zs [] ys = tack zs ys
+ rule #3: tick zs xs ys = tack zs (xs+ys)
+ state 0: #0 #1 #2 #3
+ <var> state 1
+ state 1: #0 #1 #2 #3
+ <var> state 2
+ <app> state 4
+ [] state 17
+ state 2: #3
+ <var> state 3
+ state 3: #3
+ state 4: #0 #1 #3
+ <var> state 5
+ <app> state 8
+ state 5: #3
+ <var> state 6
+ state 6: #3
+ <var> state 7
+ state 7: #3
+ state 8: #0 #1 #3
+ <var> state 9
+ : state 13
+ state 9: #3
+ <var> state 10
+ state 10: #3
+ <var> state 11
+ state 11: #3
+ <var> state 12
+ state 12: #3
+ state 13: #0 #1 #3
+ <var> state 14
+ state 14: #0 #1 #3
+ <var> state 15
+ state 15: #0 #1 #3
+ <var> state 16
+ state 16: #0 #1 #3
+ state 17: #2 #3
+ <var> state 18
+ state 18: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
state 0: #0 #1
- <var> state 1
- state 1: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
<app> state 2
- [] state 7
state 2: #0
- <app> state 3
+ : state 3
state 3: #0
- : state 4
+ <var> state 4
state 4: #0
<var> state 5
state 5: #0
<var> state 6
state 6: #0
state 7: #1
+ <var> state 8
+ state 8: #1
} end;
reverse [] = [];
-reverse (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ [] = ys/*0:01*/; accum _/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
+reverse (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ [] = ys/*0:01*/; accum ys/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
rule #0: accum ys (x:xs) = accum (x:ys) xs
rule #1: accum ys [] = ys
- rule #2: accum _ xs = throw (bad_list_value xs)
+ rule #2: accum ys xs = throw (bad_list_value xs)
state 0: #0 #1 #2
<var> state 1
state 1: #0 #1 #2
@@ -254,17 +298,19 @@
state 12: #0 #2
state 13: #1 #2
} end;
-xs/*0:01*/!!ns/*0:1*/ = catmap (\n/*0:*/ -> if n/*0:*/>=0&&n/*0:*/<m/*1:*/ then [xs/*2:01*/!n/*0:*/] else [] {
- rule #0: n = if n>=0&&n<m then [xs!n] else []
+list [] = [];
+list (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:list xs/*0:11*/;
+stream [] = [];
+stream (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:xs/*0:11*/ if thunkp xs/*0:11*/;
+stream (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:stream xs/*1:11*/&;
+xs/*0:01*/!!ns/*0:1*/ = catmap (nth/*0*/ xs/*0:01*/) ns/*0:1*/ with nth xs/*0:01*/ n/*0:1*/ = catch (cst []) [xs/*1:01*/!n/*1:1*/] {
+ rule #0: nth xs n = catch (cst []) [xs!n]
state 0: #0
<var> state 1
state 1: #0
-}) ns/*1:1*/ when m/*0:*/::int = #xs/*0:01*/ {
- rule #0: m::int = #xs
- state 0: #0
- <var>::int state 1
- state 1: #0
-} end if listp xs/*0:01*/||tuplep xs/*0:01*/;
+ <var> state 2
+ state 2: #0
+} end;
n1/*0:0101*/,n2/*0:011*/..m/*0:1*/ = while (\i/*0:*/ -> s/*1:*/*i/*0:*/<=s/*1:*/*m/*3:1*/ {
rule #0: i = s*i<=s*m
state 0: #0
@@ -304,193 +350,407 @@
do f/*0:01*/ [] = ();
do f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*0:01*/ x/*0:101*/$$do f/*0:01*/ xs/*0:11*/;
drop n/*0:01*/::int [] = [];
-drop n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = drop (n/*0:01*/-1) xs/*0:11*/ if n/*0:01*/>0;
-drop n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:xs/*0:11*/;
+drop n/*0:01*/::int ys@(x/*0:101*/:xs/*0:11*/) = drop (n/*0:01*/-1) xs/*0:11*/ if n/*0:01*/>1;
+drop n/*0:01*/::int ys@(x/*0:101*/:xs/*0:11*/) = xs/*0:11*/ if n/*0:01*/==1;
+drop n/*0:01*/::int ys@(x/*0:101*/:xs/*0:11*/) = ys/*0:1*/;
dropwhile p/*0:01*/ [] = [];
-dropwhile p/*0:01*/ (x/*0:101*/:xs/*0:11*/) = dropwhile p/*0:01*/ xs/*0:11*/ if p/*0:01*/ x/*0:101*/;
-dropwhile p/*0:01*/ (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:xs/*0:11*/;
+dropwhile p/*0:01*/ ys@(x/*0:101*/:xs/*0:11*/) = dropwhile p/*0:01*/ xs/*0:11*/ if p/*0:01*/ x/*0:101*/;
+dropwhile p/*0:01*/ ys@(x/*0:101*/:xs/*0:11*/) = ys/*0:1*/;
filter p/*0:01*/ [] = [];
-filter p/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [] (x/*0:101*/:xs/*0:11*/) with accum ys/*0:01*/ [] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/ if p/*1:01*/ x/*0:101*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ ys/*0:01*/ xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+filter p/*1:01*/ xs/*0:1*/ {
- rule #0: accum ys [] = reverse ys
- rule #1: accum ys (x:xs) = accum (x:ys) xs if p x
- rule #2: accum ys (x:xs) = accum ys xs
- rule #3: accum ys xs = reverse ys+filter p xs
+filter p/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ (add/*1*/ p/*1:01*/ x/*0:101*/ zs/*0:01*/) (filter p/*2:01*/ xs/*1:11*/&) if thunkp xs/*0:11*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (add/*1*/ p/*1:01*/ x/*0:101*/ zs/*0:01*/) xs/*0:11*/; tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ []; tick _/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
+ rule #0: tick zs (x:xs) = tack (add p x zs) (filter p xs&) if thunkp xs
+ rule #1: tick zs (x:xs) = tick (add p x zs) xs
+ rule #2: tick zs [] = tack zs []
+ rule #3: tick _ xs = throw (bad_list_value xs)
state 0: #0 #1 #2 #3
<var> state 1
state 1: #0 #1 #2 #3
<var> state 2
- [] state 3
- <app> state 4
+ <app> state 3
+ [] state 13
state 2: #3
- state 3: #0 #3
- state 4: #1 #2 #3
+ state 3: #0 #1 #3
+ <var> state 4
+ <app> state 6
+ state 4: #3
<var> state 5
- <app> state 7
state 5: #3
- <var> state 6
- state 6: #3
- state 7: #1 #2 #3
+ state 6: #0 #1 #3
+ <var> state 7
+ : state 10
+ state 7: #3
<var> state 8
- : state 11
state 8: #3
<var> state 9
state 9: #3
- <var> state 10
- state 10: #3
- state 11: #1 #2 #3
+ state 10: #0 #1 #3
+ <var> state 11
+ state 11: #0 #1 #3
<var> state 12
- state 12: #1 #2 #3
- <var> state 13
- state 13: #1 #2 #3
+ state 12: #0 #1 #3
+ state 13: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
+}; add p/*0:001*/ x/*0:01*/ xs/*0:1*/ = if p/*0:001*/ x/*0:01*/ then x/*0:01*/:xs/*0:1*/ else xs/*0:1*/ {
+ rule #0: add p x xs = if p x then x:xs else xs
+ state 0: #0
+ <var> state 1
+ state 1: #0
+ <var> state 2
+ state 2: #0
+ <var> state 3
+ state 3: #0
} end;
foldl f/*0:001*/ a/*0:01*/ [] = a/*0:01*/;
foldl f/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = foldl f/*0:001*/ (f/*0:001*/ a/*0:01*/ x/*0:101*/) xs/*0:11*/;
foldl1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = foldl f/*0:01*/ x/*0:101*/ xs/*0:11*/;
foldr f/*0:001*/ a/*0:01*/ [] = a/*0:01*/;
-foldr f/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*0:001*/ x/*0:101*/ (foldl (flip f/*0:001*/) a/*0:01*/ (reverse xs/*0:11*/));
-foldr1 f/*0:01*/ [x/*0:101*/] = x/*0:101*/;
-foldr1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*0:01*/ x/*0:101*/ (foldl1 (flip f/*0:01*/) (reverse xs/*0:11*/));
-head (x/*0:101*/:xs/*0:11*/) = x/*0:101*/;
-init [x/*0:101*/] = [];
-init (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [x/*0:101*/] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+init xs/*0:1*/ {
- rule #0: accum ys [x] = reverse ys
- rule #1: accum ys (x:xs) = accum (x:ys) xs
- rule #2: accum ys xs = reverse ys+init xs
- state 0: #0 #1 #2
+foldr f/*0:001*/ a/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ (x/*0:101*/:zs/*0:01*/) (foldr f/*2:001*/ a/*2:01*/ xs/*1:11*/&) if thunkp xs/*0:11*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (x/*0:101*/:zs/*0:01*/) xs/*0:11*/; tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ a/*1:01*/; tick zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (foldr f/*1:001*/ a/*1:01*/ xs/*0:1*/) {
+ rule #0: tick zs (x:xs) = tack (x:zs) (foldr f a xs&) if thunkp xs
+ rule #1: tick zs (x:xs) = tick (x:zs) xs
+ rule #2: tick zs [] = tack zs a
+ rule #3: tick zs xs = tack zs (foldr f a xs)
+ state 0: #0 #1 #2 #3
<var> state 1
- state 1: #0 #1 #2
+ state 1: #0 #1 #2 #3
<var> state 2
<app> state 3
- state 2: #2
- state 3: #0 #1 #2
+ [] state 13
+ state 2: #3
+ state 3: #0 #1 #3
<var> state 4
<app> state 6
- state 4: #2
+ state 4: #3
<var> state 5
- state 5: #2
- state 6: #0 #1 #2
+ state 5: #3
+ state 6: #0 #1 #3
<var> state 7
: state 10
- state 7: #2
+ state 7: #3
<var> state 8
- state 8: #2
+ state 8: #3
<var> state 9
- state 9: #2
- state 10: #0 #1 #2
+ state 9: #3
+ state 10: #0 #1 #3
<var> state 11
- state 11: #0 #1 #2
+ state 11: #0 #1 #3
<var> state 12
- [] state 13
- state 12: #1 #2
- state 13: #0 #1 #2
+ state 12: #0 #1 #3
+ state 13: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) y/*0:1*/ = tack/*1*/ xs/*0:011*/ (f/*1:001*/ x/*0:0101*/ y/*0:1*/); tack [] y/*0:1*/ = y/*0:1*/ {
+ rule #0: tack (x:xs) y = tack xs (f x y)
+ rule #1: tack [] y = y
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
-last [x/*0:101*/] = x/*0:101*/;
-last (x/*0:101*/:xs/*0:11*/) = last xs/*0:11*/;
-map f/*0:01*/ [] = [];
-map f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [f/*0:01*/ x/*0:101*/] xs/*0:11*/ with accum ys/*0:01*/ [] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (f/*1:01*/ x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+map f/*1:01*/ xs/*0:1*/ {
- rule #0: accum ys [] = reverse ys
- rule #1: accum ys (x:xs) = accum (f x:ys) xs
- rule #2: accum ys xs = reverse ys+map f xs
+foldr1 f/*0:01*/ [x/*0:101*/] = x/*0:101*/;
+foldr1 f/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ ys@(_/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ (foldr1 f/*2:01*/ ys/*1:1*/&) if thunkp xs/*0:11*/; tick zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [x/*0:01*/] = tack/*2*/ zs/*1:01*/ x/*0:01*/; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = tack/*2*/ zs/*1:01*/ (foldr1 f/*2:01*/ xs/*1:1*/) {
+ rule #0: [x] = tack zs x
+ rule #1: x:xs = tick (x:zs) xs
+ rule #2: _ = tack zs (foldr1 f xs)
state 0: #0 #1 #2
<var> state 1
- state 1: #0 #1 #2
- <var> state 2
- [] state 3
- <app> state 4
- state 2: #2
- state 3: #0 #2
- state 4: #1 #2
- <var> state 5
- <app> state 7
- state 5: #2
+ <app> state 2
+ state 1: #2
+ state 2: #0 #1 #2
+ <var> state 3
+ <app> state 5
+ state 3: #2
+ <var> state 4
+ state 4: #2
+ state 5: #0 #1 #2
<var> state 6
+ : state 9
state 6: #2
- state 7: #1 #2
+ <var> state 7
+ state 7: #2
<var> state 8
- : state 11
state 8: #2
- <var> state 9
- state 9: #2
+ state 9: #0 #1 #2
<var> state 10
- state 10: #2
+ state 10: #0 #1 #2
+ <var> state 11
+ [] state 12
state 11: #1 #2
+ state 12: #0 #1 #2
+} end {
+ rule #0: tick zs ys@(_:xs) = tack zs (foldr1 f ys&) if thunkp xs
+ rule #1: tick zs xs = case xs of [x] = tack zs x; x:xs = tick (x:zs) xs; _ = tack zs (foldr1 f xs) end
+ state 0: #0 #1
+ <var> state 1
+ state 1: #0 #1
+ <var> state 2
+ <app> state 3
+ state 2: #1
+ state 3: #0 #1
+ <var> state 4
+ <app> state 6
+ state 4: #1
+ <var> state 5
+ state 5: #1
+ state 6: #0 #1
+ <var> state 7
+ : state 10
+ state 7: #1
+ <var> state 8
+ state 8: #1
+ <var> state 9
+ state 9: #1
+ state 10: #0 #1
+ <var> state 11
+ state 11: #0 #1
<var> state 12
- state 12: #1 #2
- <var> state 13
- state 13: #1 #2
+ state 12: #0 #1
+}; tack (x/*0:0101*/:xs/*0:011*/) y/*0:1*/ = tack/*1*/ xs/*0:011*/ (f/*1:01*/ x/*0:0101*/ y/*0:1*/); tack [] y/*0:1*/ = y/*0:1*/ {
+ rule #0: tack (x:xs) y = tack xs (f x y)
+ rule #1: tack [] y = y
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
-scanl f/*0:001*/ a/*0:01*/ [] = [a/*0:01*/];
-scanl f/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [a/*0:01*/] (f/*0:001*/ a/*0:01*/ x/*0:101*/) xs/*0:11*/ with accum ys/*0:001*/ a/*0:01*/ [] = reverse (a/*0:01*/:ys/*0:001*/); accum ys/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (a/*0:01*/:ys/*0:001*/) (f/*1:001*/ a/*0:01*/ x/*0:101*/) xs/*0:11*/; accum _/*0:001*/ _/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
- rule #0: accum ys a [] = reverse (a:ys)
- rule #1: accum ys a (x:xs) = accum (a:ys) (f a x) xs
- rule #2: accum _ _ xs = throw (bad_list_value xs)
+head (x/*0:101*/:xs/*0:11*/) = x/*0:101*/;
+init [x/*0:101*/] = [];
+init xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ ys@(_/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ (init ys/*1:1*/&) if thunkp xs/*0:11*/; tick zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [x/*0:01*/] = tack/*2*/ zs/*1:01*/ []; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = tack/*2*/ zs/*1:01*/ (init xs/*1:1*/) {
+ rule #0: [x] = tack zs []
+ rule #1: x:xs = tick (x:zs) xs
+ rule #2: _ = tack zs (init xs)
state 0: #0 #1 #2
<var> state 1
- state 1: #0 #1 #2
- <var> state 2
+ <app> state 2
+ state 1: #2
state 2: #0 #1 #2
<var> state 3
- [] state 4
<app> state 5
state 3: #2
- state 4: #0 #2
- state 5: #1 #2
+ <var> state 4
+ state 4: #2
+ state 5: #0 #1 #2
<var> state 6
- <app> state 8
+ : state 9
state 6: #2
<var> state 7
state 7: #2
- state 8: #1 #2
- <var> state 9
- : state 12
- state 9: #2
+ <var> state 8
+ state 8: #2
+ state 9: #0 #1 #2
<var> state 10
- state 10: #2
+ state 10: #0 #1 #2
<var> state 11
- state 11: #2
- state 12: #1 #2
- <var> state 13
- state 13: #1 #2
- <var> state 14
- state 14: #1 #2
+ [] state 12
+ state 11: #1 #2
+ state 12: #0 #1 #2
+} end {
+ rule #0: tick zs ys@(_:xs) = tack zs (init ys&) if thunkp xs
+ rule #1: tick zs xs = case xs of [x] = tack zs []; x:xs = tick (x:zs) xs; _ = tack zs (init xs) end
+ state 0: #0 #1
+ <var> state 1
+ state 1: #0 #1
+ <var> state 2
+ <app> state 3
+ state 2: #1
+ state 3: #0 #1
+ <var> state 4
+ <app> state 6
+ state 4: #1
+ <var> state 5
+ state 5: #1
+ state 6: #0 #1
+ <var> state 7
+ : state 10
+ state 7: #1
+ <var> state 8
+ state 8: #1
+ <var> state 9
+ state 9: #1
+ state 10: #0 #1
+ <var> state 11
+ state 11: #0 #1
+ <var> state 12
+ state 12: #0 #1
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
-scanl1 f/*0:01*/ [] = [];
-scanl1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [] x/*0:101*/ xs/*0:11*/ with accum ys/*0:001*/ a/*0:01*/ [] = reverse (a/*0:01*/:ys/*0:001*/); accum ys/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (a/*0:01*/:ys/*0:001*/) (f/*1:01*/ a/*0:01*/ x/*0:101*/) xs/*0:11*/; accum _/*0:001*/ _/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
- rule #0: accum ys a [] = reverse (a:ys)
- rule #1: accum ys a (x:xs) = accum (a:ys) (f a x) xs
- rule #2: accum _ _ xs = throw (bad_list_value xs)
- state 0: #0 #1 #2
+last [x/*0:101*/] = x/*0:101*/;
+last (x/*0:101*/:xs/*0:11*/) = last xs/*0:11*/;
+map f/*0:01*/ [] = [];
+map f/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ (f/*1:01*/ x/*0:101*/:zs/*0:01*/) (map f/*2:01*/ xs/*1:11*/&) if thunkp xs/*0:11*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (f/*1:01*/ x/*0:101*/:zs/*0:01*/) xs/*0:11*/; tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ []; tick zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (map f/*1:01*/ xs/*0:1*/) {
+ rule #0: tick zs (x:xs) = tack (f x:zs) (map f xs&) if thunkp xs
+ rule #1: tick zs (x:xs) = tick (f x:zs) xs
+ rule #2: tick zs [] = tack zs []
+ rule #3: tick zs xs = tack zs (map f xs)
+ state 0: #0 #1 #2 #3
<var> state 1
- state 1: #0 #1 #2
+ state 1: #0 #1 #2 #3
<var> state 2
- state 2: #0 #1 #2
+ <app> state 3
+ [] state 13
+ state 2: #3
+ state 3: #0 #1 #3
+ <var> state 4
+ <app> state 6
+ state 4: #3
+ <var> state 5
+ state 5: #3
+ state 6: #0 #1 #3
+ <var> state 7
+ : state 10
+ state 7: #3
+ <var> state 8
+ state 8: #3
+ <var> state 9
+ state 9: #3
+ state 10: #0 #1 #3
+ <var> state 11
+ state 11: #0 #1 #3
+ <var> state 12
+ state 12: #0 #1 #3
+ state 13: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
+} end;
+scanl f/*0:001*/ a/*0:01*/ [] = [a/*0:01*/];
+scanl f/*0:001*/ a/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ a/*0:01*/ [] xs/*0:1*/ with tick a/*0:001*/ zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ (a/*0:001*/:zs/*0:01*/) (scanl f/*2:001*/ (f/*2:001*/ a/*1:001*/ x/*1:101*/) xs/*1:11*/&) if thunkp xs/*0:11*/; tick a/*0:001*/ zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (f/*1:001*/ a/*0:001*/ x/*0:101*/) (a/*0:001*/:zs/*0:01*/) xs/*0:11*/; tick a/*0:001*/ zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ [a/*0:001*/]; tick a/*0:001*/ zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (scanl f/*1:001*/ a/*0:001*/ xs/*0:1*/) {
+ rule #0: tick a zs (x:xs) = tack (a:zs) (scanl f (f a x) xs&) if thunkp xs
+ rule #1: tick a zs (x:xs) = tick (f a x) (a:zs) xs
+ rule #2: tick a zs [] = tack zs [a]
+ rule #3: tick a zs xs = tack zs (scanl f a xs)
+ state 0: #0 #1 #2 #3
+ <var> state 1
+ state 1: #0 #1 #2 #3
+ <var> state 2
+ state 2: #0 #1 #2 #3
<var> state 3
- [] state 4
- <app> state 5
- state 3: #2
- state 4: #0 #2
- state 5: #1 #2
+ <app> state 4
+ [] state 14
+ state 3: #3
+ state 4: #0 #1 #3
+ <var> state 5
+ <app> state 7
+ state 5: #3
<var> state 6
- <app> state 8
- state 6: #2
- <var> state 7
- state 7: #2
- state 8: #1 #2
+ state 6: #3
+ state 7: #0 #1 #3
+ <var> state 8
+ : state 11
+ state 8: #3
<var> state 9
- : state 12
- state 9: #2
+ state 9: #3
<var> state 10
- state 10: #2
- <var> state 11
- state 11: #2
- state 12: #1 #2
+ state 10: #3
+ state 11: #0 #1 #3
+ <var> state 12
+ state 12: #0 #1 #3
<var> state 13
- state 13: #1 #2
- <var> state 14
- state 14: #1 #2
+ state 13: #0 #1 #3
+ state 14: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
+scanl1 f/*0:01*/ [] = [];
+scanl1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = scanl f/*0:01*/ x/*0:101*/ xs/*0:11*/;
scanr f/*0:001*/ a/*0:01*/ [] = [a/*0:01*/];
-scanr f/*0:001*/ a/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*2:001*/ x/*2:101*/ y/*0:01*/:ys/*1:*/ when ys/*0:*/ = reverse (scanl (flip f/*0:001*/) a/*0:01*/ (reverse xs/*0:11*/)); y/*0:01*/:_/*0:1*/ = ys/*0:*/ {
+scanr f/*0:001*/ a/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ (f/*3:001*/ x/*2:101*/ (y/*0:01*/ when y/*0:01*/:_/*0:1*/ = ys/*1:*/ {
rule #0: y:_ = ys
state 0: #0
<app> state 1
@@ -503,15 +763,80 @@
state 4: #0
<var> state 5
state 5: #0
-} {
- rule #0: ys = reverse (scanl (flip f) a (reverse xs))
+} end)&:ys/*0:*/ when ys/*0:*/ = scanr f/*2:001*/ a/*2:01*/ xs/*1:11*/& {
+ rule #0: ys = scanr f a xs&
state 0: #0
<var> state 1
state 1: #0
+} end) if thunkp xs/*0:11*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (x/*0:101*/:zs/*0:01*/) xs/*0:11*/; tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ [a/*1:01*/]; tick zs/*0:01*/ xs/*0:1*/ = throw (bad_list_value xs/*0:1*/) {
+ rule #0: tick zs (x:xs) = tack zs (f x (y when y:_ = ys end)&:ys when ys = scanr f a xs& end) if thunkp xs
+ rule #1: tick zs (x:xs) = tick (x:zs) xs
+ rule #2: tick zs [] = tack zs [a]
+ rule #3: tick zs xs = throw (bad_list_value xs)
+ state 0: #0 #1 #2 #3
+ <var> state 1
+ state 1: #0 #1 #2 #3
+ <var> state 2
+ <app> state 3
+ [] state 13
+ state 2: #3
+ state 3: #0 #1 #3
+ <var> state 4
+ <app> state 6
+ state 4: #3
+ <var> state 5
+ state 5: #3
+ state 6: #0 #1 #3
+ <var> state 7
+ : state 10
+ state 7: #3
+ <var> state 8
+ state 8: #3
+ <var> state 9
+ state 9: #3
+ state 10: #0 #1 #3
+ <var> state 11
+ state 11: #0 #1 #3
+ <var> state 12
+ state 12: #0 #1 #3
+ state 13: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*2*/ xs/*1:011*/ (f/*2:001*/ x/*1:0101*/ y/*0:01*/:ys/*1:1*/) when y/*0:01*/:_/*0:1*/ = ys/*0:1*/ {
+ rule #0: y:_ = ys
+ state 0: #0
+ <app> state 1
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+} end; tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (f x y:ys) when y:_ = ys end
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
scanr1 f/*0:01*/ [] = [];
scanr1 f/*0:01*/ [x/*0:101*/] = [x/*0:101*/];
-scanr1 f/*0:01*/ (x/*0:101*/:xs/*0:11*/) = f/*2:01*/ x/*2:101*/ y/*0:01*/:ys/*1:*/ when ys/*0:*/ = reverse (scanl1 (flip f/*0:01*/) (reverse xs/*0:11*/)); y/*0:01*/:_/*0:1*/ = ys/*0:*/ {
+scanr1 f/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ (f/*3:01*/ x/*2:101*/ (y/*0:01*/ when y/*0:01*/:_/*0:1*/ = ys/*1:*/ {
rule #0: y:_ = ys
state 0: #0
<app> state 1
@@ -524,63 +849,170 @@
state 4: #0
<var> state 5
state 5: #0
-} {
- rule #0: ys = reverse (scanl1 (flip f) (reverse xs))
+} end)&:ys/*0:*/ when ys/*0:*/ = scanr1 f/*2:01*/ xs/*1:11*/& {
+ rule #0: ys = scanr1 f xs&
state 0: #0
<var> state 1
state 1: #0
+} end) if thunkp xs/*0:11*/; tick zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [x/*0:01*/] = tack/*2*/ zs/*1:01*/ [x/*0:01*/]; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = throw (bad_list_value xs/*1:1*/) {
+ rule #0: [x] = tack zs [x]
+ rule #1: x:xs = tick (x:zs) xs
+ rule #2: _ = throw (bad_list_value xs)
+ state 0: #0 #1 #2
+ <var> state 1
+ <app> state 2
+ state 1: #2
+ state 2: #0 #1 #2
+ <var> state 3
+ <app> state 5
+ state 3: #2
+ <var> state 4
+ state 4: #2
+ state 5: #0 #1 #2
+ <var> state 6
+ : state 9
+ state 6: #2
+ <var> state 7
+ state 7: #2
+ <var> state 8
+ state 8: #2
+ state 9: #0 #1 #2
+ <var> state 10
+ state 10: #0 #1 #2
+ <var> state 11
+ [] state 12
+ state 11: #1 #2
+ state 12: #0 #1 #2
+} end {
+ rule #0: tick zs (x:xs) = tack zs (f x (y when y:_ = ys end)&:ys when ys = scanr1 f xs& end) if thunkp xs
+ rule #1: tick zs xs = case xs of [x] = tack zs [x]; x:xs = tick (x:zs) xs; _ = throw (bad_list_value xs) end
+ state 0: #0 #1
+ <var> state 1
+ state 1: #0 #1
+ <var> state 2
+ <app> state 3
+ state 2: #1
+ state 3: #0 #1
+ <var> state 4
+ <app> state 6
+ state 4: #1
+ <var> state 5
+ state 5: #1
+ state 6: #0 #1
+ <var> state 7
+ : state 10
+ state 7: #1
+ <var> state 8
+ state 8: #1
+ <var> state 9
+ state 9: #1
+ state 10: #0 #1
+ <var> state 11
+ state 11: #0 #1
+ <var> state 12
+ state 12: #0 #1
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*2*/ xs/*1:011*/ (f/*2:01*/ x/*1:0101*/ y/*0:01*/:ys/*1:1*/) when y/*0:01*/:_/*0:1*/ = ys/*0:1*/ {
+ rule #0: y:_ = ys
+ state 0: #0
+ <app> state 1
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+} end; tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (f x y:ys) when y:_ = ys end
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
tail (x/*0:101*/:xs/*0:11*/) = xs/*0:11*/;
take n/*0:01*/::int [] = [];
-take n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = accum/*0*/ n/*0:01*/ [] (x/*0:101*/:xs/*0:11*/) with accum _/*0:001*/ ys/*0:01*/ [] = reverse ys/*0:01*/; accum n/*0:001*/::int ys/*0:01*/ _/*0:1*/ = reverse ys/*0:01*/ if n/*0:001*/<=0; accum n/*0:001*/::int ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (n/*0:001*/-1) (x/*0:101*/:ys/*0:01*/) xs/*0:11*/; accum n/*0:001*/ ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+take n/*0:001*/ xs/*0:1*/ {
- rule #0: accum _ ys [] = reverse ys
- rule #1: accum n::int ys _ = reverse ys if n<=0
- rule #2: accum n::int ys (x:xs) = accum (n-1) (x:ys) xs
- rule #3: accum n ys xs = reverse ys+take n xs
- state 0: #0 #1 #2 #3
+take n/*0:01*/::int xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ n/*0:01*/ [] xs/*0:1*/ with tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ [] if n/*0:001*/<=0; tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [] = tack/*2*/ zs/*1:01*/ []; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (n/*1:001*/-1) (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = tack/*2*/ zs/*1:01*/ (take n/*1:001*/ xs/*1:1*/) {
+ rule #0: [] = tack zs []
+ rule #1: x:xs = tick (n-1) (x:zs) xs
+ rule #2: _ = tack zs (take n xs)
+ state 0: #0 #1 #2
<var> state 1
- <var>::int state 5
- state 1: #0 #3
+ [] state 2
+ <app> state 3
+ state 1: #2
+ state 2: #0 #2
+ state 3: #1 #2
+ <var> state 4
+ <app> state 6
+ state 4: #2
+ <var> state 5
+ state 5: #2
+ state 6: #1 #2
+ <var> state 7
+ : state 10
+ state 7: #2
+ <var> state 8
+ state 8: #2
+ <var> state 9
+ state 9: #2
+ state 10: #1 #2
+ <var> state 11
+ state 11: #1 #2
+ <var> state 12
+ state 12: #1 #2
+} end {
+ rule #0: tick n::int zs xs = tack zs [] if n<=0
+ rule #1: tick n::int zs xs = case xs of [] = tack zs []; x:xs = tick (n-1) (x:zs) xs; _ = tack zs (take n xs) end
+ state 0: #0 #1
+ <var>::int state 1
+ state 1: #0 #1
<var> state 2
- state 2: #0 #3
+ state 2: #0 #1
<var> state 3
- [] state 4
- state 3: #3
- state 4: #0 #3
- state 5: #0 #1 #2 #3
+ state 3: #0 #1
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
<var> state 6
- state 6: #0 #1 #2 #3
- <var> state 7
- [] state 8
- <app> state 9
- state 7: #1 #3
- state 8: #0 #1 #3
- state 9: #1 #2 #3
- <var> state 10
- <app> state 12
- state 10: #1 #3
- <var> state 11
- state 11: #1 #3
- state 12: #1 #2 #3
- <var> state 13
- : state 16
- state 13: #1 #3
- <var> state 14
- state 14: #1 #3
- <var> state 15
- state 15: #1 #3
- state 16: #1 #2 #3
- <var> state 17
- state 17: #1 #2 #3
- <var> state 18
- state 18: #1 #2 #3
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
takewhile p/*0:01*/ [] = [];
-takewhile p/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [] (x/*0:101*/:xs/*0:11*/) with accum ys/*0:01*/ [] = reverse ys/*0:01*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = accum/*1*/ (x/*0:101*/:ys/*0:01*/) xs/*0:11*/ if p/*1:01*/ x/*0:101*/; accum ys/*0:01*/ (x/*0:101*/:xs/*0:11*/) = reverse ys/*0:01*/; accum ys/*0:01*/ xs/*0:1*/ = reverse ys/*0:01*/+takewhile p/*1:01*/ xs/*0:1*/ {
- rule #0: accum ys [] = reverse ys
- rule #1: accum ys (x:xs) = accum (x:ys) xs if p x
- rule #2: accum ys (x:xs) = reverse ys
- rule #3: accum ys xs = reverse ys+takewhile p xs
+takewhile p/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ []; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (x/*0:101*/:zs/*0:01*/) xs/*0:11*/ if p/*1:01*/ x/*0:101*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ []; tick zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (takewhile p/*1:01*/ xs/*0:1*/) {
+ rule #0: tick zs [] = tack zs []
+ rule #1: tick zs (x:xs) = tick (x:zs) xs if p x
+ rule #2: tick zs (x:xs) = tack zs []
+ rule #3: tick zs xs = tack zs (takewhile p xs)
state 0: #0 #1 #2 #3
<var> state 1
state 1: #0 #1 #2 #3
@@ -608,74 +1040,113 @@
state 12: #1 #2 #3
<var> state 13
state 13: #1 #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
cat [] = [];
-cat [xs/*0:101*/] = xs/*0:101*/;
-cat (xs/*0:101*/:xss/*0:11*/) = accum/*0*/ (reverse xs/*0:101*/) xss/*0:11*/ with accum xs/*0:01*/ [] = reverse xs/*0:01*/; accum xs/*0:01*/ ([]:yss/*0:11*/) = accum/*1*/ xs/*0:01*/ yss/*0:11*/; accum xs/*0:01*/ ((y/*0:10101*/:ys/*0:1011*/):yss/*0:11*/) = accum/*1*/ (y/*0:10101*/:xs/*0:01*/) (ys/*0:1011*/:yss/*0:11*/); accum _/*0:01*/ (ys/*0:101*/:_/*0:11*/) = throw (bad_list_value ys/*0:101*/); accum _/*0:01*/ yss/*0:1*/ = throw (bad_list_value yss/*0:1*/) {
- rule #0: accum xs [] = reverse xs
- rule #1: accum xs ([]:yss) = accum xs yss
- rule #2: accum xs ((y:ys):yss) = accum (y:xs) (ys:yss)
- rule #3: accum _ (ys:_) = throw (bad_list_value ys)
- rule #4: accum _ yss = throw (bad_list_value yss)
- state 0: #0 #1 #2 #3 #4
+cat xs@(_/*0:101*/:_/*0:11*/) = foldr ((+/*0*/)) [] xs/*0:1*/ with []+ys/*0:1*/ = ys/*0:1*/; xs@(_/*0:0101*/:_/*0:011*/)+ys/*0:1*/ = tick/*1*/ [] xs/*0:01*/ ys/*0:1*/ {
+ rule #0: []+ys = ys
+ rule #1: xs@(_:_)+ys = tick [] xs ys
+ state 0: #0 #1
+ [] state 1
+ <app> state 3
+ state 1: #0
+ <var> state 2
+ state 2: #0
+ state 3: #1
+ <app> state 4
+ state 4: #1
+ : state 5
+ state 5: #1
+ <var> state 6
+ state 6: #1
+ <var> state 7
+ state 7: #1
+ <var> state 8
+ state 8: #1
+}; tick zs/*0:001*/ (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ (x/*0:0101*/:zs/*0:001*/) (xs/*1:011*/+/*2*/ys/*1:1*/&) if thunkp xs/*0:011*/; tick zs/*0:001*/ (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tick/*1*/ (x/*0:0101*/:zs/*0:001*/) xs/*0:011*/ ys/*0:1*/; tick zs/*0:001*/ [] ys/*0:1*/ = tack/*1*/ zs/*0:001*/ ys/*0:1*/; tick zs/*0:001*/ xs/*0:01*/ ys/*0:1*/ = tack/*1*/ zs/*0:001*/ (xs/*0:01*/+/*1*/ys/*0:1*/) {
+ rule #0: tick zs (x:xs) ys = tack (x:zs) (xs+ys&) if thunkp xs
+ rule #1: tick zs (x:xs) ys = tick (x:zs) xs ys
+ rule #2: tick zs [] ys = tack zs ys
+ rule #3: tick zs xs ys = tack zs (xs+ys)
+ state 0: #0 #1 #2 #3
<var> state 1
- state 1: #0 #1 #2 #3 #4
+ state 1: #0 #1 #2 #3
<var> state 2
- [] state 3
<app> state 4
- state 2: #4
- state 3: #0 #4
- state 4: #1 #2 #3 #4
+ [] state 17
+ state 2: #3
+ <var> state 3
+ state 3: #3
+ state 4: #0 #1 #3
<var> state 5
- <app> state 7
- state 5: #4
+ <app> state 8
+ state 5: #3
<var> state 6
- state 6: #4
- state 7: #1 #2 #3 #4
- <var> state 8
- : state 11
- state 8: #4
+ state 6: #3
+ <var> state 7
+ state 7: #3
+ state 8: #0 #1 #3
<var> state 9
- state 9: #4
+ : state 13
+ state 9: #3
<var> state 10
- state 10: #4
- state 11: #1 #2 #3 #4
+ state 10: #3
+ <var> state 11
+ state 11: #3
<var> state 12
- [] state 14
- <app> state 16
- state 12: #3 #4
- <var> state 13
- state 13: #3 #4
- state 14: #1 #3 #4
+ state 12: #3
+ state 13: #0 #1 #3
+ <var> state 14
+ state 14: #0 #1 #3
<var> state 15
- state 15: #1 #3 #4
- state 16: #2 #3 #4
- <var> state 17
- <app> state 20
- state 17: #3 #4
+ state 15: #0 #1 #3
+ <var> state 16
+ state 16: #0 #1 #3
+ state 17: #2 #3
<var> state 18
- state 18: #3 #4
- <var> state 19
- state 19: #3 #4
- state 20: #2 #3 #4
- <var> state 21
- : state 25
- state 21: #3 #4
- <var> state 22
- state 22: #3 #4
- <var> state 23
- state 23: #3 #4
- <var> state 24
- state 24: #3 #4
- state 25: #2 #3 #4
- <var> state 26
- state 26: #2 #3 #4
- <var> state 27
- state 27: #2 #3 #4
- <var> state 28
- state 28: #2 #3 #4
+ state 18: #2 #3
+}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
+ rule #0: tack (x:xs) ys = tack xs (x:ys)
+ rule #1: tack [] ys = ys
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
-catmap f/*0:01*/ xs/*0:1*/ = cat (map f/*0:01*/ xs/*0:1*/);
+catmap f/*0:01*/ [] = [];
+catmap f/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = cat (map f/*0:01*/ xs/*0:1*/);
index [] _/*0:1*/ = -1;
index (x/*0:0101*/:xs/*0:011*/) y/*0:1*/ = search/*0*/ 0 (x/*0:0101*/:xs/*0:011*/) with search _/*0:01*/ [] = -1; search n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = n/*0:01*/ if x/*0:101*/==y/*1:1*/; search n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = search/*1*/ (n/*0:01*/+1) xs/*0:11*/; search _/*0:01*/ xs/*0:1*/ = index xs/*0:1*/ y/*1:1*/ {
rule #0: search _ [] = -1
@@ -774,309 +1245,545 @@
<var> state 4
state 4: #0 #1
} end;
-zip xs/*0:01*/ ys/*0:1*/ = accum/*0*/ [] xs/*0:01*/ ys/*0:1*/ with accum us/*0:001*/ (x/*0:0101*/:xs/*0:011*/) (y/*0:101*/:ys/*0:11*/) = accum/*1*/ ((x/*0:0101*/,y/*0:101*/):us/*0:001*/) xs/*0:011*/ ys/*0:11*/; accum us/*0:001*/ _/*0:01*/ _/*0:1*/ = reverse us/*0:001*/ {
- rule #0: accum us (x:xs) (y:ys) = accum ((x,y):us) xs ys
- rule #1: accum us _ _ = reverse us
- state 0: #0 #1
+zip [] _/*0:1*/ = [];
+zip _/*0:01*/ [] = [];
+zip xs@(_/*0:0101*/:_/*0:011*/) ys@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:01*/ ys/*0:1*/ with tick us/*0:001*/ (x/*0:0101*/:xs/*0:011*/) (y/*0:101*/:ys/*0:11*/) = tack/*1*/ ((x/*0:0101*/,y/*0:101*/):us/*0:001*/) (zip xs/*1:011*/ ys/*1:11*/&) if thunkp xs/*0:011*/||thunkp ys/*0:11*/; tick us/*0:001*/ (x/*0:0101*/:xs/*0:011*/) (y/*0:101*/:ys/*0:11*/) = tick/*1*/ ((x/*0:0101*/,y/*0:101*/):us/*0:001*/) xs/*0:011*/ ys/*0:11*/; tick us/*0:001*/ [] _/*0:1*/ = tack/*1*/ us/*0:001*/ []; tick us/*0:001*/ _/*0:01*/ [] = tack/*1*/ us/*0:001*/ []; tick us/*0:001*/ xs/*0:01*/ ys/*0:1*/ = tack/*1*/ us/*0:001*/ (zip xs/*0:01*/ ys/*0:1*/) {
+ rule #0: tick us (x:xs) (y:ys) = tack ((x,y):us) (zip xs ys&) if thunkp xs||thunkp ys
+ rule #1: tick us (x:xs) (y:ys) = tick ((x,y):us) xs ys
+ rule #2: tick us [] _ = tack us []
+ rule #3: tick us _ [] = tack us []
+ rule #4: tick us xs ys = tack us (zip xs ys)
+ state 0: #0 #1 #2 #3 #4
<var> state 1
- state 1: #0 #1
+ state 1: #0 #1 #2 #3 #4
<var> state 2
- <app> state 4
- state 2: #1
+ <app> state 5
+ [] state 31
+ state 2: #3 #4
<var> state 3
- state 3: #1
- state 4: #0 #1
- <var> state 5
- <app> state 8
- state 5: #1
+ [] state 4
+ state 3: #4
+ state 4: #3 #4
+ state 5: #0 #1 #3 #4
<var> state 6
- state 6: #1
+ <app> state 10
+ state 6: #3 #4
<var> state 7
- state 7: #1
- state 8: #0 #1
- <var> state 9
- : state 13
- state 9: #1
- <var> state 10
- state 10: #1
+ state 7: #3 #4
+ <var> state 8
+ [] state 9
+ state 8: #4
+ state 9: #3 #4
+ state 10: #0 #1 #3 #4
<var> state 11
- state 11: #1
+ : state 16
+ state 11: #3 #4
<var> state 12
- state 12: #1
- state 13: #0 #1
+ state 12: #3 #4
+ <var> state 13
+ state 13: #3 #4
<var> state 14
- state 14: #0 #1
- <var> state 15
- state 15: #0 #1
- <var> state 16
- <app> state 17
- state 16: #1
- state 17: #0 #1
+ [] state 15
+ state 14: #4
+ state 15: #3 #4
+ state 16: #0 #1 #3 #4
+ <var> state 17
+ state 17: #0 #1 #3 #4
<var> state 18
+ state 18: #0 #1 #3 #4
+ <var> state 19
<app> state 20
- state 18: #1
- <var> state 19
- state 19: #1
- state 20: #0 #1
+ [] state 30
+ state 19: #4
+ state 20: #0 #1 #4
<var> state 21
- : state 24
- state 21: #1
+ <app> state 23
+ state 21: #4
<var> state 22
- state 22: #1
- <var> state 23
- state 23: #1
- state 24: #0 #1
+ state 22: #4
+ state 23: #0 #1 #4
+ <var> state 24
+ : state 27
+ state 24: #4
<var> state 25
- state 25: #0 #1
+ state 25: #4
<var> state 26
- state 26: #0 #1
+ state 26: #4
+ state 27: #0 #1 #4
+ <var> state 28
+ state 28: #0 #1 #4
+ <var> state 29
+ state 29: #0 #1 #4
+ state 30: #3 #4
+ state 31: #2 #3 #4
+ <var> state 32
+ [] state 33
+ state 32: #2 #4
+ state 33: #2 #3 #4
+}; tack (u/*0:0101*/:us/*0:011*/) vs/*0:1*/ = tack/*1*/ us/*0:011*/ (u/*0:0101*/:vs/*0:1*/); tack [] vs/*0:1*/ = vs/*0:1*/ {
+ rule #0: tack (u:us) vs = tack us (u:vs)
+ rule #1: tack [] vs = vs
+ state 0: #0 #1
+ <app> state 1
+ [] state 7
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ : state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+ <var> state 6
+ state 6: #0
+ state 7: #1
+ <var> state 8
+ state 8: #1
} end;
-zip3 xs/*0:001*/ ys/*0:01*/ zs/*0:1*/ = accum/*0*/ [] xs/*0:001*/ ys/*0:01*/ zs/*0:1*/ with accum us/*0:0001*/ (x/*0:00101*/:xs/*0:0011*/) (y/*0:0101*/:ys/*0:011*/) (z/*0:101*/:zs/*0:11*/) = accum/*1*/ ((x/*0:00101*/,y/*0:0101*/,z/*0:101*/):us/*0:0001*/) xs/*0:0011*/ ys/*0:011*/ zs/*0:11*/; accum us/*0:0001*/ _/*0:001*/ _/*0:01*/ _/*0:1*/ = reverse us/*0:0001*/ {
- rule #0: accum us (x:xs) (y:ys) (z:zs) = accum ((x,y,z):us) xs ys zs
- rule #1: accum us _ _ _ = reverse us
- state 0: #0 #1
+zip3 [] _/*0:01*/ _/*0:1*/ = [];
+zip3 _/*0:001*/ [] _/*0:1*/ = [];
+zip3 _/*0:001*/ _/*0:01*/ [] = [];
+zip3 xs@(_/*0:00101*/:_/*0:0011*/) ys@(_/*0:0101*/:_/*0:011*/) zs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:001*/ ys/*0:01*/ zs/*0:1*/ with tick us/*0:0001*/ (x/*0:00101*/:xs/*0:0011*/) (y/*0:0101*/:ys/*0:011*/) (z/*0:101*/:zs/*0:11*/) = tack/*1*/ ((x/*0:00101*/,y/*0:0101*/,z/*0:101*/):us/*0:0001*/) (zip3 xs/*1:0011*/ ys/*1:011*/ zs/*1:11*/&) if thunkp xs/*0:0011*/||thunkp ys/*0:011*/||thunkp zs/*0:11*/; tick us/*0:0001*/ (x/*0:00101*/:xs/*0:0011*/) (y/*0:0101*/:ys/*0:011*/) (z/*0:101*/:zs/*0:11*/) = tick/*1*/ ((x/*0:00101*/,y/*0:0101*/,z/*0:101*/):us/*0:0001*/) xs/*0:0011*/ ys/*0:011*/ zs/*0:11*/; tick us/*0:0001*/ [] _/*0:01*/ _/*0:1*/ = tack/*1*/ us/*0:0001*/ []; tick us/*0:0001*/ _/*0:001*/ [] _/*0:1*/ = tack/*1*/ us/*0:0001*/ []; tick us/*0:0001*/ _/*0:001*/ _/*0:01*/ [] = tack/*1*/ us/*0:0001*/ []; tick us/*0:0001*/ xs/*0:001*/ ys/*0:01*/ zs/*0:1*/ = tack/*1*/ us/*0:0001*/ (zip3 xs/*0:001*/ ys/*0:01*/ zs/*0:1*/) {
+ rule #0: tick us (x:xs) (y:ys) (z:zs) = tack ((x,y,z):us) (zip3 xs ys zs&) if thunkp xs||thunkp ys||thunkp zs
+ rule #1: tick us (x:xs) (y:ys) (z:zs) = tick ((x,y,z):us) xs ys zs
+ rule #2: tick us [] _ _ = tack us []
+ rule #3: tick us _ [] _ = tack us []
+ rule #4: tick us _ _ [] = tack us []
+ rule #5: tick us xs ys zs = tack us (zip3 xs ys zs)
+ state 0: #0 #1 #2 #3 #4 #5
<var> state 1
- state 1: #0 #1
+ state 1: #0 #1 #2 #3 #4 #5
<var> state 2
- <app> state 5
- state 2: #1
+ <app> state 9
+ [] state 63
+ state 2: #3 #4 #5
<var> st...
[truncated message content] |
|
From: <ag...@us...> - 2008-09-03 20:55:19
|
Revision: 690
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=690&view=rev
Author: agraef
Date: 2008-09-03 20:55:25 +0000 (Wed, 03 Sep 2008)
Log Message:
-----------
Overhaul of the list generator functions.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/lib/strings.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-03 14:25:55 UTC (rev 689)
+++ pure/trunk/lib/prelude.pure 2008-09-03 20:55:25 UTC (rev 690)
@@ -460,30 +460,32 @@
search _ xs = index xs y;
end;
-/* Some useful list generators. */
+/* Some useful (infinite) list generators. */
-repeat n::int x = accum [] n x with
+iterate f x = x : iterate f (f x)&;
+repeat x = x : repeat x&;
+cycle ys@(x:xs) = x : (xs+cycle ys)&;
+
+/* Some finite (and strict) generators. These work like the a combination of
+ takewhile/take and the above, but are implemented directly for maximum
+ efficiency. */
+
+while p f x = accum [] p f x with
+ accum xs p f x = accum (x:xs) p f (f x) if p x;
+ = reverse xs otherwise;
+ end;
+
+repeatn n::int x = accum [] n x with
accum xs n::int x = xs if n<=0;
= accum (x:xs) (n-1) x;
end;
-cycle n::int [] = [];
-cycle n::int (x:xs) = [] if n<=0;
+cyclen n::int (x:xs) = [] if n<=0;
= accum [] n with
accum ys n::int = cat ys+take n xs if n<=m;
= accum (xs:ys) (n-m) otherwise;
end when xs = x:xs; m::int = #xs end if listp xs;
-while p f a = accum [] p f a with
- accum as p f a = accum (a:as) p f (f a) if p a;
- = reverse as otherwise;
- end;
-
-until p f a = accum [] p f a with
- accum as p f a = reverse as if p a;
- = accum (a:as) p f (f a) otherwise;
- end;
-
/* zip, unzip and friends. */
zip [] _ |
Modified: pure/trunk/lib/strings.pure
===================================================================
--- pure/trunk/lib/strings.pure 2008-09-03 14:25:55 UTC (rev 689)
+++ pure/trunk/lib/strings.pure 2008-09-03 20:55:25 UTC (rev 690)
@@ -168,12 +168,8 @@
reverse s::string = strcat (reverse (chars s));
catmap f s::string = catmap f (chars s);
-cycle n::int "" = "";
-cycle n::int s::string = "" if n<=0;
- = accum [] n with
- accum ys n = strcat ys+take n s if n<=m;
- = accum (s:ys) (n-m) otherwise;
- end when m::int = #s end;
+cycle s::string = cycle (chars s);
+cyclen n::int s::string = cyclen n (chars s) if not null s;
all p s::string = all p (chars s);
any p s::string = any p (chars s);
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-03 14:25:55 UTC (rev 689)
+++ pure/trunk/test/prelude.log 2008-09-03 20:55:25 UTC (rev 690)
@@ -1187,7 +1187,23 @@
<var> state 16
state 16: #1 #2 #3
} end;
-repeat n/*0:01*/::int x/*0:1*/ = accum/*0*/ [] n/*0:01*/ x/*0:1*/ with accum xs/*0:001*/ n/*0:01*/::int x/*0:1*/ = xs/*0:001*/ if n/*0:01*/<=0; accum xs/*0:001*/ n/*0:01*/::int x/*0:1*/ = accum/*1*/ (x/*0:1*/:xs/*0:001*/) (n/*0:01*/-1) x/*0:1*/ {
+iterate f/*0:01*/ x/*0:1*/ = x/*0:1*/:iterate f/*1:01*/ (f/*1:01*/ x/*1:1*/)&;
+repeat x/*0:1*/ = x/*0:1*/:repeat x/*1:1*/&;
+cycle ys@(x/*0:101*/:xs/*0:11*/) = x/*0:101*/:(xs/*1:11*/+cycle ys/*1:1*/)&;
+while p/*0:001*/ f/*0:01*/ x/*0:1*/ = accum/*0*/ [] p/*0:001*/ f/*0:01*/ x/*0:1*/ with accum xs/*0:0001*/ p/*0:001*/ f/*0:01*/ x/*0:1*/ = accum/*1*/ (x/*0:1*/:xs/*0:0001*/) p/*0:001*/ f/*0:01*/ (f/*0:01*/ x/*0:1*/) if p/*0:001*/ x/*0:1*/; accum xs/*0:0001*/ p/*0:001*/ f/*0:01*/ x/*0:1*/ = reverse xs/*0:0001*/ {
+ rule #0: accum xs p f x = accum (x:xs) p f (f x) if p x
+ rule #1: accum xs p f x = reverse xs
+ state 0: #0 #1
+ <var> state 1
+ state 1: #0 #1
+ <var> state 2
+ state 2: #0 #1
+ <var> state 3
+ state 3: #0 #1
+ <var> state 4
+ state 4: #0 #1
+} end;
+repeatn n/*0:01*/::int x/*0:1*/ = accum/*0*/ [] n/*0:01*/ x/*0:1*/ with accum xs/*0:001*/ n/*0:01*/::int x/*0:1*/ = xs/*0:001*/ if n/*0:01*/<=0; accum xs/*0:001*/ n/*0:01*/::int x/*0:1*/ = accum/*1*/ (x/*0:1*/:xs/*0:001*/) (n/*0:01*/-1) x/*0:1*/ {
rule #0: accum xs n::int x = xs if n<=0
rule #1: accum xs n::int x = accum (x:xs) (n-1) x
state 0: #0 #1
@@ -1198,9 +1214,8 @@
<var> state 3
state 3: #0 #1
} end;
-cycle n/*0:01*/::int [] = [];
-cycle n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = [] if n/*0:01*/<=0;
-cycle n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [] n/*2:01*/ with accum ys/*0:01*/ n/*0:1*/::int = cat ys/*0:01*/+take n/*0:1*/ xs/*2:*/ if n/*0:1*/<=m/*1:*/; accum ys/*0:01*/ n/*0:1*/::int = accum/*1*/ (xs/*2:*/:ys/*0:01*/) (n/*0:1*/-m/*1:*/) {
+cyclen n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = [] if n/*0:01*/<=0;
+cyclen n/*0:01*/::int (x/*0:101*/:xs/*0:11*/) = accum/*0*/ [] n/*2:01*/ with accum ys/*0:01*/ n/*0:1*/::int = cat ys/*0:01*/+take n/*0:1*/ xs/*2:*/ if n/*0:1*/<=m/*1:*/; accum ys/*0:01*/ n/*0:1*/::int = accum/*1*/ (xs/*2:*/:ys/*0:01*/) (n/*0:1*/-m/*1:*/) {
rule #0: accum ys n::int = cat ys+take n xs if n<=m
rule #1: accum ys n::int = accum (xs:ys) (n-m)
state 0: #0 #1
@@ -1219,32 +1234,6 @@
<var> state 1
state 1: #0
} end if listp xs/*0:11*/;
-while p/*0:001*/ f/*0:01*/ a/*0:1*/ = accum/*0*/ [] p/*0:001*/ f/*0:01*/ a/*0:1*/ with accum as/*0:0001*/ p/*0:001*/ f/*0:01*/ a/*0:1*/ = accum/*1*/ (a/*0:1*/:as/*0:0001*/) p/*0:001*/ f/*0:01*/ (f/*0:01*/ a/*0:1*/) if p/*0:001*/ a/*0:1*/; accum as/*0:0001*/ p/*0:001*/ f/*0:01*/ a/*0:1*/ = reverse as/*0:0001*/ {
- rule #0: accum as p f a = accum (a:as) p f (f a) if p a
- rule #1: accum as p f a = reverse as
- state 0: #0 #1
- <var> state 1
- state 1: #0 #1
- <var> state 2
- state 2: #0 #1
- <var> state 3
- state 3: #0 #1
- <var> state 4
- state 4: #0 #1
-} end;
-until p/*0:001*/ f/*0:01*/ a/*0:1*/ = accum/*0*/ [] p/*0:001*/ f/*0:01*/ a/*0:1*/ with accum as/*0:0001*/ p/*0:001*/ f/*0:01*/ a/*0:1*/ = reverse as/*0:0001*/ if p/*0:001*/ a/*0:1*/; accum as/*0:0001*/ p/*0:001*/ f/*0:01*/ a/*0:1*/ = accum/*1*/ (a/*0:1*/:as/*0:0001*/) p/*0:001*/ f/*0:01*/ (f/*0:01*/ a/*0:1*/) {
- rule #0: accum as p f a = reverse as if p a
- rule #1: accum as p f a = accum (a:as) p f (f a)
- state 0: #0 #1
- <var> state 1
- state 1: #0 #1
- <var> state 2
- state 2: #0 #1
- <var> state 3
- state 3: #0 #1
- <var> state 4
- state 4: #0 #1
-} end;
zip [] _/*0:1*/ = [];
zip _/*0:01*/ [] = [];
zip xs@(_/*0:0101*/:_/*0:011*/) ys@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:01*/ ys/*0:1*/ with tick us/*0:001*/ (x/*0:0101*/:xs/*0:011*/) (y/*0:101*/:ys/*0:11*/) = tack/*1*/ ((x/*0:0101*/,y/*0:101*/):us/*0:001*/) (zip xs/*1:011*/ ys/*1:11*/&) if thunkp xs/*0:011*/||thunkp ys/*0:11*/; tick us/*0:001*/ (x/*0:0101*/:xs/*0:011*/) (y/*0:101*/:ys/*0:11*/) = tick/*1*/ ((x/*0:0101*/,y/*0:101*/):us/*0:001*/) xs/*0:011*/ ys/*0:11*/; tick us/*0:001*/ [] _/*0:1*/ = tack/*1*/ us/*0:001*/ []; tick us/*0:001*/ _/*0:01*/ [] = tack/*1*/ us/*0:001*/ []; tick us/*0:001*/ xs/*0:01*/ ys/*0:1*/ = tack/*1*/ us/*0:001*/ (zip xs/*0:01*/ ys/*0:1*/) {
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-03 21:20:34
|
Revision: 691
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=691&view=rev
Author: agraef
Date: 2008-09-03 21:20:42 +0000 (Wed, 03 Sep 2008)
Log Message:
-----------
Make take and takewhile less eager by checking for thunked tails in the input.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-03 20:55:25 UTC (rev 690)
+++ pure/trunk/lib/prelude.pure 2008-09-03 21:20:42 UTC (rev 691)
@@ -400,6 +400,7 @@
take n::int xs@(_:_) = tick n [] xs
with
tick n::int zs xs = tack zs [] if n<=0;
+ = tack zs (take n xs&) if thunkp xs;
= case xs of
[] = tack zs [];
x:xs = tick (n-1) (x:zs) xs;
@@ -412,10 +413,13 @@
takewhile p [] = [];
takewhile p xs@(_:_) = tick [] xs
with
- tick zs [] = tack zs [];
- tick zs (x:xs) = tick (x:zs) xs if p x;
- = tack zs [];
- tick zs xs = tack zs (takewhile p xs);
+ tick zs xs = tack zs (takewhile p xs&) if thunkp xs;
+ = case xs of
+ [] = tack zs [];
+ x:xs = tick (x:zs) xs if p x;
+ = tack zs [];
+ _ = tack zs (takewhile p xs);
+ end;
tack (x:xs) ys = tack xs (x:ys);
tack [] ys = ys;
end;
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-03 20:55:25 UTC (rev 690)
+++ pure/trunk/test/prelude.log 2008-09-03 21:20:42 UTC (rev 691)
@@ -947,7 +947,7 @@
} end;
tail (x/*0:101*/:xs/*0:11*/) = xs/*0:11*/;
take n/*0:01*/::int [] = [];
-take n/*0:01*/::int xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ n/*0:01*/ [] xs/*0:1*/ with tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ [] if n/*0:001*/<=0; tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [] = tack/*2*/ zs/*1:01*/ []; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (n/*1:001*/-1) (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = tack/*2*/ zs/*1:01*/ (take n/*1:001*/ xs/*1:1*/) {
+take n/*0:01*/::int xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ n/*0:01*/ [] xs/*0:1*/ with tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ [] if n/*0:001*/<=0; tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (take n/*1:001*/ xs/*1:1*/&) if thunkp xs/*0:1*/; tick n/*0:001*/::int zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [] = tack/*2*/ zs/*1:01*/ []; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (n/*1:001*/-1) (x/*0:01*/:zs/*1:01*/) xs/*0:1*/; _/*0:*/ = tack/*2*/ zs/*1:01*/ (take n/*1:001*/ xs/*1:1*/) {
rule #0: [] = tack zs []
rule #1: x:xs = tick (n-1) (x:zs) xs
rule #2: _ = tack zs (take n xs)
@@ -978,14 +978,15 @@
state 12: #1 #2
} end {
rule #0: tick n::int zs xs = tack zs [] if n<=0
- rule #1: tick n::int zs xs = case xs of [] = tack zs []; x:xs = tick (n-1) (x:zs) xs; _ = tack zs (take n xs) end
- state 0: #0 #1
+ rule #1: tick n::int zs xs = tack zs (take n xs&) if thunkp xs
+ rule #2: tick n::int zs xs = case xs of [] = tack zs []; x:xs = tick (n-1) (x:zs) xs; _ = tack zs (take n xs) end
+ state 0: #0 #1 #2
<var>::int state 1
- state 1: #0 #1
+ state 1: #0 #1 #2
<var> state 2
- state 2: #0 #1
+ state 2: #0 #1 #2
<var> state 3
- state 3: #0 #1
+ state 3: #0 #1 #2
}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
rule #0: tack (x:xs) ys = tack xs (x:ys)
rule #1: tack [] ys = ys
@@ -1008,38 +1009,44 @@
state 8: #1
} end;
takewhile p/*0:01*/ [] = [];
-takewhile p/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ [] = tack/*1*/ zs/*0:01*/ []; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tick/*1*/ (x/*0:101*/:zs/*0:01*/) xs/*0:11*/ if p/*1:01*/ x/*0:101*/; tick zs/*0:01*/ (x/*0:101*/:xs/*0:11*/) = tack/*1*/ zs/*0:01*/ []; tick zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (takewhile p/*1:01*/ xs/*0:1*/) {
- rule #0: tick zs [] = tack zs []
- rule #1: tick zs (x:xs) = tick (x:zs) xs if p x
- rule #2: tick zs (x:xs) = tack zs []
- rule #3: tick zs xs = tack zs (takewhile p xs)
+takewhile p/*0:01*/ xs@(_/*0:101*/:_/*0:11*/) = tick/*0*/ [] xs/*0:1*/ with tick zs/*0:01*/ xs/*0:1*/ = tack/*1*/ zs/*0:01*/ (takewhile p/*2:01*/ xs/*1:1*/&) if thunkp xs/*0:1*/; tick zs/*0:01*/ xs/*0:1*/ = case xs/*0:1*/ of [] = tack/*2*/ zs/*1:01*/ []; x/*0:01*/:xs/*0:1*/ = tick/*2*/ (x/*0:01*/:zs/*1:01*/) xs/*0:1*/ if p/*2:01*/ x/*0:01*/; x/*0:01*/:xs/*0:1*/ = tack/*2*/ zs/*1:01*/ []; _/*0:*/ = tack/*2*/ zs/*1:01*/ (takewhile p/*2:01*/ xs/*1:1*/) {
+ rule #0: [] = tack zs []
+ rule #1: x:xs = tick (x:zs) xs if p x
+ rule #2: x:xs = tack zs []
+ rule #3: _ = tack zs (takewhile p xs)
state 0: #0 #1 #2 #3
<var> state 1
- state 1: #0 #1 #2 #3
- <var> state 2
- [] state 3
- <app> state 4
- state 2: #3
- state 3: #0 #3
- state 4: #1 #2 #3
+ [] state 2
+ <app> state 3
+ state 1: #3
+ state 2: #0 #3
+ state 3: #1 #2 #3
+ <var> state 4
+ <app> state 6
+ state 4: #3
<var> state 5
- <app> state 7
state 5: #3
- <var> state 6
- state 6: #3
- state 7: #1 #2 #3
+ state 6: #1 #2 #3
+ <var> state 7
+ : state 10
+ state 7: #3
<var> state 8
- : state 11
state 8: #3
<var> state 9
state 9: #3
- <var> state 10
- state 10: #3
+ state 10: #1 #2 #3
+ <var> state 11
state 11: #1 #2 #3
<var> state 12
state 12: #1 #2 #3
- <var> state 13
- state 13: #1 #2 #3
+} end {
+ rule #0: tick zs xs = tack zs (takewhile p xs&) if thunkp xs
+ rule #1: tick zs xs = case xs of [] = tack zs []; x:xs = tick (x:zs) xs if p x; x:xs = tack zs []; _ = tack zs (takewhile p xs) end
+ state 0: #0 #1
+ <var> state 1
+ state 1: #0 #1
+ <var> state 2
+ state 2: #0 #1
}; tack (x/*0:0101*/:xs/*0:011*/) ys/*0:1*/ = tack/*1*/ xs/*0:011*/ (x/*0:0101*/:ys/*0:1*/); tack [] ys/*0:1*/ = ys/*0:1*/ {
rule #0: tack (x:xs) ys = tack xs (x:ys)
rule #1: tack [] ys = ys
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-03 21:47:46
|
Revision: 692
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=692&view=rev
Author: agraef
Date: 2008-09-03 21:47:54 +0000 (Wed, 03 Sep 2008)
Log Message:
-----------
Arithmetic sequences permit an infinite upper bound now.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-03 21:20:42 UTC (rev 691)
+++ pure/trunk/lib/prelude.pure 2008-09-03 21:47:54 UTC (rev 692)
@@ -248,9 +248,11 @@
infix 1 .. ;
-n1,n2..m = while (\i->s*i<=s*m) (\x->x+k) n1
+n1,n2..m = if m===s*inf then iterate (\x->x+k) n1
+ else while (\i->s*i<=s*m) (\x->x+k) n1
when k = n2-n1; s = if k>0 then 1 else -1 end if n1!=n2;
-n..m = while (\i->i<=m) (\x->x+1) n;
+n..m = if m===inf then iterate (\x->x+1) n
+ else while (\i->i<=m) (\x->x+1) n;
/* Common list functions. This mostly comes straight from the Q prelude which
in turn was based on the first edition of the Bird/Wadler book, and is very
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-03 21:20:42 UTC (rev 691)
+++ pure/trunk/test/prelude.log 2008-09-03 21:47:54 UTC (rev 692)
@@ -311,7 +311,12 @@
<var> state 2
state 2: #0
} end;
-n1/*0:0101*/,n2/*0:011*/..m/*0:1*/ = while (\i/*0:*/ -> s/*1:*/*i/*0:*/<=s/*1:*/*m/*3:1*/ {
+n1/*0:0101*/,n2/*0:011*/..m/*0:1*/ = if m/*2:1*/===s/*0:*/*(1e+307*1e+307) then iterate (\x/*0:*/ -> x/*0:*/+k/*2:*/ {
+ rule #0: x = x+k
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) n1/*2:0101*/ else while (\i/*0:*/ -> s/*1:*/*i/*0:*/<=s/*1:*/*m/*3:1*/ {
rule #0: i = s*i<=s*m
state 0: #0
<var> state 1
@@ -332,7 +337,12 @@
<var> state 1
state 1: #0
} end if n1/*0:0101*/!=n2/*0:011*/;
-n/*0:01*/..m/*0:1*/ = while (\i/*0:*/ -> i/*0:*/<=m/*1:1*/ {
+n/*0:01*/..m/*0:1*/ = if m/*0:1*/===1e+307*1e+307 then iterate (\x/*0:*/ -> x/*0:*/+1 {
+ rule #0: x = x+1
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}) n/*0:01*/ else while (\i/*0:*/ -> i/*0:*/<=m/*1:1*/ {
rule #0: i = i<=m
state 0: #0
<var> state 1
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-04 16:14:15
|
Revision: 703
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=703&view=rev
Author: agraef
Date: 2008-09-04 16:14:26 +0000 (Thu, 04 Sep 2008)
Log Message:
-----------
Prelude changes.
Modified Paths:
--------------
pure/trunk/lib/prelude.pure
pure/trunk/test/prelude.log
Modified: pure/trunk/lib/prelude.pure
===================================================================
--- pure/trunk/lib/prelude.pure 2008-09-04 16:13:51 UTC (rev 702)
+++ pure/trunk/lib/prelude.pure 2008-09-04 16:14:26 UTC (rev 703)
@@ -89,6 +89,10 @@
uncurry3 f (x,y,z)
= f x y z;
+/* The (normal order) fixed point combinator. */
+
+fix f = y y when y = \x -> f (x x&) end;
+
/* Some convenient optimization rules which eliminate saturated calls of the
function composition combinators. */
@@ -211,7 +215,7 @@
accum ys xs = throw (bad_list_value xs);
end;
-/* Convert between lists and tuples. */
+/* Conversions between lists, tuples and streams. */
list () = [];
list (x,xs) = accum [x] xs with
@@ -226,8 +230,6 @@
accum ys xs = ys,xs;
end;
-/* Convert between lists and streams. */
-
list [] = [];
list (x:xs) = x:list xs;
@@ -235,6 +237,9 @@
stream (x:xs) = x:xs if thunkp xs;
= x:stream xs& otherwise;
+stream () = [];
+stream xs@(_,_) = stream (list xs);
+
/* Slicing. xs!!ns returns the list of xs!n for all members n of the index
list ns which are in the valid index range. This is a generic definition
which will work with any kind of container data structure which defines (!)
Modified: pure/trunk/test/prelude.log
===================================================================
--- pure/trunk/test/prelude.log 2008-09-04 16:13:51 UTC (rev 702)
+++ pure/trunk/test/prelude.log 2008-09-04 16:14:26 UTC (rev 703)
@@ -9,6 +9,17 @@
curry3 f/*0:0001*/ x/*0:001*/ y/*0:01*/ z/*0:1*/ = f/*0:0001*/ (x/*0:001*/,y/*0:01*/,z/*0:1*/);
uncurry f/*0:01*/ (x/*0:101*/,y/*0:11*/) = f/*0:01*/ x/*0:101*/ y/*0:11*/;
uncurry3 f/*0:01*/ (x/*0:101*/,y/*0:1101*/,z/*0:111*/) = f/*0:01*/ x/*0:101*/ y/*0:1101*/ z/*0:111*/;
+fix f/*0:1*/ = y/*0:*/ y/*0:*/ when y/*0:*/ = \x/*0:*/ -> f/*1:1*/ (x/*1:*/ x/*1:*/&) {
+ rule #0: x = f (x x&)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+} {
+ rule #0: y = \x -> f (x x&)
+ state 0: #0
+ <var> state 1
+ state 1: #0
+} end;
def f/*0:01*/$x/*0:1*/ = f/*0:01*/ x/*0:1*/;
def (f/*0:001*/.g/*0:01*/) x/*0:1*/ = f/*0:001*/ (g/*0:01*/ x/*0:1*/);
def void (catmap f/*0:101*/ x/*0:11*/) = do f/*0:101*/ x/*0:11*/;
@@ -303,6 +314,8 @@
stream [] = [];
stream (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:xs/*0:11*/ if thunkp xs/*0:11*/;
stream (x/*0:101*/:xs/*0:11*/) = x/*0:101*/:stream xs/*1:11*/&;
+stream () = [];
+stream xs@(_/*0:101*/,_/*0:11*/) = stream (list xs/*0:1*/);
xs/*0:01*/!!ns/*0:1*/ = catmap (nth/*0*/ xs/*0:01*/) ns/*0:1*/ with nth xs/*0:01*/ n/*0:1*/ = catch (cst []) [xs/*1:01*/!n/*1:1*/] {
rule #0: nth xs n = catch (cst []) [xs!n]
state 0: #0
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-04 23:13:40
|
Revision: 705
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=705&view=rev
Author: agraef
Date: 2008-09-04 23:13:50 +0000 (Thu, 04 Sep 2008)
Log Message:
-----------
Renamed 'list' command to 'show'.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lexer.ll
pure/trunk/pure.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-04 23:01:42 UTC (rev 704)
+++ pure/trunk/ChangeLog 2008-09-04 23:13:50 UTC (rev 705)
@@ -1,3 +1,11 @@
+2008-09-05 Albert Graef <Dr....@t-...>
+
+ * pure.cc, lexer.ll: Renamed the interactive 'list' command to
+ 'show', as suggested by John Cowan. This hopefully puts an end to
+ inadvertent execution of that command, since 'show' is no prelude
+ function and is deemed less likely to be used as a function name
+ by the programmer.
+
2008-09-04 Albert Graef <Dr....@t-...>
* lib/prelude.pure: Added the normal order fixed point combinator,
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-09-04 23:01:42 UTC (rev 704)
+++ pure/trunk/lexer.ll 2008-09-04 23:13:50 UTC (rev 705)
@@ -133,8 +133,9 @@
static const char *commands[] = {
"cd", "clear", "const", "def", "extern", "help", "infix", "infixl",
- "infixr", "let", "list", "ls", "nullary", "override", "postfix", "prefix",
- "private", "pwd", "quit", "run", "save", "stats", "underride", "using", 0
+ "infixr", "let", "ls", "nullary", "override", "postfix", "prefix",
+ "private", "pwd", "quit", "run", "save", "show", "stats", "underride",
+ "using", 0
};
typedef map<string, symbol> symbol_map;
@@ -357,8 +358,8 @@
else if (chdir(args.l.begin()->c_str()))
perror("cd");
}
-^list.* {
- // list command is only permitted in interactive mode
+^show.* {
+ // show command is only permitted in interactive mode
if (!interp.interactive) REJECT;
uint8_t s_verbose = interpreter::g_verbose;
uint8_t tflag = 0; int pflag = -1;
@@ -368,7 +369,7 @@
const char *s = yytext+4;
if (*s && !isspace(*s)) REJECT;
yylloc->step();
- argl args(s, "list");
+ argl args(s, "show");
list<string>::iterator arg;
if (!args.ok) goto out;
// process option arguments
@@ -402,8 +403,8 @@
tflag = interp.temp;
break;
case 'h':
- cout << "list command help: list [options ...] [symbol ...]\n\
-Options may be combined, e.g., list -tvl is the same as list -t -v -l.\n\
+ cout << "show command help: show [options ...] [symbol ...]\n\
+Options may be combined, e.g., show -tvl is the same as show -t -v -l.\n\
-a Disassembles pattern matching automata. Useful for debugging purposes.\n\
-c Print information about defined constants.\n\
-d Disassembles LLVM IR, showing the generated LLVM assembler code of a\n\
@@ -427,7 +428,7 @@
-v Print information about defined variables.\n";
goto out;
default:
- cerr << "list: invalid option character '" << *s << "'\n";
+ cerr << "show: invalid option character '" << *s << "'\n";
goto out;
}
}
Modified: pure/trunk/pure.cc
===================================================================
--- pure/trunk/pure.cc 2008-09-04 23:01:42 UTC (rev 704)
+++ pure/trunk/pure.cc 2008-09-04 23:13:50 UTC (rev 705)
@@ -48,15 +48,16 @@
PURELIB Directory to search for library scripts and the prelude.\n\
PURE_INCLUDE Path to search for included source files.\n\
PURE_LIBRARY Path to search for dynamic libraries.\n\
-PURE_MORE Shell command for paging through output of the 'list' command.\n\
+PURE_MORE Shell command for paging through output of the 'show' command.\n\
PURE_PS Command prompt to be used in the interactive command loop.\n\
PURE_STACK Maximum stack size in kilobytes (default: 0 = unlimited).\n"
#define LICENSE "This program is free software distributed under the GNU Public License\n(GPL V3 or later). Please see the COPYING file for details.\n"
static const char *commands[] = {
"cd", "clear", "const", "def", "extern", "help", "infix", "infixl",
- "infixr", "let", "list", "ls", "nullary", "override", "postfix", "prefix",
- "private", "pwd", "quit", "run", "save", "stats", "underride", "using", 0
+ "infixr", "let", "ls", "nullary", "override", "postfix", "prefix",
+ "private", "pwd", "quit", "run", "save", "show", "stats", "underride",
+ "using", 0
};
/* Generator functions for command completion. */
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-05 00:59:11
|
Revision: 707
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=707&view=rev
Author: agraef
Date: 2008-09-05 00:59:21 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
Change print syntax of external objects, 2nd attempt.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/printer.cc
pure/trunk/test/test004.log
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 00:44:33 UTC (rev 706)
+++ pure/trunk/ChangeLog 2008-09-05 00:59:21 UTC (rev 707)
@@ -1,5 +1,10 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * printer.cc: Changed <<...>> syntax for "external" objects such
+ as closures, thunks and pointers to #<...> syntax pilfered from
+ Scheme. This is less likely to be mistaken for a valid Pure
+ expression.
+
* pure.cc, lexer.ll: Renamed the interactive 'list' command to
'show', as suggested by John Cowan. This hopefully puts an end to
inadvertent execution of that command, since 'show' is no prelude
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-05 00:44:33 UTC (rev 706)
+++ pure/trunk/printer.cc 2008-09-05 00:59:21 UTC (rev 707)
@@ -166,7 +166,7 @@
static ostream& printx(ostream& os, const expr& x, bool pat, bool aspat)
{
char buf[64];
- if (x.is_null()) return os << "{{NULL}}";
+ if (x.is_null()) return os << "#<NULL>";
//os << "{" << x.refc() << "}";
// handle "as" patterns
if (aspat && x.astag()>0) {
@@ -243,7 +243,7 @@
return os;
}
case EXPR::PTR:
- return os << "{{pointer " << x.pval() << "}}";
+ return os << "#<pointer " << x.pval() << ">";
case EXPR::APP: {
expr u, v, w, y;
exprl xs;
@@ -665,7 +665,7 @@
return os;
}
case EXPR::PTR:
- return os << "{{pointer " << x->data.p << "}}";
+ return os << "#<pointer " << x->data.p << ">";
case EXPR::APP: {
list<const pure_expr*> xs;
prec_t p;
@@ -760,11 +760,11 @@
default: {
if (x->tag == 0) {
const char *s = (x->data.clos && x->data.clos->n==0)?"thunk":"closure";
- return os << "{{" << s << " " << (void*)x << "}}";
+ return os << "#<" << s << " " << (void*)x << ">";
}
const symbol& sym = interpreter::g_interp->symtab.sym(x->tag);
if (x->data.clos && x->data.clos->local)
- return os << "{{closure " << sym.s << "}}";
+ return os << "#<closure " << sym.s << ">";
if (sym.prec < 10)
return os << '(' << sym.s << ')';
else
Modified: pure/trunk/test/test004.log
===================================================================
--- pure/trunk/test/test004.log 2008-09-05 00:44:33 UTC (rev 706)
+++ pure/trunk/test/test004.log 2008-09-05 00:59:21 UTC (rev 707)
@@ -35,15 +35,15 @@
foo 99;
99
foo2 99;
-{{closure bar}} 100
+#<closure bar> 100
foo2 98;
-{{closure bar}} 98
+#<closure bar> 98
foo3 99;
-{{closure bar}}
+#<closure bar>
foo3 99 98;
-{{closure bar}} 98
+#<closure bar> 98
foo3 99 99;
-{{closure bar}} 100
+#<closure bar> 100
loop = loop;
count n/*0:1*/ = ct/*0*/ n/*0:1*/ with ct n/*0:1*/::int = n/*0:1*/ if n/*0:1*/<=0; ct n/*0:1*/::int = ct/*1*/ (n/*0:1*/-1) {
rule #0: ct n::int = n if n<=0
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-05 02:01:32
|
Revision: 709
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=709&view=rev
Author: agraef
Date: 2008-09-05 02:01:42 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
Warn about used identifiers which are also interactive commands.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/lexer.ll
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 01:12:59 UTC (rev 708)
+++ pure/trunk/ChangeLog 2008-09-05 02:01:42 UTC (rev 709)
@@ -1,5 +1,8 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * lexer.ll: Warn about used identifiers which are also interactive
+ commands.
+
* printer.cc: Changed <<...>> syntax for "external" objects such
as closures, thunks and pointers to #<...> syntax pilfered from
Scheme. This is less likely to be mistaken for a valid Pure
Modified: pure/trunk/lexer.ll
===================================================================
--- pure/trunk/lexer.ll 2008-09-05 01:12:59 UTC (rev 708)
+++ pure/trunk/lexer.ll 2008-09-05 02:01:42 UTC (rev 709)
@@ -215,6 +215,27 @@
free(matches);
}
}
+
+static void check(const yy::location& l, const char* s)
+{
+ static set<string> done;
+ const char *name;
+ size_t i = 0;
+ while ((name = commands[i++]))
+ /* We warn about each identifier at most once. FIXME: We should also check
+ whether the interpreter is running in (global) interactive mode, but at
+ present this information isn't available before we actually enter the
+ interactive loop, when all source files from the command line have
+ already been processed. */
+ if (strcmp(name, s) == 0 && done.find(s) == done.end()) {
+ assert(interpreter::g_interp);
+ interpreter& interp = *interpreter::g_interp;
+ interp.warning(l, "warning: identifier '"+string(s)+
+ "' is also an interpreter command");
+ done.insert(s);
+ return;
+ }
+}
%}
%option noyywrap nounput debug
@@ -257,7 +278,7 @@
<comment>[\n]+ yylloc->lines(yyleng); yylloc->step();
<comment>"*"+"/" yylloc->step(); BEGIN(INITIAL);
-<xdecl>{id} yylval->sval = new string(yytext); return token::ID;
+<xdecl>{id} check(*yylloc, yytext); yylval->sval = new string(yytext); return token::ID;
<xdecl>[()*,=] return yy::parser::token_type(yytext[0]);
<xdecl>"//".* yylloc->step();
<xdecl>"/*" BEGIN(xdecl_comment);
@@ -275,7 +296,7 @@
<xdecl_comment>[\n]+ yylloc->lines(yyleng); yylloc->step();
<xdecl_comment>"*"+"/" yylloc->step(); BEGIN(xdecl);
-<xusing>{id} yylval->sval = new string(yytext); return token::ID;
+<xusing>{id} check(*yylloc, yytext); yylval->sval = new string(yytext); return token::ID;
<xusing>, return yy::parser::token_type(yytext[0]);
<xusing>"//".* yylloc->step();
<xusing>"/*" BEGIN(xusing_comment);
@@ -930,6 +951,7 @@
with return token::WITH;
using BEGIN(xusing); return token::USING;
{id} {
+ check(*yylloc, yytext);
if (interp.declare_op) {
yylval->sval = new string(yytext);
return token::ID;
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-05 09:38:35
|
Revision: 712
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=712&view=rev
Author: agraef
Date: 2008-09-05 09:38:43 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
Bugfixes.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/runtime.cc
Added Paths:
-----------
pure/trunk/test/test023.log
pure/trunk/test/test023.pure
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 02:15:43 UTC (rev 711)
+++ pure/trunk/ChangeLog 2008-09-05 09:38:43 UTC (rev 712)
@@ -1,5 +1,8 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * runtime.cc (pure_force): Fix a rather obscure segfault in the
+ thunk implementation. See also test/test023.pure.
+
* lexer.ll: Warn about used identifiers which are also interactive
commands.
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-05 02:15:43 UTC (rev 711)
+++ pure/trunk/runtime.cc 2008-09-05 09:38:43 UTC (rev 712)
@@ -1438,6 +1438,7 @@
// that recursively
if (ret->tag == 0 && ret->data.clos && ret->data.clos->n == 0)
ret = pure_force(pure_new_internal(ret));
+ pure_new_internal(ret);
// memoize the result
assert(x!=ret);
pure_free_clos(x);
@@ -1458,7 +1459,7 @@
x->data.clos = pure_copy_clos(x->data.clos);
break;
}
- pure_freenew(ret);
+ pure_free_internal(ret);
return x;
} else {
#if DEBUG>2
Added: pure/trunk/test/test023.log
===================================================================
--- pure/trunk/test/test023.log (rev 0)
+++ pure/trunk/test/test023.log 2008-09-05 09:38:43 UTC (rev 712)
@@ -0,0 +1,47 @@
+odd x/*0:1*/ = x/*0:1*/ mod 2;
+{
+ rule #0: odd x = x mod 2
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+{
+ rule #0: x = 1..1e+307*1e+307
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let x = 1..1e+307*1e+307;
+{
+ rule #0: y = filter odd x
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let y = filter odd x;
+{
+ rule #0: z = zip x y
+ state 0: #0
+ <var> state 1
+ state 1: #0
+}
+let z = zip x y;
+{
+ rule #0: u,v = unzip z
+ state 0: #0
+ <app> state 1
+ state 1: #0
+ <app> state 2
+ state 2: #0
+ , state 3
+ state 3: #0
+ <var> state 4
+ state 4: #0
+ <var> state 5
+ state 5: #0
+}
+let u,v = unzip z;
+list (take 10 u);
+[1,2,3,4,5,6,7,8,9,10]
+list (take 10 v);
+[1,3,5,7,9,11,13,15,17,19]
Added: pure/trunk/test/test023.pure
===================================================================
--- pure/trunk/test/test023.pure (rev 0)
+++ pure/trunk/test/test023.pure 2008-09-05 09:38:43 UTC (rev 712)
@@ -0,0 +1,9 @@
+// thunk regression test (cf. r712)
+
+odd x = x mod 2;
+
+let x = 1..inf; let y = filter odd x; let z = zip x y;
+let u,v = unzip z;
+
+list (take 10 u);
+list (take 10 v);
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-05 11:13:27
|
Revision: 717
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=717&view=rev
Author: agraef
Date: 2008-09-05 11:13:38 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
Add configure checks for POSIX/ISOC99 complex types.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/config.h.in
pure/trunk/configure
pure/trunk/configure.ac
pure/trunk/runtime.cc
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 11:08:32 UTC (rev 716)
+++ pure/trunk/ChangeLog 2008-09-05 11:13:38 UTC (rev 717)
@@ -1,5 +1,8 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * configure.ac, runtime.cc (pure_sys_vars): Add configure checks
+ for POSIX/ISOC99 complex types. (Requires reconfigure.)
+
* runtime.cc (pure_force): Fix a rather obscure segfault in the
thunk implementation. See also test/test023.pure.
Modified: pure/trunk/config.h.in
===================================================================
--- pure/trunk/config.h.in 2008-09-05 11:08:32 UTC (rev 716)
+++ pure/trunk/config.h.in 2008-09-05 11:13:38 UTC (rev 717)
@@ -78,6 +78,12 @@
/* Define to 1 if you have the `usleep' function. */
#undef HAVE_USLEEP
+/* Define to 1 if the system has the type `_Complex double'. */
+#undef HAVE__COMPLEX_DOUBLE
+
+/* Define to 1 if the system has the type `_Complex float'. */
+#undef HAVE__COMPLEX_FLOAT
+
/* Define to the name of the host system. */
#undef HOST
Modified: pure/trunk/configure
===================================================================
--- pure/trunk/configure 2008-09-05 11:08:32 UTC (rev 716)
+++ pure/trunk/configure 2008-09-05 11:13:38 UTC (rev 717)
@@ -5472,6 +5472,129 @@
fi
done
+{ echo "$as_me:$LINENO: checking for _Complex float" >&5
+echo $ECHO_N "checking for _Complex float... $ECHO_C" >&6; }
+if test "${ac_cv_type__Complex_float+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+typedef _Complex float ac__type_new_;
+int
+main ()
+{
+if ((ac__type_new_ *) 0)
+ return 0;
+if (sizeof (ac__type_new_))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_type__Complex_float=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_type__Complex_float=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_type__Complex_float" >&5
+echo "${ECHO_T}$ac_cv_type__Complex_float" >&6; }
+if test $ac_cv_type__Complex_float = yes; then
+
+cat >>confdefs.h <<_ACEOF
+#define HAVE__COMPLEX_FLOAT 1
+_ACEOF
+
+
+fi
+{ echo "$as_me:$LINENO: checking for _Complex double" >&5
+echo $ECHO_N "checking for _Complex double... $ECHO_C" >&6; }
+if test "${ac_cv_type__Complex_double+set}" = set; then
+ echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+ cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h. */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h. */
+$ac_includes_default
+typedef _Complex double ac__type_new_;
+int
+main ()
+{
+if ((ac__type_new_ *) 0)
+ return 0;
+if (sizeof (ac__type_new_))
+ return 0;
+ ;
+ return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (ac_try="$ac_compile"
+case "(($ac_try" in
+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;
+ *) ac_try_echo=$ac_try;;
+esac
+eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5
+ (eval "$ac_compile") 2>conftest.er1
+ ac_status=$?
+ grep -v '^ *+' conftest.er1 >conftest.err
+ rm -f conftest.er1
+ cat conftest.err >&5
+ echo "$as_me:$LINENO: \$? = $ac_status" >&5
+ (exit $ac_status); } && {
+ test -z "$ac_c_werror_flag" ||
+ test ! -s conftest.err
+ } && test -s conftest.$ac_objext; then
+ ac_cv_type__Complex_double=yes
+else
+ echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ ac_cv_type__Complex_double=no
+fi
+
+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
+fi
+{ echo "$as_me:$LINENO: result: $ac_cv_type__Complex_double" >&5
+echo "${ECHO_T}$ac_cv_type__Complex_double" >&6; }
+if test $ac_cv_type__Complex_double = yes; then
+
+cat >>confdefs.h <<_ACEOF
+#define HAVE__COMPLEX_DOUBLE 1
+_ACEOF
+
+
+fi
+
ac_config_files="$ac_config_files Makefile"
cat >confcache <<\_ACEOF
Modified: pure/trunk/configure.ac
===================================================================
--- pure/trunk/configure.ac 2008-09-05 11:08:32 UTC (rev 716)
+++ pure/trunk/configure.ac 2008-09-05 11:13:38 UTC (rev 717)
@@ -91,6 +91,8 @@
AC_FUNC_ALLOCA
dnl Platform-dependent time functions.
AC_CHECK_FUNCS(ftime gettimeofday nanosleep usleep)
+dnl Check to see whether we have POSIX/ISOC99 complex numbers.
+AC_CHECK_TYPES([_Complex float, _Complex double])
AC_CONFIG_FILES([Makefile])
AC_OUTPUT
Modified: pure/trunk/runtime.cc
===================================================================
--- pure/trunk/runtime.cc 2008-09-05 11:08:32 UTC (rev 716)
+++ pure/trunk/runtime.cc 2008-09-05 11:13:38 UTC (rev 717)
@@ -3263,8 +3263,12 @@
cdf(interp, "SIZEOF_LONG_LONG", pure_int(sizeof(long long)));
cdf(interp, "SIZEOF_FLOAT", pure_int(sizeof(float)));
cdf(interp, "SIZEOF_DOUBLE", pure_int(sizeof(double)));
+#ifdef HAVE__COMPLEX_FLOAT
cdf(interp, "SIZEOF_COMPLEX_FLOAT", pure_int(sizeof(_Complex float)));
+#endif
+#ifdef HAVE__COMPLEX_DOUBLE
cdf(interp, "SIZEOF_COMPLEX_DOUBLE", pure_int(sizeof(_Complex double)));
+#endif
cdf(interp, "SIZEOF_POINTER", pure_int(sizeof(void*)));
// clock
cdf(interp, "CLOCKS_PER_SEC", pure_int(CLOCKS_PER_SEC));
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
|
From: <ag...@us...> - 2008-09-05 13:40:37
|
Revision: 719
http://pure-lang.svn.sourceforge.net/pure-lang/?rev=719&view=rev
Author: agraef
Date: 2008-09-05 13:40:46 +0000 (Fri, 05 Sep 2008)
Log Message:
-----------
User can now override print representations of expressions at runtime via the __show__ function.
Modified Paths:
--------------
pure/trunk/ChangeLog
pure/trunk/printer.cc
pure/trunk/symtable.cc
pure/trunk/symtable.hh
Modified: pure/trunk/ChangeLog
===================================================================
--- pure/trunk/ChangeLog 2008-09-05 12:11:50 UTC (rev 718)
+++ pure/trunk/ChangeLog 2008-09-05 13:40:46 UTC (rev 719)
@@ -1,5 +1,9 @@
2008-09-05 Albert Graef <Dr....@t-...>
+ * printer.cc (operator << (ostream& os, const pure_expr *x)):
+ Experimental support for calling a user-defined __show__ function
+ to override print representations of expressions at runtime.
+
* configure.ac, runtime.cc (pure_sys_vars): Add configure checks
for POSIX/ISOC99 complex types. (Requires reconfigure.)
Modified: pure/trunk/printer.cc
===================================================================
--- pure/trunk/printer.cc 2008-09-05 12:11:50 UTC (rev 718)
+++ pure/trunk/printer.cc 2008-09-05 13:40:46 UTC (rev 719)
@@ -622,6 +622,28 @@
return os << p.x;
}
+static inline bool pstr(ostream& os, pure_expr *x)
+{
+ interpreter& interp = *interpreter::g_interp;
+ int32_t f = interp.symtab.__show__sym;
+ if (f > 0 && interp.globenv.find(f) != interp.globenv.end()) {
+ assert(x->refc > 0);
+ pure_expr *y = pure_app(pure_symbol(f), x);
+ assert(y);
+ if (y->tag == EXPR::STR) {
+ char *s = fromutf8(y->data.s);
+ pure_freenew(y);
+ if (s) {
+ os << s; free(s);
+ return true;
+ } else
+ return false;
+ } else
+ return false;
+ } else
+ return false;
+}
+
ostream& operator << (ostream& os, const pure_expr *x)
{
char test;
@@ -631,6 +653,7 @@
throw err("stack overflow in printer");
char buf[64];
assert(x);
+ if (pstr(os, (pure_expr*)x)) return os;
//os << "{" << x->refc << "}";
switch (x->tag) {
case EXPR::INT:
Modified: pure/trunk/symtable.cc
===================================================================
--- pure/trunk/symtable.cc 2008-09-05 12:11:50 UTC (rev 718)
+++ pure/trunk/symtable.cc 2008-09-05 13:40:46 UTC (rev 719)
@@ -2,7 +2,7 @@
#include "symtable.hh"
#include <assert.h>
-symtable::symtable() : fno(0), rtab(1024)
+symtable::symtable() : fno(0), rtab(1024), __show__sym(0)
{
// enter any predefined symbols here, e.g.:
//sym("-", 6, infixl);
@@ -72,6 +72,7 @@
_sym = symbol(s, fno, modno);
//cout << "new symbol " << _sym.f << ": " << _sym.s << endl;
rtab[fno] = &_sym;
+ if (__show__sym == 0 && s == "__show__") __show__sym = fno;
}
return _sym;
}
@@ -88,6 +89,7 @@
_sym = symbol(s, fno, prec, fix, modno);
//cout << "new symbol " << _sym.f << ": " << _sym.s << endl;
rtab[fno] = &_sym;
+ if (__show__sym == 0 && s == "__show__") __show__sym = fno;
}
return _sym;
}
@@ -125,6 +127,7 @@
_sym = symbol(s, fno, prec, fix, modno);
//cout << "new symbol " << _sym.f << ": " << _sym.s << endl;
rtab[fno] = &_sym;
+ if (__show__sym == 0 && s == "__show__") __show__sym = fno;
}
return _sym;
}
Modified: pure/trunk/symtable.hh
===================================================================
--- pure/trunk/symtable.hh 2008-09-05 12:11:50 UTC (rev 718)
+++ pure/trunk/symtable.hh 2008-09-05 13:40:46 UTC (rev 719)
@@ -63,6 +63,7 @@
// get a symbol by its number
symbol& sym(int32_t f);
// retrieve various builtin symbols (create when necessary)
+ int32_t __show__sym; // This is cached here to improve performance.
symbol& nil_sym();
symbol& cons_sym();
symbol& void_sym();
This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.
|
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X