From 7c898bd553146f67a585d9df603454a5575d2a08 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 12:30:11 -0400 Subject: [PATCH 01/82] Eliminate redundant unique5 lookup for poker hands --- extra/poker/poker.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/extra/poker/poker.factor b/extra/poker/poker.factor index 2a7fe73762..e8e9fa23c5 100644 --- a/extra/poker/poker.factor +++ b/extra/poker/poker.factor @@ -117,9 +117,6 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" : lookup ( cards table -- value ) [ rank-bits ] dip nth ; -: unique5? ( cards -- ? ) - unique5-table lookup 0 > ; - : map-product ( seq quot -- n ) [ 1 ] 2dip [ dip * ] curry [ swap ] prepose each ; inline @@ -138,11 +135,11 @@ CONSTANT: VALUE_STR { "" "Straight Flush" "Four of a Kind" "Full House" "Flush" bitxor values-table nth ; : hand-value ( cards -- value ) - { - { [ dup flush? ] [ flushes-table lookup ] } - { [ dup unique5? ] [ unique5-table lookup ] } - [ prime-bits perfect-hash-find ] - } cond ; + dup flush? [ flushes-table lookup ] [ + dup unique5-table lookup dup 0 > [ nip ] [ + drop prime-bits perfect-hash-find + ] if + ] if ; : >card-rank ( card -- str ) -8 shift HEX: F bitand RANK_STR nth ; From 01677ada51c65d392df4ab61cb011644eaa08acc Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 8 Apr 2009 18:15:24 -0400 Subject: [PATCH 02/82] Remove unnecessary helper word after refactoring --- extra/project-euler/069/069.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/069/069.factor b/extra/project-euler/069/069.factor index eae1d82ece..3a59d66522 100644 --- a/extra/project-euler/069/069.factor +++ b/extra/project-euler/069/069.factor @@ -69,12 +69,9 @@ PRIVATE> [ nth-prime primes-upto ] } cond product ; -: (primorial-upto) ( count limit -- m ) - '[ dup primorial _ <= ] [ 1+ dup primorial ] produce - nip penultimate ; - : primorial-upto ( limit -- m ) - 1 swap (primorial-upto) ; + 1 swap '[ dup primorial _ <= ] [ 1+ dup primorial ] produce + nip penultimate ; PRIVATE> From e4ce05f73bdfcdfa2f9fc1b13eeb0a9e1b3f215e Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 19 Apr 2009 13:01:02 -0400 Subject: [PATCH 03/82] Additional solution to PE problem 1 from IRC --- extra/project-euler/001/001-tests.factor | 1 + extra/project-euler/001/001.factor | 16 ++++++++++++---- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor index 1cab275619..32a72dfaf0 100644 --- a/extra/project-euler/001/001-tests.factor +++ b/extra/project-euler/001/001-tests.factor @@ -5,3 +5,4 @@ IN: project-euler.001.tests [ 233168 ] [ euler001a ] unit-test [ 233168 ] [ euler001b ] unit-test [ 233168 ] [ euler001c ] unit-test +[ 233168 ] [ euler001d ] unit-test diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor index 20e08242c5..0d4f5fb1bd 100644 --- a/extra/project-euler/001/001.factor +++ b/extra/project-euler/001/001.factor @@ -1,6 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.ranges sequences project-euler.common ; +USING: kernel math math.functions math.ranges project-euler.common sequences + sets ; IN: project-euler.001 ! http://projecteuler.net/index.php?section=problems&id=1 @@ -32,7 +33,7 @@ PRIVATE> 999 15 sum-divisible-by - ; ! [ euler001 ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.0 SD (100 trials) ! ALTERNATE SOLUTIONS @@ -42,14 +43,14 @@ PRIVATE> 0 999 3 sum 0 999 5 sum + 0 999 15 sum - ; ! [ euler001a ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.03 SD (100 trials) : euler001b ( -- answer ) 1000 [ [ 5 mod ] [ 3 mod ] bi [ 0 = ] either? ] filter sum ; ! [ euler001b ] 100 ave-time -! 0 ms run / 0 ms GC ave time - 100 trials +! 0 ms ave run time - 0.06 SD (100 trials) : euler001c ( -- answer ) @@ -58,4 +59,11 @@ PRIVATE> ! [ euler001c ] 100 ave-time ! 0 ms ave run time - 0.06 SD (100 trials) + +: euler001d ( -- answer ) + { 3 5 } [ [ 999 ] keep ] gather sum ; + +! [ euler001d ] 100 ave-time +! 0 ms ave run time - 0.08 SD (100 trials) + SOLUTION: euler001 From e8d695e3144d3c589f6a4475585fbf8cdf5adcca Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 20 Apr 2009 19:01:33 -0500 Subject: [PATCH 04/82] refactoring directory searching --- basis/io/directories/search/search.factor | 39 +++++++++++++---------- 1 file changed, 22 insertions(+), 17 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 236da09489..1346fbbdb8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs ; +sorting assocs calendar threads ; IN: io.directories.search > + ] each-file ; + 0 swap t [ + [ link-info size-on-disk>> + ] [ 2drop ] recover + ] each-file ; + +: path>usage ( directory-entry -- name size ) + [ name>> dup ] [ directory? ] bi [ + directory-size + ] [ + [ link-info size-on-disk>> ] [ drop 0 ] recover + ] if ; : directory-usage ( path -- assoc ) [ - [ - [ name>> dup ] [ directory? ] bi [ - directory-size - ] [ - link-info size-on-disk>> - ] if - ] { } map>assoc + [ [ path>usage ] [ drop name>> 0 ] recover ] { } map>assoc ] with-qualified-directory-entries sort-values ; os windows? [ "io.directories.search.windows" require ] when From 19be5cd5e55d3dc5653e3d66e46b0f4c001d2481 Mon Sep 17 00:00:00 2001 From: "U-HPLAPTOP\\Ken" Date: Mon, 20 Apr 2009 21:06:42 -0500 Subject: [PATCH 05/82] word change --- basis/help/cookbook/cookbook.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor index 9bb76f8d5a..cd26c6856e 100644 --- a/basis/help/cookbook/cookbook.factor +++ b/basis/help/cookbook/cookbook.factor @@ -67,7 +67,7 @@ $nl } "In Factor, this example will print 3 since word redefinition is explicitly supported." $nl - "Indeed, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." + "However, redefining a word twice in the same source file is an error; this is almost always a mistake since there's no way to call the first definition. See " { $link "definition-checking" } "." } { $references { "A whole slew of shuffle words can be used to rearrange the stack. There are forms of word definition other than colon definition, words can be defined entirely at runtime, and word definitions can be " { $emphasis "annotated" } " with tracing calls and breakpoints without modifying the source code." } From 7095ace2c1044615fed09422e8c540ec8a8328b0 Mon Sep 17 00:00:00 2001 From: Ken Causey Date: Mon, 20 Apr 2009 22:11:01 -0500 Subject: [PATCH 06/82] Makes it possible to change the names of the exectables named in the variables at the top of the Makefile and still build. Also removes unused IMAGE variable. --- Makefile | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 35a5ba58bf..db99120a77 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,6 @@ CONSOLE_EXECUTABLE = factor-console TEST_LIBRARY = factor-ffi-test VERSION = 0.92 -IMAGE = factor.image BUNDLE = Factor.app LIBPATH = -L/usr/X11R6/lib CFLAGS = -Wall @@ -151,17 +150,17 @@ macosx.app: factor @executable_path/../Frameworks/libfactor.dylib \ Factor.app/Contents/MacOS/factor -factor: $(DLL_OBJS) $(EXE_OBJS) +$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) -factor-console: $(DLL_OBJS) $(EXE_OBJS) +$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS) $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS) -factor-ffi-test: vm/ffi_test.o +$(TEST_LIBRARY): vm/ffi_test.o $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS) clean: From 6c38831c4813391b2ff380df925e60bc41a2b286 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 21 Apr 2009 18:29:06 -0400 Subject: [PATCH 07/82] Improve license owner phrasing and in-file copyright notices --- basis/tools/scaffold/scaffold.factor | 11 ++++++----- license.txt | 3 +++ 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index f35da24266..6f7cb25ab9 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2008 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. +! Copyright (c) 2008 Doug Coleman. All rights reserved. +! This software is licensed under the Simplified BSD License. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,9 +79,10 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (C) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write "." print - "! See http://factorcode.org/license.txt for BSD license." print ; + "! Copyright (c) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write + ". All rights reserved." print + "! This software is licensed under the Simplified BSD License." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index e9cd58a5e4..3310ddc18f 100644 --- a/license.txt +++ b/license.txt @@ -1,3 +1,6 @@ +Copyright (c) 2003-2009, Slava Pestov and contributing authors +All rights reserved. + Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From 25cc5a409ae3fc6d8f26cf3e21b28923834fcf6a Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 22 Apr 2009 00:20:53 -0400 Subject: [PATCH 08/82] Revert "Improve license owner phrasing and in-file copyright notices" This reverts commit 6c38831c4813391b2ff380df925e60bc41a2b286. --- basis/tools/scaffold/scaffold.factor | 11 +++++------ license.txt | 3 --- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 6f7cb25ab9..f35da24266 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -1,5 +1,5 @@ -! Copyright (c) 2008 Doug Coleman. All rights reserved. -! This software is licensed under the Simplified BSD License. +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: assocs io.files io.pathnames io.directories io.encodings.utf8 hashtables kernel namespaces sequences vocabs.loader io combinators calendar accessors math.parser @@ -79,10 +79,9 @@ ERROR: no-vocab vocab ; dup exists? [ not-scaffolding f ] [ scaffolding t ] if ; : scaffold-copyright ( -- ) - "! Copyright (c) " write now year>> number>string write - developer-name get [ "Your name" ] unless* bl write - ". All rights reserved." print - "! This software is licensed under the Simplified BSD License." print ; + "! Copyright (C) " write now year>> number>string write + developer-name get [ "Your name" ] unless* bl write "." print + "! See http://factorcode.org/license.txt for BSD license." print ; : main-file-string ( vocab -- string ) [ diff --git a/license.txt b/license.txt index 3310ddc18f..e9cd58a5e4 100644 --- a/license.txt +++ b/license.txt @@ -1,6 +1,3 @@ -Copyright (c) 2003-2009, Slava Pestov and contributing authors -All rights reserved. - Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: From b075f20d806210c115930298aafc0a9e2b23c19b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 06:50:09 -0500 Subject: [PATCH 09/82] Move multi-methods, and vocabs that depend on them (dns, shell, newfx). Multi methods won't be in Factor 1.0 and I don't want to keep maintaining this feature --- {extra => unmaintained}/boolean-expr/authors.txt | 0 {extra => unmaintained}/boolean-expr/boolean-expr.factor | 0 {extra => unmaintained}/boolean-expr/summary.txt | 0 {extra => unmaintained}/boolean-expr/tags.txt | 0 {extra => unmaintained}/dns/cache/nx/nx.factor | 0 {extra => unmaintained}/dns/cache/rr/rr.factor | 0 {extra => unmaintained}/dns/dns.factor | 0 {extra => unmaintained}/dns/forwarding/forwarding.factor | 0 {extra => unmaintained}/dns/misc/misc.factor | 0 {extra => unmaintained}/dns/resolver/resolver.factor | 0 {extra => unmaintained}/dns/server/server.factor | 0 {extra => unmaintained}/dns/stub/stub.factor | 0 {extra => unmaintained}/dns/util/util.factor | 0 {extra => unmaintained}/multi-methods/authors.txt | 0 {extra => unmaintained}/multi-methods/multi-methods.factor | 0 {extra => unmaintained}/multi-methods/summary.txt | 0 {extra => unmaintained}/multi-methods/tags.txt | 0 {extra => unmaintained}/multi-methods/tests/canonicalize.factor | 0 {extra => unmaintained}/multi-methods/tests/definitions.factor | 0 {extra => unmaintained}/multi-methods/tests/legacy.factor | 0 {extra => unmaintained}/multi-methods/tests/syntax.factor | 0 .../multi-methods/tests/topological-sort.factor | 0 {extra => unmaintained}/shell/parser/parser.factor | 0 {extra => unmaintained}/shell/shell.factor | 0 24 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/boolean-expr/authors.txt (100%) rename {extra => unmaintained}/boolean-expr/boolean-expr.factor (100%) rename {extra => unmaintained}/boolean-expr/summary.txt (100%) rename {extra => unmaintained}/boolean-expr/tags.txt (100%) rename {extra => unmaintained}/dns/cache/nx/nx.factor (100%) rename {extra => unmaintained}/dns/cache/rr/rr.factor (100%) rename {extra => unmaintained}/dns/dns.factor (100%) rename {extra => unmaintained}/dns/forwarding/forwarding.factor (100%) rename {extra => unmaintained}/dns/misc/misc.factor (100%) rename {extra => unmaintained}/dns/resolver/resolver.factor (100%) rename {extra => unmaintained}/dns/server/server.factor (100%) rename {extra => unmaintained}/dns/stub/stub.factor (100%) rename {extra => unmaintained}/dns/util/util.factor (100%) rename {extra => unmaintained}/multi-methods/authors.txt (100%) rename {extra => unmaintained}/multi-methods/multi-methods.factor (100%) rename {extra => unmaintained}/multi-methods/summary.txt (100%) rename {extra => unmaintained}/multi-methods/tags.txt (100%) rename {extra => unmaintained}/multi-methods/tests/canonicalize.factor (100%) rename {extra => unmaintained}/multi-methods/tests/definitions.factor (100%) rename {extra => unmaintained}/multi-methods/tests/legacy.factor (100%) rename {extra => unmaintained}/multi-methods/tests/syntax.factor (100%) rename {extra => unmaintained}/multi-methods/tests/topological-sort.factor (100%) rename {extra => unmaintained}/shell/parser/parser.factor (100%) rename {extra => unmaintained}/shell/shell.factor (100%) diff --git a/extra/boolean-expr/authors.txt b/unmaintained/boolean-expr/authors.txt similarity index 100% rename from extra/boolean-expr/authors.txt rename to unmaintained/boolean-expr/authors.txt diff --git a/extra/boolean-expr/boolean-expr.factor b/unmaintained/boolean-expr/boolean-expr.factor similarity index 100% rename from extra/boolean-expr/boolean-expr.factor rename to unmaintained/boolean-expr/boolean-expr.factor diff --git a/extra/boolean-expr/summary.txt b/unmaintained/boolean-expr/summary.txt similarity index 100% rename from extra/boolean-expr/summary.txt rename to unmaintained/boolean-expr/summary.txt diff --git a/extra/boolean-expr/tags.txt b/unmaintained/boolean-expr/tags.txt similarity index 100% rename from extra/boolean-expr/tags.txt rename to unmaintained/boolean-expr/tags.txt diff --git a/extra/dns/cache/nx/nx.factor b/unmaintained/dns/cache/nx/nx.factor similarity index 100% rename from extra/dns/cache/nx/nx.factor rename to unmaintained/dns/cache/nx/nx.factor diff --git a/extra/dns/cache/rr/rr.factor b/unmaintained/dns/cache/rr/rr.factor similarity index 100% rename from extra/dns/cache/rr/rr.factor rename to unmaintained/dns/cache/rr/rr.factor diff --git a/extra/dns/dns.factor b/unmaintained/dns/dns.factor similarity index 100% rename from extra/dns/dns.factor rename to unmaintained/dns/dns.factor diff --git a/extra/dns/forwarding/forwarding.factor b/unmaintained/dns/forwarding/forwarding.factor similarity index 100% rename from extra/dns/forwarding/forwarding.factor rename to unmaintained/dns/forwarding/forwarding.factor diff --git a/extra/dns/misc/misc.factor b/unmaintained/dns/misc/misc.factor similarity index 100% rename from extra/dns/misc/misc.factor rename to unmaintained/dns/misc/misc.factor diff --git a/extra/dns/resolver/resolver.factor b/unmaintained/dns/resolver/resolver.factor similarity index 100% rename from extra/dns/resolver/resolver.factor rename to unmaintained/dns/resolver/resolver.factor diff --git a/extra/dns/server/server.factor b/unmaintained/dns/server/server.factor similarity index 100% rename from extra/dns/server/server.factor rename to unmaintained/dns/server/server.factor diff --git a/extra/dns/stub/stub.factor b/unmaintained/dns/stub/stub.factor similarity index 100% rename from extra/dns/stub/stub.factor rename to unmaintained/dns/stub/stub.factor diff --git a/extra/dns/util/util.factor b/unmaintained/dns/util/util.factor similarity index 100% rename from extra/dns/util/util.factor rename to unmaintained/dns/util/util.factor diff --git a/extra/multi-methods/authors.txt b/unmaintained/multi-methods/authors.txt similarity index 100% rename from extra/multi-methods/authors.txt rename to unmaintained/multi-methods/authors.txt diff --git a/extra/multi-methods/multi-methods.factor b/unmaintained/multi-methods/multi-methods.factor similarity index 100% rename from extra/multi-methods/multi-methods.factor rename to unmaintained/multi-methods/multi-methods.factor diff --git a/extra/multi-methods/summary.txt b/unmaintained/multi-methods/summary.txt similarity index 100% rename from extra/multi-methods/summary.txt rename to unmaintained/multi-methods/summary.txt diff --git a/extra/multi-methods/tags.txt b/unmaintained/multi-methods/tags.txt similarity index 100% rename from extra/multi-methods/tags.txt rename to unmaintained/multi-methods/tags.txt diff --git a/extra/multi-methods/tests/canonicalize.factor b/unmaintained/multi-methods/tests/canonicalize.factor similarity index 100% rename from extra/multi-methods/tests/canonicalize.factor rename to unmaintained/multi-methods/tests/canonicalize.factor diff --git a/extra/multi-methods/tests/definitions.factor b/unmaintained/multi-methods/tests/definitions.factor similarity index 100% rename from extra/multi-methods/tests/definitions.factor rename to unmaintained/multi-methods/tests/definitions.factor diff --git a/extra/multi-methods/tests/legacy.factor b/unmaintained/multi-methods/tests/legacy.factor similarity index 100% rename from extra/multi-methods/tests/legacy.factor rename to unmaintained/multi-methods/tests/legacy.factor diff --git a/extra/multi-methods/tests/syntax.factor b/unmaintained/multi-methods/tests/syntax.factor similarity index 100% rename from extra/multi-methods/tests/syntax.factor rename to unmaintained/multi-methods/tests/syntax.factor diff --git a/extra/multi-methods/tests/topological-sort.factor b/unmaintained/multi-methods/tests/topological-sort.factor similarity index 100% rename from extra/multi-methods/tests/topological-sort.factor rename to unmaintained/multi-methods/tests/topological-sort.factor diff --git a/extra/shell/parser/parser.factor b/unmaintained/shell/parser/parser.factor similarity index 100% rename from extra/shell/parser/parser.factor rename to unmaintained/shell/parser/parser.factor diff --git a/extra/shell/shell.factor b/unmaintained/shell/shell.factor similarity index 100% rename from extra/shell/shell.factor rename to unmaintained/shell/shell.factor From f4f99036ca2173720fc9338dcc7ea30ec45852d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:04:15 -0500 Subject: [PATCH 10/82] Move lint to unmaintained --- {extra => unmaintained}/lint/authors.txt | 0 {extra => unmaintained}/lint/lint-tests.factor | 0 {extra => unmaintained}/lint/lint.factor | 0 {extra => unmaintained}/lint/summary.txt | 0 4 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/lint/authors.txt (100%) rename {extra => unmaintained}/lint/lint-tests.factor (100%) rename {extra => unmaintained}/lint/lint.factor (100%) rename {extra => unmaintained}/lint/summary.txt (100%) diff --git a/extra/lint/authors.txt b/unmaintained/lint/authors.txt similarity index 100% rename from extra/lint/authors.txt rename to unmaintained/lint/authors.txt diff --git a/extra/lint/lint-tests.factor b/unmaintained/lint/lint-tests.factor similarity index 100% rename from extra/lint/lint-tests.factor rename to unmaintained/lint/lint-tests.factor diff --git a/extra/lint/lint.factor b/unmaintained/lint/lint.factor similarity index 100% rename from extra/lint/lint.factor rename to unmaintained/lint/lint.factor diff --git a/extra/lint/summary.txt b/unmaintained/lint/summary.txt similarity index 100% rename from extra/lint/summary.txt rename to unmaintained/lint/summary.txt From 3353a777f76da28cf25f7835225a3bd144613b13 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:05:00 -0500 Subject: [PATCH 11/82] Fixing some unit test failures --- .../format/macros/macros-tests.factor | 2 +- basis/combinators/smart/smart-tests.factor | 2 +- .../cpu/ppc/assembler/assembler-tests.factor | 2 -- basis/debugger/debugger-tests.factor | 3 +++ basis/help/markup/markup-tests.factor | 2 +- basis/math/intervals/intervals-tests.factor | 4 +-- basis/peg/ebnf/ebnf-tests.factor | 2 -- basis/peg/peg-tests.factor | 2 -- basis/regexp/parser/parser-tests.factor | 2 +- basis/tools/crossref/crossref-tests.factor | 2 +- basis/tools/crossref/crossref.factor | 25 ++++++++++++++--- basis/tools/profiler/profiler-tests.factor | 2 +- basis/unicode/breaks/breaks-tests.factor | 2 +- .../unicode/collation/collation-tests.factor | 5 ++-- .../unicode/normalize/normalize-tests.factor | 2 -- basis/windows/com/wrapper/wrapper.factor | 2 +- core/continuations/continuations-tests.factor | 12 ++++----- core/kernel/kernel-tests.factor | 27 ++++++++++++------- core/parser/parser-tests.factor | 3 ++- .../client/internals/internals-tests.factor | 2 +- 20 files changed, 62 insertions(+), 43 deletions(-) diff --git a/basis/calendar/format/macros/macros-tests.factor b/basis/calendar/format/macros/macros-tests.factor index 48567539ad..4ba2872b43 100644 --- a/basis/calendar/format/macros/macros-tests.factor +++ b/basis/calendar/format/macros/macros-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test kernel ; +USING: tools.test kernel accessors ; IN: calendar.format.macros [ 2 ] [ { [ 2 ] } attempt-all-quots ] unit-test diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 080379e924..a18ef1f3b8 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test combinators.smart math kernel ; +USING: tools.test combinators.smart math kernel accessors ; IN: combinators.smart.tests : test-bi ( -- 9 11 ) diff --git a/basis/cpu/ppc/assembler/assembler-tests.factor b/basis/cpu/ppc/assembler/assembler-tests.factor index f35a5cfca8..09db4cb050 100644 --- a/basis/cpu/ppc/assembler/assembler-tests.factor +++ b/basis/cpu/ppc/assembler/assembler-tests.factor @@ -114,5 +114,3 @@ make vocabs sequences ; { HEX: fc411800 } [ 1 2 3 FCMPU ] test-assembler { HEX: fc411840 } [ 1 2 3 FCMPO ] test-assembler { HEX: 3c601234 HEX: 60635678 } [ HEX: 12345678 3 LOAD ] test-assembler - -"cpu.ppc.assembler" words [ must-infer ] each diff --git a/basis/debugger/debugger-tests.factor b/basis/debugger/debugger-tests.factor index afa4aa1c28..08f84d9335 100644 --- a/basis/debugger/debugger-tests.factor +++ b/basis/debugger/debugger-tests.factor @@ -2,3 +2,6 @@ IN: debugger.tests USING: debugger kernel continuations tools.test ; [ ] [ [ drop ] [ error. ] recover ] unit-test + +[ f ] [ { } vm-error? ] unit-test +[ f ] [ { "A" "B" } vm-error? ] unit-test \ No newline at end of file diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor index bcd8843b24..93bed37a55 100644 --- a/basis/help/markup/markup-tests.factor +++ b/basis/help/markup/markup-tests.factor @@ -5,7 +5,7 @@ IN: help.markup.tests TUPLE: blahblah quux ; -[ "an int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test +[ "int" ] [ [ { "int" } $instance ] with-string-writer ] unit-test [ ] [ \ quux>> print-topic ] unit-test [ ] [ \ >>quux print-topic ] unit-test diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 8b43456901..2b8b3dff24 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -302,8 +302,8 @@ IN: math.intervals.tests : comparison-test ( -- ? ) random-interval random-interval random-comparison - [ [ [ random-element ] bi@ ] dip first execute ] 3keep - second execute dup incomparable eq? [ 2drop t ] [ = ] if ; + [ [ [ random-element ] bi@ ] dip first execute( a b -- ? ) ] 3keep + second execute( a b -- ? ) dup incomparable eq? [ 2drop t ] [ = ] if ; [ t ] [ 40000 iota [ drop comparison-test ] all? ] unit-test diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor index 58102cffc3..329156d733 100644 --- a/basis/peg/ebnf/ebnf-tests.factor +++ b/basis/peg/ebnf/ebnf-tests.factor @@ -300,8 +300,6 @@ main = Primary "x[i][j].y" primary ] unit-test -'ebnf' compile must-infer - { V{ V{ "a" "b" } "c" } } [ "abc" [EBNF a="a" "b" foo=(a "c") EBNF] ] unit-test diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 9a15dd2105..683fa328d8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -206,5 +206,3 @@ USE: compiler [ ] [ enable-compiler ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test - -[ [ ] ] [ "" epsilon [ drop [ [ ] ] ] action [ call ] action parse ] unit-test \ No newline at end of file diff --git a/basis/regexp/parser/parser-tests.factor b/basis/regexp/parser/parser-tests.factor index 0e12014eef..5ea9753fba 100644 --- a/basis/regexp/parser/parser-tests.factor +++ b/basis/regexp/parser/parser-tests.factor @@ -4,7 +4,7 @@ IN: regexp.parser.tests : regexp-parses ( string -- ) [ [ ] ] dip '[ _ parse-regexp drop ] unit-test ; -: regexp-fails ( string -- regexp ) +: regexp-fails ( string -- ) '[ _ parse-regexp ] must-fail ; { diff --git a/basis/tools/crossref/crossref-tests.factor b/basis/tools/crossref/crossref-tests.factor index 26c6c4e597..80f5367fb6 100755 --- a/basis/tools/crossref/crossref-tests.factor +++ b/basis/tools/crossref/crossref-tests.factor @@ -1,6 +1,6 @@ USING: math kernel sequences io.files io.pathnames tools.crossref tools.test parser namespaces source-files generic -definitions ; +definitions words accessors compiler.units ; IN: tools.crossref.tests GENERIC: foo ( a b -- c ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index feaddc8194..c5cd246f2e 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -13,30 +13,47 @@ GENERIC: uses ( defspec -- seq ) alist ] dip (seq-uses) + ] if ; M: array quot-uses seq-uses ; -M: hashtable quot-uses [ >alist ] dip seq-uses ; +M: hashtable quot-uses assoc-uses ; M: callable quot-uses seq-uses ; M: wrapper quot-uses [ wrapped>> ] dip quot-uses ; M: callable uses ( quot -- assoc ) - H{ } clone [ quot-uses ] keep keys ; + V{ } clone visited [ + H{ } clone [ quot-uses ] keep keys + ] with-variable ; M: word uses def>> uses ; M: link uses { $subsection $link $see-also } article-links ; -M: pathname uses string>> source-file top-level-form>> uses ; +M: pathname uses string>> source-file top-level-form>> [ uses ] [ { } ] if* ; GENERIC: crossref-def ( defspec -- ) diff --git a/basis/tools/profiler/profiler-tests.factor b/basis/tools/profiler/profiler-tests.factor index 0bd3663729..d2e605ecdc 100644 --- a/basis/tools/profiler/profiler-tests.factor +++ b/basis/tools/profiler/profiler-tests.factor @@ -34,7 +34,7 @@ words ; [ 1 ] [ \ foobar counter>> ] unit-test -: fooblah ( -- ) { } [ ] like call ; +: fooblah ( -- ) { } [ ] like call( -- ) ; : foobaz ( -- ) fooblah fooblah ; diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor index 3a26b01213..6d6d4233f5 100644 --- a/basis/unicode/breaks/breaks-tests.factor +++ b/basis/unicode/breaks/breaks-tests.factor @@ -32,7 +32,7 @@ IN: unicode.breaks.tests [ concat [ quot call [ "" like ] map ] curry ] bi unit-test ] each ; -: grapheme-test ( tests quot -- ) +: grapheme-test ( tests -- ) [ [ 1quotation ] [ concat [ >graphemes [ "" like ] map ] curry ] bi unit-test diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index f53a1382ae..fdeb721e65 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -11,9 +11,10 @@ IN: unicode.collation.tests : test-two ( str1 str2 -- ) [ +lt+ ] -rot [ string<=> ] 2curry unit-test ; -: test-equality ( str1 str2 -- ) +: test-equality ( str1 str2 -- ? ? ? ? ) { primary= secondary= tertiary= quaternary= } - [ execute ] with with each ; + [ execute( a b -- ? ) ] with with map + first4 ; [ f f f f ] [ "hello" "hi" test-equality ] unit-test [ t f f f ] [ "hello" "h\u0000e9llo" test-equality ] unit-test diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index f774016272..cea880c0b0 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,8 +3,6 @@ simple-flat-file io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests -{ nfc nfkc nfd nfkd } [ must-infer ] each - [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index a014a56ea0..e78c987cd4 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as malloc-byte-array ; + [ execute( -- callback ) ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 391b87a44f..f4eeeefb77 100644 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -50,21 +50,19 @@ IN: continuations.tests gc ] unit-test -[ f ] [ { } kernel-error? ] unit-test -[ f ] [ { "A" "B" } kernel-error? ] unit-test - ! ! See how well callstack overflow is handled ! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; ! [ callstack-overflow ] must-fail -: don't-compile-me ( n -- ) { } [ ] each ; - -: foo ( -- ) callstack "c" set 3 don't-compile-me ; +: don't-compile-me ( -- ) ; +: foo ( -- ) callstack "c" set don't-compile-me ; : bar ( -- a b ) 1 foo 2 ; -[ 1 3 2 ] [ bar ] unit-test +<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> + +[ 1 2 ] [ bar ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-quot = ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index 84a356805b..b58c744b05 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,7 +1,7 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations continuations prettyprint io.streams.string debugger assocs -sequences.private accessors locals.backend grouping ; +sequences.private accessors locals.backend grouping words ; IN: kernel.tests [ 0 ] [ f size ] unit-test @@ -23,20 +23,25 @@ IN: kernel.tests : overflow-d ( -- ) 3 overflow-d ; -[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with - -[ ] [ :c ] unit-test - : (overflow-d-alt) ( -- n ) 3 ; : overflow-d-alt ( -- ) (overflow-d-alt) overflow-d-alt ; +: overflow-r ( -- ) 3 load-local overflow-r ; + +<< +{ overflow-d (overflow-d-alt) overflow-d-alt overflow-r } +[ t "no-compile" set-word-prop ] each +>> + +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with + +[ ] [ :c ] unit-test + [ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] with-string-writer drop ] unit-test -: overflow-r ( -- ) 3 load-local overflow-r ; - [ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -99,7 +104,9 @@ IN: kernel.tests [ ] [ :c ] unit-test ! Doesn't compile; important -: foo ( a -- b ) 5 + 0 [ ] each ; +: foo ( a -- b ) ; + +<< \ foo t "no-compile" set-word-prop >> [ drop foo ] must-fail [ ] [ :c ] unit-test @@ -109,13 +116,13 @@ IN: kernel.tests [ pick ] dip swap [ pick ] dip swap < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive -: loop ( obj obj -- ) +: loop ( obj -- ) H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; [ loop ] must-fail ! Discovered on Windows -: total-failure-1 ( -- ) "" [ ] map unimplemented ; +: total-failure-1 ( -- a ) "" [ ] map unimplemented ; [ total-failure-1 ] must-fail diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index a8a57ccdaa..e944ecc6f2 100644 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -3,7 +3,8 @@ io.streams.string namespaces classes effects source-files assocs sequences strings io.files io.pathnames definitions continuations sorting classes.tuple compiler.units debugger vocabs vocabs.loader accessors eval combinators lexer -vocabs.parser words.symbol multiline source-files.errors ; +vocabs.parser words.symbol multiline source-files.errors +tools.crossref ; IN: parser.tests [ diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index d20ae50bcc..27b5648f97 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/extra/irc/client/internals/internals-tests.factor @@ -41,7 +41,7 @@ M: mb-writer dispose drop ; : %pop-output-line ( -- string ) irc> stream>> out>> lines>> pop ; : read-matching-message ( chat quot: ( msg -- ? ) -- irc-message ) - [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; + [ in-messages>> 0.1 seconds ] dip mailbox-get-timeout? ; inline : spawning-irc ( quot: ( -- ) -- ) [ spawn-client ] dip [ (terminate-irc) ] compose with-irc ; inline From 91cd13d2d626428722745cd51933a845a4e8fce3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 07:07:24 -0500 Subject: [PATCH 12/82] mason.test: collect compiler errors at the very end of the process, to catch errors in unit test files --- extra/mason/test/test.factor | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/extra/mason/test/test.factor b/extra/mason/test/test.factor index 912fbaa17a..22b932ac5b 100644 --- a/extra/mason/test/test.factor +++ b/extra/mason/test/test.factor @@ -25,12 +25,6 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ file>> ] map prune natural-sort summary-file to-file errors details-file utf8 [ errors. ] with-file-writer ; -: do-compile-errors ( -- ) - compiler-errors get values - compiler-errors-file - compiler-error-messages-file - do-step ; - : do-tests ( -- ) test-all test-failures get test-all-vocabs-file @@ -50,6 +44,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; [ benchmark-error-messages-file utf8 [ benchmark-errors. ] with-file-writer ] bi ] bi* ; +: do-compile-errors ( -- ) + compiler-errors get values + compiler-errors-file + compiler-error-messages-file + do-step ; + : benchmark-ms ( quot -- ms ) benchmark 1000 /i ; inline @@ -66,11 +66,12 @@ M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ; ".." [ bootstrap-time get boot-time-file to-file check-boot-image - [ do-load do-compile-errors ] benchmark-ms load-time-file to-file + [ do-load ] benchmark-ms load-time-file to-file [ generate-help ] benchmark-ms html-help-time-file to-file [ do-tests ] benchmark-ms test-time-file to-file [ do-help-lint ] benchmark-ms help-lint-time-file to-file [ do-benchmarks ] benchmark-ms benchmark-time-file to-file + do-compile-errors ] with-directory ; MAIN: do-all \ No newline at end of file From cd91b2e755cc42649f7837078c4df81eb8368eb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 10:46:50 -0500 Subject: [PATCH 13/82] tools.errors: fix printing of errors with no associated source file --- basis/tools/errors/errors-tests.factor | 20 ++++++++++++++++++++ basis/tools/errors/errors.factor | 6 ++++-- basis/ui/tools/error-list/error-list.factor | 10 +++++----- 3 files changed, 29 insertions(+), 7 deletions(-) create mode 100644 basis/tools/errors/errors-tests.factor diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor new file mode 100644 index 0000000000..a70aa32be8 --- /dev/null +++ b/basis/tools/errors/errors-tests.factor @@ -0,0 +1,20 @@ +USING: compiler.errors stack-checker.errors tools.test words ; +IN: tools.errors + +DEFER: blah + +[ ] [ + { + T{ compiler-error + { error + T{ inference-error + f + T{ do-not-compile f blah } + +compiler-error+ + blah + } + } + { asset blah } + } + } errors. +] unit-test \ No newline at end of file diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index 422e08f020..ae55e9a1da 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -14,9 +14,11 @@ M: source-file-error compute-restarts M: source-file-error error-help error>> error-help ; +CONSTANT: +listener-input+ "" + M: source-file-error summary [ - [ file>> [ % ": " % ] [ "" % ] if* ] + [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi ] "" make ; @@ -27,7 +29,7 @@ M: source-file-error error. : errors. ( errors -- ) group-by-source-file sort-errors [ - [ nl "==== " write print nl ] + [ nl "==== " write +listener-input+ or print nl ] [ [ nl ] [ error. ] interleave ] bi* ] assoc-each ; diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 42863a8fd2..5a4fb7376a 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger namespaces -summary locals ui ui.commands ui.gadgets ui.gadgets.panes +models.arrow.smart models.search models.mapping models.delay debugger +namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs -ui.gadgets.labels ui.baseline-alignment ui.images -compiler.errors calendar ; +ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener +compiler.errors calendar tools.errors ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -39,7 +39,7 @@ SINGLETON: source-file-renderer M: source-file-renderer row-columns drop first2 [ [ source-file-icon ] - [ "" or ] + [ +listener-input+ or ] [ length number>string ] tri* ] output>array ; From 367ec5de939d44ab6bf00d7c166cb3f1cb9f12f5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 11:54:59 -0500 Subject: [PATCH 14/82] newfx => unmaintained since it uses multi-methods --- {extra => unmaintained}/newfx/newfx.factor | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/newfx/newfx.factor (100%) diff --git a/extra/newfx/newfx.factor b/unmaintained/newfx/newfx.factor similarity index 100% rename from extra/newfx/newfx.factor rename to unmaintained/newfx/newfx.factor From 7f983f12d46ac9bafc82c089699d46cde6a56aa0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Apr 2009 12:26:28 -0500 Subject: [PATCH 15/82] fix help lint failures, fix example in words --- basis/compiler/tree/builder/builder-docs.factor | 4 ++-- basis/tools/crossref/crossref-docs.factor | 4 ++-- core/words/words-docs.factor | 6 ++++-- 3 files changed, 8 insertions(+), 6 deletions(-) diff --git a/basis/compiler/tree/builder/builder-docs.factor b/basis/compiler/tree/builder/builder-docs.factor index 3fa576faf5..b7ee51834b 100644 --- a/basis/compiler/tree/builder/builder-docs.factor +++ b/basis/compiler/tree/builder/builder-docs.factor @@ -3,11 +3,11 @@ compiler.tree stack-checker.errors ; IN: compiler.tree.builder HELP: build-tree -{ $values { "quot/word" { $or quotation word } } { "nodes" "a sequence of nodes" } } +{ $values { "word/quot" { $or word quotation } } { "nodes" "a sequence of nodes" } } { $description "Attempts to construct tree SSA IR from a quotation." } { $notes "This is the first stage of the compiler." } { $errors "Throws an " { $link inference-error } " if stack effect inference fails." } ; HELP: build-sub-tree -{ $values { "#call" #call } { "quot/word" { $or quotation word } } { "nodes" { $maybe "a sequence of nodes" } } } +{ $values { "#call" #call } { "word/quot" { $or word quotation } } { "nodes/f" { $maybe "a sequence of nodes" } } } { $description "Attempts to construct tree SSA IR from a quotation, starting with an initial data stack of values from the call site. Outputs " { $link f } " if stack effect inference fails." } ; diff --git a/basis/tools/crossref/crossref-docs.factor b/basis/tools/crossref/crossref-docs.factor index 99d1257f31..9108777554 100644 --- a/basis/tools/crossref/crossref-docs.factor +++ b/basis/tools/crossref/crossref-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax words definitions prettyprint -tools.crossref.private math quotations assocs ; +tools.crossref.private math quotations assocs kernel ; IN: tools.crossref ARTICLE: "tools.crossref" "Definition cross referencing" @@ -51,7 +51,7 @@ HELP: usage. { $examples { $code "\\ reverse usage." } } ; HELP: quot-uses -{ $values { "quot" quotation } { "assoc" "an assoc with words as keys" } } +{ $values { "obj" object } { "assoc" "an assoc with words as keys" } } { $description "Outputs a set of words referenced by the quotation and any quotations it contains." } ; { usage usage. } related-words diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index c1b8c0c229..58cc3c4f49 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -160,11 +160,13 @@ ABOUT: "words" HELP: execute ( word -- ) { $values { "word" word } } -{ $description "Executes a word." } +{ $description "Executes a word. Words which call execute must be inlined in order to compile when called from other words." } { $examples - { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ;\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } + { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; +{ execute POSTPONE: execute( } related-words + HELP: deferred { $class-description "The class of deferred words created by " { $link POSTPONE: DEFER: } "." } ; From 553de434bb4e17a7f6750eb6cfd10c3f52391be8 Mon Sep 17 00:00:00 2001 From: Maxim Savchenko Date: Wed, 22 Apr 2009 16:39:28 -0400 Subject: [PATCH 16/82] Cleaning out newfx references --- unmaintained/dns/dns.factor | 30 +++++++++++++++--------------- unmaintained/dns/misc/misc.factor | 6 +++--- 2 files changed, 18 insertions(+), 18 deletions(-) diff --git a/unmaintained/dns/dns.factor b/unmaintained/dns/dns.factor index cf98154e7a..6d81f2a14b 100644 --- a/unmaintained/dns/dns.factor +++ b/unmaintained/dns/dns.factor @@ -6,7 +6,7 @@ USING: kernel byte-arrays combinators strings arrays sequences splitting io io.binary io.sockets io.encodings.binary accessors combinators.smart - newfx + assocs ; IN: dns @@ -148,8 +148,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] } cleave ] output>array concat ; @@ -203,8 +203,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ name>> dn->ba ] - [ type>> type-table of uint16->ba ] - [ class>> class-table of uint16->ba ] + [ type>> type-table at uint16->ba ] + [ class>> class-table at uint16->ba ] [ ttl>> uint32->ba ] [ [ type>> ] [ rdata>> ] bi rdata->ba @@ -219,13 +219,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ { [ qr>> 15 shift ] - [ opcode>> opcode-table of 11 shift ] + [ opcode>> opcode-table at 11 shift ] [ aa>> 10 shift ] [ tc>> 9 shift ] [ rd>> 8 shift ] [ ra>> 7 shift ] [ z>> 4 shift ] - [ rcode>> rcode-table of 0 shift ] + [ rcode>> rcode-table at 0 shift ] } cleave ] sum-outputs uint16->ba ; @@ -301,8 +301,8 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ get-name ] [ skip-name - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] 2bi ] 2bi query boa ; @@ -364,10 +364,10 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED [ skip-name { - [ 0 + get-double type-table key-of ] - [ 2 + get-double class-table key-of ] + [ 0 + get-double type-table value-at ] + [ 2 + get-double class-table value-at ] [ 4 + get-quad ] - [ [ 10 + ] [ get-double type-table key-of ] 2bi get-rdata ] + [ [ 10 + ] [ get-double type-table value-at ] 2bi get-rdata ] } 2cleave ] @@ -393,13 +393,13 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED get-double { [ 15 >> BIN: 1 bitand ] - [ 11 >> BIN: 111 bitand opcode-table key-of ] + [ 11 >> BIN: 111 bitand opcode-table value-at ] [ 10 >> BIN: 1 bitand ] [ 9 >> BIN: 1 bitand ] [ 8 >> BIN: 1 bitand ] [ 7 >> BIN: 1 bitand ] [ 4 >> BIN: 111 bitand ] - [ BIN: 1111 bitand rcode-table key-of ] + [ BIN: 1111 bitand rcode-table value-at ] } cleave ; @@ -484,7 +484,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: message-query ( message -- query ) question-section>> 1st ; +: message-query ( message -- query ) question-section>> first ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/unmaintained/dns/misc/misc.factor b/unmaintained/dns/misc/misc.factor index 6e62513a80..af080f61eb 100644 --- a/unmaintained/dns/misc/misc.factor +++ b/unmaintained/dns/misc/misc.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences splitting math - io.files io.encodings.utf8 random newfx dns.util ; + io.files io.encodings.utf8 random dns.util ; IN: dns.misc @@ -9,8 +9,8 @@ IN: dns.misc : resolv-conf-servers ( -- seq ) "/etc/resolv.conf" utf8 file-lines [ " " split ] map - [ 1st "nameserver" = ] filter - [ 2nd ] map ; + [ first "nameserver" = ] filter + [ second ] map ; : resolv-conf-server ( -- ip ) resolv-conf-servers random ; From 47fb13955c7e49c2ae2adaa38daed06c7c9b9c57 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 22 Apr 2009 16:18:15 -0500 Subject: [PATCH 17/82] move dns from unmaintained to extra for keyholder --- {unmaintained => extra}/dns/cache/nx/nx.factor | 0 {unmaintained => extra}/dns/cache/rr/rr.factor | 0 {unmaintained => extra}/dns/dns.factor | 0 {unmaintained => extra}/dns/forwarding/forwarding.factor | 0 {unmaintained => extra}/dns/misc/misc.factor | 0 {unmaintained => extra}/dns/resolver/resolver.factor | 0 {unmaintained => extra}/dns/server/server.factor | 6 +++--- {unmaintained => extra}/dns/stub/stub.factor | 0 {unmaintained => extra}/dns/util/util.factor | 0 9 files changed, 3 insertions(+), 3 deletions(-) rename {unmaintained => extra}/dns/cache/nx/nx.factor (100%) rename {unmaintained => extra}/dns/cache/rr/rr.factor (100%) rename {unmaintained => extra}/dns/dns.factor (100%) rename {unmaintained => extra}/dns/forwarding/forwarding.factor (100%) rename {unmaintained => extra}/dns/misc/misc.factor (100%) rename {unmaintained => extra}/dns/resolver/resolver.factor (100%) rename {unmaintained => extra}/dns/server/server.factor (97%) rename {unmaintained => extra}/dns/stub/stub.factor (100%) rename {unmaintained => extra}/dns/util/util.factor (100%) diff --git a/unmaintained/dns/cache/nx/nx.factor b/extra/dns/cache/nx/nx.factor similarity index 100% rename from unmaintained/dns/cache/nx/nx.factor rename to extra/dns/cache/nx/nx.factor diff --git a/unmaintained/dns/cache/rr/rr.factor b/extra/dns/cache/rr/rr.factor similarity index 100% rename from unmaintained/dns/cache/rr/rr.factor rename to extra/dns/cache/rr/rr.factor diff --git a/unmaintained/dns/dns.factor b/extra/dns/dns.factor similarity index 100% rename from unmaintained/dns/dns.factor rename to extra/dns/dns.factor diff --git a/unmaintained/dns/forwarding/forwarding.factor b/extra/dns/forwarding/forwarding.factor similarity index 100% rename from unmaintained/dns/forwarding/forwarding.factor rename to extra/dns/forwarding/forwarding.factor diff --git a/unmaintained/dns/misc/misc.factor b/extra/dns/misc/misc.factor similarity index 100% rename from unmaintained/dns/misc/misc.factor rename to extra/dns/misc/misc.factor diff --git a/unmaintained/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor similarity index 100% rename from unmaintained/dns/resolver/resolver.factor rename to extra/dns/resolver/resolver.factor diff --git a/unmaintained/dns/server/server.factor b/extra/dns/server/server.factor similarity index 97% rename from unmaintained/dns/server/server.factor rename to extra/dns/server/server.factor index b14d765e8d..644533d3a2 100644 --- a/unmaintained/dns/server/server.factor +++ b/extra/dns/server/server.factor @@ -2,7 +2,7 @@ USING: kernel combinators sequences sets math threads namespaces continuations debugger io io.sockets unicode.case accessors destructors combinators.short-circuit combinators.smart - newfx fry arrays + fry arrays dns dns.util dns.misc ; IN: dns.server @@ -64,7 +64,7 @@ SYMBOL: records-var [ rr->rdata-names ] map concat ; : extract-names ( message -- names ) - [ message-query name>> ] [ extract-rdata-names ] bi prefix-on ; + [ message-query name>> ] [ extract-rdata-names ] bi swap prefix ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! fill-authority @@ -99,7 +99,7 @@ DEFER: query->rrs : matching-cname? ( query -- rrs/f ) [ ] [ clone CNAME >>type matching-rrs ] bi ! query rrs [ empty? not ] - [ 1st swap clone over rdata>> >>name query->rrs prefix-on ] + [ first swap clone over rdata>> >>name query->rrs swap prefix ] [ 2drop f ] 1if ; diff --git a/unmaintained/dns/stub/stub.factor b/extra/dns/stub/stub.factor similarity index 100% rename from unmaintained/dns/stub/stub.factor rename to extra/dns/stub/stub.factor diff --git a/unmaintained/dns/util/util.factor b/extra/dns/util/util.factor similarity index 100% rename from unmaintained/dns/util/util.factor rename to extra/dns/util/util.factor From 24d854fb8e9fdf519ae475e88fadc4937b5516c6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 19:35:51 -0500 Subject: [PATCH 18/82] inverse: [ \ + ] fold was incorrectly evaluating to [ + ] --- basis/inverse/inverse-tests.factor | 6 ++++++ basis/inverse/inverse.factor | 8 ++++---- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/basis/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor index 9d81992eae..75e1198658 100644 --- a/basis/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -83,3 +83,9 @@ C: nil [ [ sqrt ] ] [ [ sq ] [undo] ] unit-test [ [ not ] ] [ [ not ] [undo] ] unit-test [ { 3 2 1 } ] [ { 1 2 3 } [ reverse ] undo ] unit-test + +TUPLE: funny-tuple ; +: ( -- funny-tuple ) \ funny-tuple boa ; +: funny-tuple ( -- ) "OOPS" throw ; + +[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 3a86703caf..a988063293 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -74,7 +74,9 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; : fold-word ( stack word -- stack ) 2dup enough? - [ 1quotation with-datastack ] [ [ % ] [ , ] bi* { } ] if ; + [ 1quotation with-datastack ] + [ [ [ literalize , ] each ] [ , ] bi* { } ] + if ; : fold ( quot -- folded-quot ) [ { } [ fold-word ] reduce % ] [ ] make ; @@ -217,9 +219,7 @@ DEFER: _ "predicate" word-prop [ dupd call assure ] curry ; : slot-readers ( class -- quot ) - all-slots - [ name>> reader-word 1quotation [ keep ] curry ] map concat - [ ] like [ drop ] compose ; + all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ; : ?wrapped ( object -- wrapped ) dup wrapper? [ wrapped>> ] when ; From c9defa64944b0a2c4b784d14254eb2b2eb0ea2eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 19:36:01 -0500 Subject: [PATCH 19/82] Make FORGET: M\ ... work --- core/definitions/definitions.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index 5dc3808362..6f9fdaecf5 100644 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces assocs math ; +USING: kernel sequences namespaces assocs math accessors ; IN: definitions MIXIN: definition @@ -41,6 +41,8 @@ GENERIC: forget* ( defspec -- ) M: f forget* drop ; +M: wrapper forget* wrapped>> forget* ; + SYMBOL: forgotten-definitions : forgotten-definition ( defspec -- ) From 1dd3ed519f476c3a5fe7ee8e1fdfad5e2b27951b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:03:53 -0500 Subject: [PATCH 20/82] Revert part of an earlier ccompiler.tree.checker hange to fix smalltalk.eval regression --- basis/compiler/tree/checker/checker.factor | 12 ++++----- .../compiler/tree/optimizer/optimizer.factor | 1 - basis/stack-checker/backend/backend.factor | 27 ++++++++----------- .../stack-checker/stack-checker-tests.factor | 6 +++-- basis/stack-checker/state/state.factor | 1 - 5 files changed, 20 insertions(+), 27 deletions(-) diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor index 718def367d..e25f152aef 100755 --- a/basis/compiler/tree/checker/checker.factor +++ b/basis/compiler/tree/checker/checker.factor @@ -144,15 +144,13 @@ M: #terminate check-stack-flow* SYMBOL: branch-out -: check-branch ( nodes -- datastack ) +: check-branch ( nodes -- stack ) [ datastack [ clone ] change - retainstack [ clone ] change - retainstack get clone [ (check-stack-flow) ] dip - terminated? get [ drop f ] [ - retainstack get assert= - datastack get - ] if + V{ } clone retainstack set + (check-stack-flow) + terminated? get [ assert-retainstack-empty ] unless + terminated? get f datastack get ? ] with-scope ; M: #branch check-stack-flow* diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor index daa8f072ca..fe3c7acb92 100644 --- a/basis/compiler/tree/optimizer/optimizer.factor +++ b/basis/compiler/tree/optimizer/optimizer.factor @@ -29,7 +29,6 @@ SYMBOL: check-optimizer? normalize propagate cleanup - ?check dup run-escape-analysis? [ escape-analysis unbox-tuples diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 182de28cd9..4fb5bab96f 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -84,8 +84,11 @@ M: object apply-object push-literal ; meta-r empty? [ too-many->r ] unless ; : infer-quot-here ( quot -- ) - [ apply-object terminated? get not ] all? - [ commit-literals ] [ literals get delete-all ] if ; + meta-r [ + V{ } clone \ meta-r set + [ apply-object terminated? get not ] all? + [ commit-literals check->r ] [ literals get delete-all ] if + ] dip \ meta-r set ; : infer-quot ( quot rstate -- ) recursive-state get [ @@ -113,33 +116,25 @@ M: object apply-object push-literal ; ] if ; : infer->r ( n -- ) - terminated? get [ drop ] [ - consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi - ] if ; + consume-d dup copy-values [ nip output-r ] [ #>r, ] 2bi ; : infer-r> ( n -- ) - terminated? get [ drop ] [ - consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi - ] if ; - -: (consume/produce) ( effect -- inputs outputs ) - [ in>> length consume-d ] [ out>> length produce-d ] bi ; + consume-r dup copy-values [ nip output-d ] [ #r>, ] 2bi ; : consume/produce ( effect quot: ( inputs outputs -- ) -- ) - '[ (consume/produce) @ ] + '[ [ in>> length consume-d ] [ out>> length produce-d ] bi @ ] [ terminated?>> [ terminate ] when ] bi ; inline +: apply-word/effect ( word effect -- ) + swap '[ _ #call, ] consume/produce ; + : end-infer ( -- ) - terminated? get [ check->r ] unless meta-d clone #return, ; : required-stack-effect ( word -- effect ) dup stack-effect [ ] [ missing-effect ] ?if ; -: apply-word/effect ( word effect -- ) - swap '[ _ #call, ] consume/produce ; - : infer-word ( word -- ) { { [ dup macro? ] [ do-not-compile ] } diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 9f5d0a2213..919cd098f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -299,7 +299,7 @@ ERROR: custom-error ; [ custom-error inference-error ] infer ] unit-test -[ T{ effect f 1 1 t } ] [ +[ T{ effect f 1 2 t } ] [ [ dup [ 3 throw ] dip ] infer ] unit-test @@ -369,4 +369,6 @@ DEFER: eee' [ [ cond ] infer ] must-fail [ [ bi ] infer ] must-fail -[ at ] must-infer \ No newline at end of file +[ at ] must-infer + +[ [ [ "OOPS" throw ] dip ] [ drop ] if ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 9b87854b69..a76d302a7e 100644 --- a/basis/stack-checker/state/state.factor +++ b/basis/stack-checker/state/state.factor @@ -42,7 +42,6 @@ SYMBOL: literals : init-inference ( -- ) terminated? off V{ } clone \ meta-d set - V{ } clone \ meta-r set V{ } clone literals set 0 d-in set ; From 8432c30ed144f217fad6a84960c66479e384b08d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:20:36 -0500 Subject: [PATCH 21/82] Fix docs --- core/kernel/kernel-docs.factor | 4 +++- core/syntax/syntax-docs.factor | 9 ++++++++- core/words/words-docs.factor | 2 +- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 36d04f1437..371edcf995 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -182,12 +182,14 @@ HELP: either? HELP: call { $values { "callable" callable } } -{ $description "Calls a quotation." } +{ $description "Calls a quotation. Words which " { $link call } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal quotation can have a static stack effect." } { $examples "The following two lines are equivalent:" { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } } ; +{ call POSTPONE: call( } related-words + HELP: call-clear ( quot -- ) { $values { "quot" callable } } { $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 73335e09cf..a0e1d280d5 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -791,7 +791,14 @@ HELP: call-next-method HELP: call( { $syntax "call( stack -- effect )" } -{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } +{ $examples + { $code + "TUPLE: action name quot ;" + ": perform-action ( action -- )" + " [ name>> print ] [ quot>> call( -- ) ] bi ;" + } +} ; HELP: execute( { $syntax "execute( stack -- effect )" } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 58cc3c4f49..9cc1f5b2b9 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -160,7 +160,7 @@ ABOUT: "words" HELP: execute ( word -- ) { $values { "word" word } } -{ $description "Executes a word. Words which call execute must be inlined in order to compile when called from other words." } +{ $description "Executes a word. Words which " { $link execute } " an input parameter must be declared " { $link POSTPONE: inline } " so that a caller which passes in a literal word can have a static stack effect." } { $examples { $example "USING: kernel io words ;" "IN: scratchpad" ": twice ( word -- ) dup execute execute ; inline\n: hello ( -- ) \"Hello\" print ;\n\\ hello twice" "Hello\nHello" } } ; From d3cffcbee28302c0399dfc75bce7e7a4ea5d394a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:26:22 -0500 Subject: [PATCH 22/82] Slightly more efficient compilation of 'new' --- basis/stack-checker/transforms/transforms.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 2e66d7d728..955399b00b 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -113,11 +113,9 @@ M\ tuple-class boa t "no-compile" set-word-prop \ new [ dup tuple-class? [ dup inlined-dependency depends-on - [ - [ all-slots [ initial>> literalize , ] each ] - [ literalize , ] bi - \ boa , - ] [ ] make + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append ] [ drop f ] if ] 1 define-transform From 57e1de5181abe41d33deead3e819d04b573bb0de Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 22 Apr 2009 21:26:55 -0500 Subject: [PATCH 23/82] stack-checker.transforms doesn't need make anymore --- basis/stack-checker/transforms/transforms.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 955399b00b..cd8a57bf2e 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel kernel.private combinators.private -words sequences generic math math.order namespaces make quotations +words sequences generic math math.order namespaces quotations assocs combinators combinators.short-circuit classes.tuple classes.tuple.private effects summary hashtables classes generic sets definitions generic.standard slots.private continuations locals From c2fe2a4feab2a25849672e90e3bdb8f8485c502d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 03:48:32 -0500 Subject: [PATCH 24/82] Improve stack checker documentation --- basis/combinators/smart/smart-docs.factor | 7 +- basis/compiler/compiler-docs.factor | 4 +- basis/help/cookbook/cookbook.factor | 69 +-------- basis/help/handbook/handbook.factor | 17 ++- basis/io/mmap/mmap-docs.factor | 11 +- basis/io/sockets/sockets-docs.factor | 11 ++ basis/math/matrices/matrices.factor | 19 ++- basis/memoize/memoize-docs.factor | 14 ++ basis/stack-checker/errors/errors-docs.factor | 34 +++-- basis/stack-checker/stack-checker-docs.factor | 133 +++++++++++------- basis/threads/threads-docs.factor | 2 +- basis/tools/errors/errors-docs.factor | 6 +- core/combinators/combinators-docs.factor | 40 +++--- core/continuations/continuations-docs.factor | 4 +- core/effects/effects-docs.factor | 40 ++---- core/generic/generic-docs.factor | 2 +- core/io/files/files-docs.factor | 13 ++ core/io/io-docs.factor | 20 ++- core/syntax/syntax-docs.factor | 12 +- core/words/words-docs.factor | 63 +++++---- 20 files changed, 286 insertions(+), 235 deletions(-) diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 679b587759..d8ee89ef2d 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel quotations math sequences -multiline ; +multiline stack-checker ; IN: combinators.smart HELP: inputnumber ;" - ": print-age ( n -- )" - " \"You are \" write" - " number>string write" - " \" years old.\" print ;" - ": example ( -- ) ask-age read-age print-age ;" - "example" -} -"Print the lines of a file in sorted order:" -{ $code - "USING: io io.encodings.utf8 io.files sequences sorting ;" - "\"lines.txt\" utf8 file-lines natural-sort [ print ] each" -} -"Read 1024 bytes from a file:" -{ $code - "USING: io io.encodings.binary io.files ;" - "\"data.bin\" binary [ 1024 read ] with-file-reader" -} -"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" -{ $code - "USING: accessors grouping io.files io.mmap.char kernel sequences ;" - "\"mydata.dat\" [" - " 4 [ reverse-here ] change-each" - "] with-mapped-char-file" -} -"Send some bytes to a remote host:" -{ $code - "USING: io io.encodings.ascii io.sockets strings ;" - "\"myhost\" 1033 ascii" - "[ B{ 12 17 102 } write ] with-client" -} -{ $references - { } - "number-strings" - "io" -} ; - ARTICLE: "cookbook-application" "Application cookbook" "Vocabularies can define a main entry point:" { $code "IN: game-of-life" "..." -": play-life ... ;" +": play-life ( -- ) ... ;" "" "MAIN: play-life" } @@ -318,7 +267,6 @@ $nl { "Use " { $link "cleave-combinators" } " and " { $link "spread-combinators" } " instead of " { $link "shuffle-words" } " to give your code more structure." } { "Not everything has to go on the stack. The " { $vocab-link "namespaces" } " vocabulary provides dynamically-scoped variables, and the " { $vocab-link "locals" } " vocabulary provides lexically-scoped variables. Learn both and use them where they make sense, but keep in mind that overuse of variables makes code harder to factor." } "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." - { "Learn to use the " { $link "inference" } " tool." } { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution." { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } @@ -332,6 +280,7 @@ $nl "Factor tries to implement as much of itself as possible, because this improves simplicity and performance. One consequence is that Factor exposes its internals for extension and study. You even have the option of using low-level features not usually found in high-level languages, such manual memory management, pointer arithmetic, and inline assembly code." $nl "Unsafe features are tucked away so that you will not invoke them by accident, or have to use them to solve conventional programming problems. However when the need arises, unsafe features are invaluable, for example you might have to do some pointer arithmetic when interfacing directly with C libraries." ; + ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" "Factor is a very clean and consistent language. However, it has some limitations and leaky abstractions you should keep in mind, as well as behaviors which differ from other languages you may be used to." { $list @@ -341,13 +290,6 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" { "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." } { "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." } { "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by “multiple inheritance” in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." } - { "Performance-sensitive code should have a static stack effect so that it can be compiled by the optimizing word compiler, which generates more efficient code than the non-optimizing quotation compiler. See " { $link "inference" } " and " { $link "compiler" } "." - $nl - "This means that methods defined on performance sensitive, frequently-called core generic words such as " { $link nth } " should have static stack effects which are consistent with each other, since a generic word will only have a static stack effect if all methods do." - $nl - "Unit tests for the " { $vocab-link "stack-checker" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" - { $code "\"stack-checker\" test" } - "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; @@ -372,7 +314,6 @@ ARTICLE: "cookbook" "Factor cookbook" { $subsection "cookbook-combinators" } { $subsection "cookbook-variables" } { $subsection "cookbook-vocabs" } -{ $subsection "cookbook-io" } { $subsection "cookbook-application" } { $subsection "cookbook-scripts" } { $subsection "cookbook-philosophy" } diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index a97a46badc..262c46bbc3 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -39,7 +39,7 @@ $nl { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } { $heading "Stack effect conventions" } -"Stack effect conventions are documented in " { $link "effect-declaration" } "." +"Stack effect conventions are documented in " { $link "effects" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table @@ -229,9 +229,11 @@ ARTICLE: "handbook-language-reference" "The language" { $heading "Fundamentals" } { $subsection "conventions" } { $subsection "syntax" } -{ $subsection "effects" } +{ $heading "The stack" } { $subsection "evaluator" } -{ $heading "Data types" } +{ $subsection "effects" } +{ $subsection "inference" } +{ $heading "Basic data types" } { $subsection "booleans" } { $subsection "numbers" } { $subsection "collections" } @@ -239,16 +241,18 @@ ARTICLE: "handbook-language-reference" "The language" { $subsection "words" } { $subsection "shuffle-words" } { $subsection "combinators" } -{ $subsection "errors" } -{ $subsection "continuations" } +{ $subsection "threads" } { $heading "Named values" } { $subsection "locals" } { $subsection "namespaces" } { $subsection "namespaces-global" } { $subsection "values" } { $heading "Abstractions" } +{ $subsection "errors" } { $subsection "objects" } { $subsection "destructors" } +{ $subsection "continuations" } +{ $subsection "memoize" } { $subsection "parsing-words" } { $subsection "macros" } { $subsection "fry" } @@ -263,6 +267,7 @@ ARTICLE: "handbook-system-reference" "The implementation" { $subsection "vocabularies" } { $subsection "source-files" } { $subsection "compiler" } +{ $subsection "tools.errors" } { $heading "Virtual machine" } { $subsection "images" } { $subsection "cli" } @@ -283,7 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools" { $subsection "prettyprint" } { $subsection "inspector" } { $subsection "tools.annotations" } -{ $subsection "inference" } +{ $subsection "tools.inference" } { $heading "Browsing" } { $subsection "see" } { $subsection "tools.crossref" } diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index 5ef3400a6d..f0adb47321 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -54,11 +54,20 @@ ARTICLE: "io.mmap.arrays" "Memory-mapped arrays" ARTICLE: "io.mmap.low-level" "Reading and writing mapped files directly" "Data can be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. See " { $link "reading-writing-memory" } "." ; +ARTICLE: "io.mmap.examples" "Memory-mapped file example" +"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:" +{ $code + "USING: accessors grouping io.files io.mmap.char kernel sequences ;" + "\"mydata.dat\" [" + " 4 [ reverse-here ] change-each" + "] with-mapped-char-file" +} ; + ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } "Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." -$nl +{ $subsection "io.mmap.examples" } "A utility combinator which wraps the above:" { $subsection with-mapped-file } "Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:" diff --git a/basis/io/sockets/sockets-docs.factor b/basis/io/sockets/sockets-docs.factor index a66ed1d0c0..970aa34ea6 100644 --- a/basis/io/sockets/sockets-docs.factor +++ b/basis/io/sockets/sockets-docs.factor @@ -56,12 +56,23 @@ $nl } "The " { $link inet } " address specifier is not supported by the " { $link send } " word because a single host name can resolve to any number of IPv4 or IPv6 addresses, therefore there is no way to know which address should be used. Applications should call " { $link resolve-host } " then use some kind of strategy to pick the correct address (for example, by sending a packet to each one and waiting for a response, or always assuming IPv4)." ; +ARTICLE: "network-examples" "Networking examples" +"Send some bytes to a remote host:" +{ $code + "USING: io io.encodings.ascii io.sockets strings ;" + "\"myhost\" 1033 ascii" + "[ B{ 12 17 102 } write ] with-client" +} +"Look up the IP addresses associated with a host name:" +{ $code "USING: io.sockets ;" "\"www.apple.com\" 80 resolve-host ." } ; + ARTICLE: "network-streams" "Networking" "Factor supports connection-oriented and packet-oriented communication over a variety of protocols:" { $list "TCP/IP and UDP/IP, over IPv4 and IPv6" "Unix domain sockets (Unix only)" } +{ $subsection "network-examples" } { $subsection "network-addressing" } { $subsection "network-connection" } { $subsection "network-packet" } diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 7c687d753d..4c2c641c84 100755 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors sequences ; +USING: arrays kernel math math.order math.vectors +sequences sequences.private accessors columns ; IN: math.matrices ! Matrices @@ -24,9 +25,19 @@ IN: math.matrices : m* ( m m -- m ) [ v* ] 2map ; : m/ ( m m -- m ) [ v/ ] 2map ; -: v.m ( v m -- v ) flip [ v. ] with map ; -: m.v ( m v -- v ) [ v. ] curry map ; -: m. ( m m -- m ) flip [ swap m.v ] curry map ; +TUPLE: flipped { seq read-only } ; + +M: flipped length seq>> first length ; + +M: flipped nth-unsafe seq>> swap ; + +INSTANCE: flipped sequence + +C: flipped + +: v.m ( v m -- v ) [ v. ] with map ; +: m.v ( m v -- v ) [ v. ] curry map ; inline +: m. ( m m -- m ) [ swap m.v ] curry map ; : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; diff --git a/basis/memoize/memoize-docs.factor b/basis/memoize/memoize-docs.factor index cfb5cffb37..a551272f43 100644 --- a/basis/memoize/memoize-docs.factor +++ b/basis/memoize/memoize-docs.factor @@ -3,6 +3,20 @@ USING: help.syntax help.markup words quotations effects ; IN: memoize +ARTICLE: "memoize" "Memoization" +"The " { $vocab-link "memoize" } " vocabulary implements a simple form of memoization, which is when a word caches results for every unique set of inputs that is supplied. Calling a memoized word with the same inputs more than once does not recalculate anything." +$nl +"Memoization is useful in situations where the set of possible inputs is small, but the results are expensive to compute and should be cached. Memoized words should not have any side effects." +$nl +"Defining a memoized word at parse time:" +{ $subsection POSTPONE: MEMO: } +"Defining a memoized word at run time:" +{ $subsection define-memoized } +"Clearing memoized results:" +{ $subsection reset-memoized } ; + +ABOUT: "memoize" + HELP: define-memoized { $values { "word" word } { "quot" quotation } { "effect" effect } } { $description "defines the given word at runtime as one which memoizes its output given a particular input" } diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 5b314a3154..3c36d95d1e 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -3,10 +3,9 @@ sequences.private words ; IN: stack-checker.errors HELP: literal-expected -{ $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } -{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } +{ $error-description "Thrown when inference encounters a combinator or macro being applied to a value which is not known to be a literal, or constructed in a manner which can be analyzed statically. Such code needs changes before it can compile and run. See " { $link "inference-combinators" } " and " { $link "inference-escape" } " for details." } { $examples - "In this example, words calling " { $snippet "literal-expected-example" } " will compile, even if " { $snippet "literal-expected-example" } " does not compile itself:" + "In this example, words calling " { $snippet "literal-expected-example" } " will have a static stac keffect, even if " { $snippet "literal-expected-example" } " does not:" { $code ": literal-expected-example ( quot -- )" " [ call ] [ call ] bi ; inline" @@ -16,10 +15,8 @@ HELP: literal-expected HELP: unbalanced-branches-error { $values { "in" "a sequence of integers" } { "out" "a sequence of integers" } } { $description "Throws an " { $link unbalanced-branches-error } "." } -{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height." } -{ $notes "Conditionals with variable stack effects are considered to be bad style and should be avoided since they do not compile." -$nl -"If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } +{ $error-description "Thrown when inference encounters an " { $link if } " or " { $link dispatch } " where the branches do not all exit with the same stack height. See " { $link "inference-branches" } " for details." } +{ $notes "If this error comes up when inferring the stack effect of a recursive word, check the word's stack effect declaration; it might be wrong." } { $examples { $code ": unbalanced-branches-example ( a b c -- )" @@ -86,25 +83,26 @@ HELP: inconsistent-recursive-call-error } } ; -ARTICLE: "inference-errors" "Inference warnings and errors" +ARTICLE: "inference-errors" "Stack checker errors" "These conditions are thrown by " { $link "inference" } ", as well as the " { $link "compiler" } "." $nl -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } -"Inference warnings:" +"Error thrown when insufficient information is available to calculate the stack effect of a combinator call (see " { $link "inference-combinators" } "):" { $subsection literal-expected } -"Inference errors:" -{ $subsection recursive-quotation-error } -{ $subsection unbalanced-branches-error } +"Error thrown when a word's stack effect declaration does not match the composition of the stack effects of its factors:" { $subsection effect-error } -{ $subsection missing-effect } -"Inference errors for inline recursive words:" +"Error thrown when branches have incompatible stack effects (see " { $link "inference-branches" } "):" +{ $subsection unbalanced-branches-error } +"Inference errors for inline recursive words (see " { $link "inference-recursive-combinators" } "):" { $subsection undeclared-recursion-error } { $subsection diverging-recursion-error } { $subsection unbalanced-recursion-error } { $subsection inconsistent-recursive-call-error } -"Retain stack usage errors:" +"More obscure errors that are unlikely to arise in ordinary code:" +{ $subsection recursive-quotation-error } { $subsection too-many->r } -{ $subsection too-many-r> } ; +{ $subsection too-many-r> } +{ $subsection missing-effect } +"Main wrapper for all inference warnings and errors:" +{ $subsection inference-error } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 78196abfba..243221ccf0 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -4,38 +4,54 @@ stack-checker.backend stack-checker.branches stack-checker.errors stack-checker.transforms -stack-checker.state ; +stack-checker.state +continuations ; IN: stack-checker ARTICLE: "inference-simple" "Straight-line stack effects" -"The simplest case to look at is that of a quotation which does not have any branches or recursion, and just pushes literals and calls words, each of which has a known stack effect." +"The simplest case is when a piece of code does not have any branches or recursion, and just pushes literals and calls words." $nl -"Stack effect inference works by stepping through the quotation, while maintaining a \"shadow stack\" which tracks stack height at the current position in the quotation. Initially, the shadow stack is empty. If a word is encountered which expects more values than there are on the shadow stack, a global counter is incremented. This counter keeps track of the number of inputs the quotation expects on the stack. When inference is done, this counter, together with the final height of the shadow stack, gives the inferred stack effect." -{ $subsection d-in } -{ $subsection meta-d } -"When a literal is encountered, it is simply pushed on the shadow stack. For example, the stack effect of the following quotation is inferred by pushing all three literals on the shadow stack, then taking the value of " { $link d-in } " and the length of " { $link meta-d } ":" +"Pushing a literal has stack effect " { $snippet "( -- object )" } ". The stack effect of a most words is always known statically from the declaration. Stack effects of " { $link POSTPONE: inline } " words and " { $link "macros" } ", may depend on literals pushed on the stack prior to the call, and this case is discussed in " { $link "inference-combinators" } "." +$nl +"The stack effect of each element in a code snippet is composed. The result is then the stack effect of the snippet." +$nl +"An example:" { $example "[ 1 2 3 ] infer." "( -- object object object )" } -"In the following example, the call to " { $link + } " expects two values on the shadow stack, but only one value is present, the literal which was pushed previously. This increments the " { $link d-in } " counter by one:" -{ $example "[ 2 + ] infer." "( object -- object )" } -"After the call to " { $link + } ", the shadow stack contains a \"computed value placeholder\", since the inferencer has no way to know what the resulting value actually is (in fact it is arbitrary)." ; +"Another example:" +{ $example "[ 2 + ] infer." "( object -- object )" } ; ARTICLE: "inference-combinators" "Combinator stack effects" -"Without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the inferencer encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." -{ $example "[ dup call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } -"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point:" -{ $example "[ [ 2 + ] call ] infer." "( object -- object )" } -"Consider a combinator such as " { $link keep } ". The combinator itself does not have a stack effect, because it applies " { $link call } " to a potentially arbitrary quotation. However, since the combinator is declared " { $link POSTPONE: inline } ", a given usage of it can have a stack effect:" -{ $example "[ [ 2 + ] keep ] infer." "( object -- object object )" } -"Another example is the " { $link compose } " combinator. Because it is decared " { $link POSTPONE: inline } ", we can infer the stack effect of applying " { $link call } " to the result of " { $link compose } ":" -{ $example "[ 2 [ + ] curry [ sq ] compose ] infer." "( -- object )" } -"Incidentally, this example demonstrates that the stack effect of nested currying and composition can also be inferred." +"If a word, call it " { $snippet "W" } ", calls a combinator, one of the following two conditions must hold:" +{ $list + { "The combinator may be called with a quotation that is either a literal, or built from literals, " { $link curry } " and " { $link compose } "." } + { "The combinator must be called on an input parameter, or be built from input parameters, literals, " { $link curry } " and " { $link compose } ", " { $strong "if" } " the word " { $snippet "W" } " must be declared " { $link POSTPONE: inline } ". Then " { $snippet "W" } " is itself considered to be a combinator, and its callers must satisfy one of these two conditions." } +} +"If neither condition holds, the stack checker throws a " { $link literal-expected } " error, and an escape hatch such as " { $link POSTPONE: call( } " must be used instead. See " { $link "inference-escape" } " for details. An inline combinator can be called with an unknown quotation by currying the quotation onto a literal quotation that uses " { $link POSTPONE: call( } "." +{ $heading "Examples" } +{ $subheading "Calling a combinator" } +"The following usage of " { $link map } " passes the stack checker, because the quotation is the result of " { $link curry } ":" +{ $example "[ [ + ] curry map ] infer." "( object object -- object )" } +{ $subheading "Defining an inline combinator" } +"The following word calls a quotation twice; the word is declared " { $link POSTPONE: inline } ", since it invokes " { $link call } " on the result of " { $link compose } " on an input parameter:" +{ $code ": twice ( value quot -- result ) dup compose call ; inline" } +"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":" +{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( object -- object )" } +{ $subheading "Defining a combinator for unknown quotations" } +"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:" +{ $code + "TUPLE: action name quot ;" + ": perform ( value action -- result ) quot>> call( value -- result ) ;" +} +{ $subheading "Passing an unknown quotation to an inline combinator" } +"Suppose we want to write :" +{ $code ": perform ( values action -- results ) quot>> map ;" } +"However this fails to pass the stack checker since there is no guarantee the quotation has the right stack effect for " { $link map } ". It can be wrapped in a new quotation with a declaration:" +{ $code ": perform ( values action -- results )" " quot>> [ call( value -- result ) ] curry map ;" } +{ $heading "Explanation" } +"This restriction exists because without further information, one cannot say what the stack effect of " { $link call } " is; it depends on the given quotation. If the stack checker encounters a " { $link call } " without further information, a " { $link literal-expected } " error is raised." $nl -"A general rule of thumb is that any word which applies " { $link call } " or " { $link curry } " to one of its inputs must be declared " { $link POSTPONE: inline } "." -$nl -"Here is an example where the stack effect cannot be inferred:" -{ $code ": foo ( -- n quot ) 0 [ + ] ;" "[ foo reduce ] infer." } -"However if " { $snippet "foo" } " was declared " { $link POSTPONE: inline } ", everything would work, since the " { $link reduce } " combinator is also " { $link POSTPONE: inline } ", and the inferencer can see the literal quotation value at the point it is passed to " { $link call } ":" -{ $example ": foo ( -- n quot ) 0 [ + ] ; inline" "[ foo reduce ] infer." "( object -- object )" } +"On the other hand, the stack effect of applying " { $link call } " to a literal quotation or a " { $link curry } " of a literal quotation is easy to compute; it behaves as if the quotation was substituted at that point." +{ $heading "Limitations" } "Passing a literal quotation on the data stack through an inlined recursive combinator nullifies its literal status. For example, the following will not infer:" { $example "[ [ reverse ] swap [ reverse ] map swap call ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." @@ -46,30 +62,25 @@ $nl } ; ARTICLE: "inference-branches" "Branch stack effects" -"Conditionals such as " { $link if } " and combinators built on " { $link if } " present a problem, in that if the two branches leave the stack at a different height, it is not clear what the stack effect should be. In this case, inference throws a " { $link unbalanced-branches-error } "." +"Conditionals such as " { $link if } " and combinators built on top have the same restrictions as " { $link POSTPONE: inline } " combinators (see " { $link "inference-combinators" } ") with the additional requirement that all branches leave the stack at the same height. If this is not the case, the stack checker throws a " { $link unbalanced-branches-error } "." $nl "If all branches leave the stack at the same height, then the stack effect of the conditional is just the maximum of the stack effect of each branch. For example," { $example "[ [ + ] [ drop ] if ] infer." "( object object object -- object )" } "The call to " { $link if } " takes one value from the stack, a generalized boolean. The first branch " { $snippet "[ + ]" } " has stack effect " { $snippet "( x x -- x )" } " and the second has stack effect " { $snippet "( x -- )" } ". Since both branches decrease the height of the stack by one, we say that the stack effect of the two branches is " { $snippet "( x x -- x )" } ", and together with the boolean popped off the stack by " { $link if } ", this gives a total stack effect of " { $snippet "( x x x -- x )" } "." ; -ARTICLE: "inference-recursive" "Stack effects of recursive words" -"When a recursive call is encountered, the declared stack effect is substituted in. When inference is complete, the inferred stack effect is compared with the declared stack effect." +ARTICLE: "inference-recursive-combinators" "Recursive combinator stack effects" +"Most combinators do not call themselves recursively directly; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } ". In these cases, the rules outlined in " { $link "inference-combinators" } " apply." $nl -"Attempting to infer the stack effect of a recursive word which outputs a variable number of objects on the stack will fail. For example, the following will throw an " { $link unbalanced-branches-error } ":" -{ $code ": foo ( seq -- ) dup empty? [ drop ] [ dup pop foo ] if ;" "[ foo ] infer." } -"If you declare an incorrect stack effect, inference will fail also. Badly defined recursive words cannot confuse the inferencer." ; - -ARTICLE: "inference-recursive-combinators" "Recursive combinator inference" -"Most combinators are not explicitly recursive; instead, they are implemented in terms of existing combinators, for example " { $link while } ", " { $link map } ", and the " { $link "compositional-combinators" } "." -$nl -"Combinators which are recursive require additional care." -$nl -"If a recursive word takes quotation parameters from the stack and calls them, it must be declared " { $link POSTPONE: inline } " (as documented in " { $link "inference-combinators" } ") as well as " { $link POSTPONE: recursive } "." -$nl -"Furthermore, the input parameters which are quotations must be annotated in the stack effect. For example, the following will not infer:" +"Combinators which are recursive require additional care. In addition to being declared " { $link POSTPONE: inline } ", they must be declared " { $link POSTPONE: recursive } ". There are three restrictions that only apply to combinators with this declaration:" +{ $heading "Input quotation declaration" } +"Input parameters which are quotations must be annotated as much in the stack effect. For example, the following will not infer:" { $example ": bad ( quot -- ) [ call ] keep foo ; inline recursive" "[ [ ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "The following is correct:" { $example ": good ( quot: ( -- ) -- ) [ call ] keep good ; inline recursive" "[ [ ] good ] infer." "( -- )" } +"The effect of the nested quotation itself is only present for documentation purposes; the mere presence of a nested effect is sufficient to mark that value as a quotation parameter." +{ $heading "Data flow restrictions" } +"The stack checker does not trace data flow in two instances." +$nl "An inline recursive word cannot pass a quotation on the data stack through the recursive call. For example, the following will not infer:" { $example ": bad ( ? quot: ( ? -- ) -- ) 2dup [ not ] dip bad call ; inline recursive" "[ [ drop ] bad ] infer." "Got a computed value where a literal quotation was expected\n\nType :help for debugging help." } "However a small change can be made:" @@ -80,23 +91,47 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "inference" "Stack effect inference" -"The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." -$nl -"The main entry point is a single word which takes a quotation and prints its stack effect and variable usage:" -{ $subsection infer. } -"Instead of printing the inferred information, it can be returned as objects on the stack:" +ARTICLE: "tools.inference" "Stack effect tools" +{ $link "inference" } " can be used interactively to print stack effects of quotations without running them. It can also be used from " { $link "combinators.smart" } "." { $subsection infer } -"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +{ $subsection infer. } +"There are also some words for working with " { $link effect } " instances. Getting a word's declared stack effect:" +{ $subsection stack-effect } +"Converting a stack effect to a string form:" +{ $subsection effect>string } +"Comparing effects:" +{ $subsection effect-height } +{ $subsection effect<= } +"The class of stack effects:" +{ $subsection effect } +{ $subsection effect? } ; + +ARTICLE: "inference-escape" "Stack effect checking escape hatches" +"In a static checking regime, sometimes it is necessary to step outside the boundaries and run some code which cannot be statically checked; perhaps this code is constructed at run-time. There are two ways to get around the static stack checker." $nl -"The following articles describe the implementation of the stack effect inference algorithm:" +"If the stack effect of a word or quotation is known, but the word or quotation itself is not, " { $link POSTPONE: execute( } " or " { $link POSTPONE: call( } " can be used. See " { $link "call" } " for details." +$nl +"If the stack effect is not known, the code being called cannot manipulate the datastack directly. Instead, it must reflect the datastack into an array:" +{ $subsection with-datastack } +"The surrounding code has a static stack effect since " { $link with-datastack } " has one. However, the array passed in as input may be transformed arbitrarily by calling this combinator." ; + +ARTICLE: "inference" "Stack effect checking" +"The " { $link "compiler" } " checks the " { $link "effects" } " of words before they can be run. This ensures that words take exactly the number of inputs and outputs that the programmer declares in source." +$nl +"Words that do not pass the stack checker are rejected and cannot be run, and so essentially this defines a very simple and permissive type system that nevertheless catches some invalid programs and enables compiler optimizations." +$nl +"If a word's stack effect cannot be inferred, a compile error is reported. See " { $link "compiler-errors" } "." +$nl +"The following articles describe how different control structures are handled by the stack checker." { $subsection "inference-simple" } -{ $subsection "inference-recursive" } { $subsection "inference-combinators" } { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } +"Stack checking catches several classes of errors." { $subsection "inference-errors" } -{ $see-also "effects" } ; +"Sometimes code with a dynamic stack effect has to be run." +{ $subsection "inference-escape" } +{ $see-also "effects" "tools.inference" "tools.errors" } ; ABOUT: "inference" diff --git a/basis/threads/threads-docs.factor b/basis/threads/threads-docs.factor index a1d7e50594..dbdb69b3e9 100644 --- a/basis/threads/threads-docs.factor +++ b/basis/threads/threads-docs.factor @@ -48,7 +48,7 @@ ARTICLE: "thread-impl" "Thread implementation" { $subsection sleep-queue } ; ARTICLE: "threads" "Lightweight co-operative threads" -"Factor supports lightweight co-operative threads implemented on top of continuations. A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." +"Factor supports lightweight co-operative threads implemented on top of " { $link "continuations" } ". A thread will yield while waiting for input/output operations to complete, or when a yield has been explicitly requested." $nl "Factor threads are very lightweight. Each thread can take as little as 900 bytes of memory. This library has been tested running hundreds of thousands of simple threads." $nl diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 96b13b69b6..5bbb6c4721 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -6,15 +6,15 @@ ARTICLE: "compiler-errors" "Compiler warnings and errors" "After loading a vocabulary, you might see messages like:" { $code ":errors - print 2 compiler errors" - ":warnings - print 50 compiler warnings" + ":warnings - print 1 compiler warnings" } -"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "." +"This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl "Words to view warnings and errors:" { $subsection :warnings } { $subsection :errors } { $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ; +"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error { $values { "error" "an error" } { "word" word } } diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index dd55d5fabe..e02103697d 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -269,28 +269,28 @@ ARTICLE: "combinators-quot" "Quotation construction utilities" { $subsection case>quot } { $subsection alist>quot } ; -ARTICLE: "call" "Fundamental combinators" -"The most basic combinators are those that take either a quotation or word, and invoke it immediately. There are two sets of combinators; they differe in whether or not the stack effect of the expected code is declared." -$nl -"The simplest combinators do not take an effect declaration:" -{ $subsection call } -{ $subsection execute } -"These combinators only get optimized by the compiler if the quotation or word parameter is a literal; otherwise a compiler warning will result. Definitions of combinators which require literal parameters must be followed by the " { $link POSTPONE: inline } " declaration. For example:" -{ $code - ": keep ( x quot -- x )" - " over [ call ] dip ; inline" -} -"See " { $link "declarations" } " and " { $link "compiler-errors" } " for details." -$nl -"The other set of combinators allow arbitrary quotations and words to be called from optimized code. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." -{ $subsection call-effect } -{ $subsection execute-effect } -"A simple layer of syntax sugar is defined on top:" -{ $subsection POSTPONE: call( } -{ $subsection POSTPONE: execute( } +ARTICLE: "call-unsafe" "Unsafe combinators" "Unsafe calls declare an effect statically without any runtime checking:" { $subsection call-effect-unsafe } -{ $subsection execute-effect-unsafe } +{ $subsection execute-effect-unsafe } ; + +ARTICLE: "call" "Fundamental combinators" +"The most basic combinators are those that take either a quotation or word, and invoke it immediately." +$nl +"There are two sets of combinators; they differ in whether or not the stack effect of the expected code is declared." +$nl +"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:" +{ $subsection call } +{ $subsection execute } +"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:" +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:" +{ $subsection call-effect } +{ $subsection execute-effect } +{ $subsection "call-unsafe" } +"The combinator variants that do not take an effect declaration can only be used if the compiler is able to infer the stack effect by other means. See " { $link "inference-combinators" } "." +{ $subsection "call-unsafe" } { $see-also "effects" "inference" } ; ARTICLE: "combinators" "Combinators" diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 651169554e..2c91981f13 100644 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -81,8 +81,6 @@ $nl { $subsection attempt-all } { $subsection retry } { $subsection with-return } -"Reflecting the datastack:" -{ $subsection with-datastack } "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." { $subsection "continuations.private" } ; @@ -211,7 +209,7 @@ $low-level-note ; HELP: with-datastack { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } -{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } +{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $examples { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } } ; diff --git a/core/effects/effects-docs.factor b/core/effects/effects-docs.factor index 20709ca807..495aeb39c1 100644 --- a/core/effects/effects-docs.factor +++ b/core/effects/effects-docs.factor @@ -1,16 +1,20 @@ USING: help.markup help.syntax math strings words kernel combinators ; IN: effects -ARTICLE: "effect-declaration" "Stack effect declaration" -"Stack effects of words must be declared, with the exception of words which only push literals on the stack." -$nl -"A stack effect declaration is written in parentheses and lists word inputs and outputs, separated by " { $snippet "--" } ". Here is an example:" -{ $synopsis sq } +ARTICLE: "effects" "Stack effect declarations" +"Word definition words such as " { $link POSTPONE: : } " and " { $link POSTPONE: GENERIC: } " have a " { $emphasis "stack effect declaration" } " as part of their syntax. A stack effect declaration takes the following form:" +{ $code "( input1 input2 ... -- output1 ... )" } +"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Here is an example:" +{ $synopsis + } "Parameters which are quotations can be declared by suffixing the parameter name with " { $snippet ":" } " and then writing a nested stack effect declaration:" { $synopsis while } -"Stack effect declarations are read in using a parsing word:" -{ $subsection POSTPONE: ( } -"Stack elements in a stack effect are ordered so that the top of the stack is on the right side. Each value can be named by a data type or description. The following are some examples of value names:" +"Only the number of inputs and outputs carries semantic meaning." +$nl +"Nested quotation declaration only has semantic meaning for " { $link POSTPONE: inline } " " { $link POSTPONE: recursive } " words. See " { $link "inference-recursive-combinators" } "." +$nl +"In concatenative code, input and output names are for documentation purposes only and certain conventions have been established to make them more descriptive. For code written with " { $link "locals" } ", stack values are bound to local variables named by the stack effect's input parameters." +$nl +"Inputs and outputs are typically named after some pun on their data type, or a description of the value's purpose if the type is very general. The following are some examples of value names:" { $table { { { $snippet "?" } } "a boolean" } { { { $snippet "<=>" } } { "an ordering sepcifier; see " { $link "order-specifiers" } } } @@ -26,25 +30,7 @@ $nl { { $snippet "dim" } "a screen dimension specified as a two-element array holding width and height values" } { { $snippet "*" } "when this symbol appears by itself in the list of outputs, it means the word unconditionally throws an error" } } -"The stack effect inferencer verifies stack effect comments to ensure the correct number of inputs and outputs is listed. Value names are ignored; only their number matters. An error is thrown if a word's declared stack effect does not match its inferred stack effect. See " { $link "inference" } "." ; - -ARTICLE: "effects" "Stack effects" -"A " { $emphasis "stack effect declaration" } ", for example " { $snippet "( x y -- z )" } " denotes that an operation takes two inputs, with " { $snippet "y" } " at the top of the stack, and returns one output. Stack effects are first-class, and words for working with them are found in the " { $vocab-link "effects" } " vocabulary." -$nl -"Stack effects of words must be declared, and the " { $link "compiler" } " checks that these declarations are correct. Invalid declarations are reported as " { $link "compiler-errors" } ". The " { $link "inference" } " tool can be used to check stack effects interactively." -{ $subsection "effect-declaration" } -"There is a literal syntax for stack objects. It is most often used with " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." -{ $subsection POSTPONE: (( } -"Getting a word's declared stack effect:" -{ $subsection stack-effect } -"Converting a stack effect to a string form:" -{ $subsection effect>string } -"Comparing effects:" -{ $subsection effect-height } -{ $subsection effect<= } -"The class of stack effects:" -{ $subsection effect } -{ $subsection effect? } ; +{ $see-also "inference" } ; ABOUT: "effects" diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 7017ef8a08..e8b5e6d69c 100644 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -95,7 +95,7 @@ $nl { $subsection POSTPONE: MATH: } "Method definition:" { $subsection POSTPONE: M: } -"Generic words must declare their stack effect in order to compile. See " { $link "effect-declaration" } "." +"Generic words must declare their stack effect in order to compile. See " { $link "effects" } "." { $subsection "method-order" } { $subsection "call-next-method" } { $subsection "method-combination" } diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index cf0aea787b..9989d889a8 100644 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -2,7 +2,20 @@ USING: help.markup help.syntax io strings arrays io.backend io.files.private quotations sequences ; IN: io.files +ARTICLE: "io.files.examples" "Examples of reading and writing files" +"Sort the lines in a file and write them back to the same file:" +{ $code + "USING: io io.encodings.utf8 io.files sequences sorting ;" + "\"lines.txt\" utf8 [ file-lines natural-sort ] 2keep set-file-lines" +} +"Read 1024 bytes from a file:" +{ $code + "USING: io io.encodings.binary io.files ;" + "\"data.bin\" binary [ 1024 read ] with-file-reader" +} ; + ARTICLE: "io.files" "Reading and writing files" +{ $subsection "io.files.examples" } "File streams:" { $subsection } { $subsection } diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index ebc248bbbf..740152f294 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -355,9 +355,27 @@ $nl "Copying the contents of one stream to another:" { $subsection stream-copy } ; +ARTICLE: "stream-examples" "Stream example" +"Ask the user for their age, and print it back:" +{ $code + "USING: io math.parser ;" + "" + ": ask-age ( -- ) \"How old are you?\" print ;" + "" + ": read-age ( -- n ) readln string>number ;" + "" + ": print-age ( n -- )" + " \"You are \" write" + " number>string write" + " \" years old.\" print ;" + ": example ( -- ) ask-age read-age print-age ;" + "" + "example" +} ; + ARTICLE: "streams" "Streams" "Input and output centers on the concept of a " { $emphasis "stream" } ", which is a source or sink of " { $emphasis "elements" } "." -$nl +{ $subsection "stream-examples" } "A stream can either be passed around on the stack or bound to a dynamic variable and used as one of the two implicit " { $emphasis "default streams" } "." { $subsection "stream-protocol" } { $subsection "stdio" } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index a0e1d280d5..7ab287fd20 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant ; +assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" @@ -152,6 +152,11 @@ ARTICLE: "syntax-pathnames" "Pathname syntax" { $subsection POSTPONE: P" } "Pathnames are documented in " { $link "io.pathnames" } "." ; +ARTICLE: "syntax-effects" "Stack effect syntax" +"Note that this is " { $emphasis "not" } " syntax to declare stack effects of words. This pushes an " { $link effect } " instance on the stack for reflection, for use with words such as " { $link define-declared } ", " { $link call-effect } " and " { $link execute-effect } "." +{ $subsection POSTPONE: (( } +{ $see-also "effects" "inference" "tools.inference" } ; + ARTICLE: "syntax-literals" "Literals" "Many different types of objects can be constructed at parse time via literal syntax. Numbers are a special case since support for reading them is built-in to the parser. All other literals are constructed via parsing words." $nl @@ -168,7 +173,8 @@ $nl { $subsection "syntax-sbufs" } { $subsection "syntax-hashtables" } { $subsection "syntax-tuples" } -{ $subsection "syntax-pathnames" } ; +{ $subsection "syntax-pathnames" } +{ $subsection "syntax-effects" } ; ARTICLE: "syntax" "Syntax" "Factor has two main forms of syntax: " { $emphasis "definition" } " syntax and " { $emphasis "literal" } " syntax. Code is data, so the syntax for code is a special case of object literal syntax. This section documents literal syntax. Definition syntax is covered in " { $link "words" } ". Extending the parser is the main topic of " { $link "parser" } "." @@ -517,7 +523,7 @@ HELP: ( { $syntax "( inputs -- outputs )" } { $values { "inputs" "a list of tokens" } { "outputs" "a list of tokens" } } { $description "A stack effect declaration. This is treated as a comment unless it appears inside a word definition." } -{ $see-also "effect-declaration" } ; +{ $see-also "effects" } ; HELP: (( { $syntax "(( inputs -- outputs ))" } diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 9cc1f5b2b9..94609a06e5 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -21,8 +21,8 @@ $nl { $subsection gensym } { $subsection define-temp } ; -ARTICLE: "colon-definition" "Word definitions" -"Every word has an associated quotation definition that is called when the word is executed." +ARTICLE: "colon-definition" "Colon definitions" +"Every word has an associated quotation definition that is called when the word is executed. A " { $emphasis "colon definition" } " is a word where this quotation is supplied directly by the user. This is the simplest and most common type of word definition." $nl "Defining words at parse time:" { $subsection POSTPONE: : } @@ -31,7 +31,7 @@ $nl { $subsection define } { $subsection define-declared } { $subsection define-inline } -"Word definitions must declare their stack effect. See " { $link "effect-declaration" } "." +"Word definitions must declare their stack effect. See " { $link "effects" } "." $nl "All other types of word definitions, such as " { $link "words.symbol" } " and " { $link "generic" } ", are just special cases of the above." ; @@ -56,30 +56,16 @@ $nl ": foo undefined ;" } ; -ARTICLE: "declarations" "Declarations" -"Declarations are parsing words that set a word property in the most recently defined word. Declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently." +ARTICLE: "declarations" "Compiler declarations" +"Compiler declarations are parsing words that set a word property in the most recently defined word. They appear after the final " { $link POSTPONE: ; } " of a word definition:" +{ $code ": cubed ( x -- y ) dup dup * * ; foldable" } +"Compiler declarations assert that the word follows a certain contract, enabling certain optimizations that are not valid in general." { $subsection POSTPONE: inline } { $subsection POSTPONE: foldable } { $subsection POSTPONE: flushable } { $subsection POSTPONE: recursive } -{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." } -"Stack effect declarations are documented in " { $link "effect-declaration" } "." ; - -ARTICLE: "word-definition" "Defining words" -"There are two approaches to creating word definitions:" -{ $list - "using parsing words at parse time," - "using defining words at run time." -} -"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." -{ $subsection "colon-definition" } -{ $subsection "words.symbol" } -{ $subsection "words.alias" } -{ $subsection "words.constant" } -{ $subsection "primitives" } -{ $subsection "deferred" } -{ $subsection "declarations" } -"Words implement the definition protocol; see " { $link "definitions" } "." ; +"It is entirely up to the programmer to ensure that the word satisfies the contract of a declaration. Furthermore, if a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract. Unspecified behavior may result if a word does not follow the contract of one of its declarations." +{ $see-also "effects" } ; ARTICLE: "word-props" "Word properties" "Each word has a hashtable of properties." @@ -100,7 +86,7 @@ $nl { { { $snippet "\"reading\"" } ", " { $snippet "\"writing\"" } } { "Set on slot accessor words - " { $link "slots" } } } - { { $snippet "\"declared-effect\"" } { $link "effect-declaration" } } + { { $snippet "\"declared-effect\"" } { $link "effects" } } { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } @@ -134,9 +120,7 @@ $nl "An " { $emphasis "XT" } " (execution token) is the machine code address of a word:" { $subsection word-xt } ; -ARTICLE: "words" "Words" -"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." -$nl +ARTICLE: "words.introspection" "Word introspection" "Word introspection facilities and implementation details are found in the " { $vocab-link "words" } " vocabulary." $nl "Word objects contain several slots:" @@ -149,11 +133,32 @@ $nl "Words are instances of a class." { $subsection word } { $subsection word? } +"Words implement the definition protocol; see " { $link "definitions" } "." { $subsection "interned-words" } { $subsection "uninterned-words" } -{ $subsection "word-definition" } { $subsection "word-props" } -{ $subsection "word.private" } +{ $subsection "word.private" } ; + +ARTICLE: "words" "Words" +"Words are the Factor equivalent of functions or procedures; a word is essentially a named quotation." +$nl +"There are two ways of creating word definitions:" +{ $list + "using parsing words at parse time," + "using defining words at run time." +} +"The latter is a more dynamic feature that can be used to implement code generation and such, and in fact parse time defining words are implemented in terms of run time defining words." +$nl +"Types of words:" +{ $subsection "colon-definition" } +{ $subsection "words.symbol" } +{ $subsection "words.alias" } +{ $subsection "words.constant" } +{ $subsection "primitives" } +"Advanced topics:" +{ $subsection "deferred" } +{ $subsection "declarations" } +{ $subsection "words.introspection" } { $see-also "vocabularies" "vocabs.loader" "definitions" "see" } ; ABOUT: "words" From 77c56e55a3d3c1d0c7e3d1cb9f6db20d6961df44 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 03:57:05 -0500 Subject: [PATCH 25/82] Oops --- basis/math/matrices/matrices.factor | 16 +++------------- 1 file changed, 3 insertions(+), 13 deletions(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 4c2c641c84..cfdbe17c06 100755 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -25,19 +25,9 @@ IN: math.matrices : m* ( m m -- m ) [ v* ] 2map ; : m/ ( m m -- m ) [ v/ ] 2map ; -TUPLE: flipped { seq read-only } ; - -M: flipped length seq>> first length ; - -M: flipped nth-unsafe seq>> swap ; - -INSTANCE: flipped sequence - -C: flipped - -: v.m ( v m -- v ) [ v. ] with map ; -: m.v ( m v -- v ) [ v. ] curry map ; inline -: m. ( m m -- m ) [ swap m.v ] curry map ; +: v.m ( v m -- v ) flip [ v. ] with map ; +: m.v ( m v -- v ) [ v. ] curry map ; +: m. ( m m -- m ) flip [ swap m.v ] curry map ; : mmin ( m -- n ) [ 1/0. ] dip [ [ min ] each ] each ; : mmax ( m -- n ) [ -1/0. ] dip [ [ max ] each ] each ; From d039c803eb3df092ce5ccb78300c6eff2a9840f8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Apr 2009 12:08:30 -0500 Subject: [PATCH 26/82] env vocab for accessing the environment as an assoc --- extra/env/authors.txt | 1 + extra/env/env-docs.factor | 13 +++++++++++++ extra/env/env.factor | 26 ++++++++++++++++++++++++++ extra/env/summary.txt | 1 + 4 files changed, 41 insertions(+) create mode 100644 extra/env/authors.txt create mode 100644 extra/env/env-docs.factor create mode 100644 extra/env/env.factor create mode 100644 extra/env/summary.txt diff --git a/extra/env/authors.txt b/extra/env/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/env/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/env/env-docs.factor b/extra/env/env-docs.factor new file mode 100644 index 0000000000..918b30af4b --- /dev/null +++ b/extra/env/env-docs.factor @@ -0,0 +1,13 @@ +! (c)2009 Joe Groff, see bsd license +USING: help.markup help.syntax ; +IN: env + +HELP: env +{ $class-description "A singleton that implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." } ; + +ARTICLE: "env" "Accessing the environment via the assoc protocol" +"The " { $vocab-link "env" } " vocabulary defines a " { $link env } " word which implements the " { $link "assocs-protocol" } " over " { $link "environment" } "." +{ $subsection env } +; + +ABOUT: "env" diff --git a/extra/env/env.factor b/extra/env/env.factor new file mode 100644 index 0000000000..f7f4c5d231 --- /dev/null +++ b/extra/env/env.factor @@ -0,0 +1,26 @@ +! (c)2009 Joe Groff, see bsd license +USING: assocs environment kernel sequences ; +IN: env + +SINGLETON: env + +INSTANCE: env assoc + +M: env at* + drop os-env dup >boolean ; + +M: env assoc-size + drop (os-envs) length ; + +M: env >alist + drop os-envs >alist ; + +M: env set-at + drop set-os-env ; + +M: env delete-at + drop unset-os-env ; + +M: env clear-assoc + drop os-envs keys [ unset-os-env ] each ; + diff --git a/extra/env/summary.txt b/extra/env/summary.txt new file mode 100644 index 0000000000..bd15472427 --- /dev/null +++ b/extra/env/summary.txt @@ -0,0 +1 @@ +Access environment variables via the assoc protocol From d88a89a3a00bcdb3a32691b8dad9e7ed8daeeb80 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 23 Apr 2009 12:32:18 -0500 Subject: [PATCH 27/82] booleans union class --- basis/booleans/booleans-docs.factor | 7 +++++++ basis/booleans/booleans-tests.factor | 7 +++++++ basis/booleans/booleans.factor | 5 +++++ 3 files changed, 19 insertions(+) create mode 100644 basis/booleans/booleans-docs.factor create mode 100644 basis/booleans/booleans-tests.factor create mode 100644 basis/booleans/booleans.factor diff --git a/basis/booleans/booleans-docs.factor b/basis/booleans/booleans-docs.factor new file mode 100644 index 0000000000..d3e9dfaed3 --- /dev/null +++ b/basis/booleans/booleans-docs.factor @@ -0,0 +1,7 @@ +! (c)2009 Joe Groff, see bsd license +USING: help.markup help.syntax ; +IN: booleans + +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + diff --git a/basis/booleans/booleans-tests.factor b/basis/booleans/booleans-tests.factor new file mode 100644 index 0000000000..4b3154236d --- /dev/null +++ b/basis/booleans/booleans-tests.factor @@ -0,0 +1,7 @@ +! (c)2009 Joe Groff, see bsd license +USING: booleans tools.test ; +IN: booleans.tests + +[ t ] [ t boolean? ] unit-test +[ t ] [ f boolean? ] unit-test +[ f ] [ 1 boolean? ] unit-test diff --git a/basis/booleans/booleans.factor b/basis/booleans/booleans.factor new file mode 100644 index 0000000000..0ec7db33bf --- /dev/null +++ b/basis/booleans/booleans.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff, see bsd license +USING: kernel ; +IN: booleans + +UNION: boolean POSTPONE: t POSTPONE: f ; From c074c2c93bfd4ef3cafc5e7105153f7e26949d6f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 19:07:27 -0500 Subject: [PATCH 28/82] Fix >alist docs --- core/assocs/assocs-docs.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/assocs/assocs-docs.factor b/core/assocs/assocs-docs.factor index 9576a41b7b..d4046a4dcf 100755 --- a/core/assocs/assocs-docs.factor +++ b/core/assocs/assocs-docs.factor @@ -361,8 +361,7 @@ HELP: inc-at HELP: >alist { $values { "assoc" assoc } { "newassoc" "an array of key/value pairs" } } -{ $contract "Converts an associative structure into an association list." } -{ $notes "The " { $link assoc } " mixin has a default implementation for this generic word which constructs the association list by iterating over the assoc with " { $link assoc-find } "." } ; +{ $contract "Converts an associative structure into an association list." } ; HELP: assoc-clone-like { $values From 5649cc7a0a6cbc849160859a68edc01175b231cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 22:17:25 -0500 Subject: [PATCH 29/82] Compiler warnings are no more --- basis/bootstrap/stage2.factor | 4 +- basis/compiler/codegen/codegen.factor | 38 ++------ basis/compiler/compiler-docs.factor | 2 +- basis/compiler/compiler.factor | 39 +++++--- basis/compiler/errors/errors.factor | 68 ++++++++----- basis/compiler/tree/builder/builder.factor | 12 +-- basis/stack-checker/errors/errors-docs.factor | 4 +- basis/stack-checker/errors/errors.factor | 91 ++++-------------- .../errors/prettyprint/prettyprint.factor | 69 +++++-------- .../recursive-state/recursive-state.factor | 16 +-- basis/tools/errors/errors-docs.factor | 27 +++--- basis/tools/errors/errors.factor | 25 ++--- .../tools/error-list/error-list-docs.factor | 7 +- .../error-list/icons/compiler-warning.tiff | Bin 1036 -> 0 bytes core/parser/parser-docs.factor | 4 +- extra/mason/report/report.factor | 2 +- 16 files changed, 157 insertions(+), 251 deletions(-) delete mode 100644 basis/ui/tools/error-list/icons/compiler-warning.tiff diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 4d566a288d..cc853e4842 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -68,9 +68,11 @@ SYMBOL: bootstrap-time "staging" get "deploy-vocab" get or [ "stage2: deployment mode" print ] [ - "listener" require "debugger" require + "alien.prettyprint" require + "inspector" require "tools.errors" require + "listener" require "none" require ] if diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index a220de476a..2a0456e3b7 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -375,45 +375,21 @@ M: long-long-type flatten-value-type ( type -- types ) : box-return* ( node -- ) return>> [ ] [ box-return ] if-void ; -TUPLE: no-such-library name ; - -M: no-such-library summary - drop "Library not found" ; - -M: no-such-library error-type drop +linkage-error+ ; - -: no-such-library ( name -- ) - \ no-such-library boa - compiling-word get compiler-error ; - -TUPLE: no-such-symbol name ; - -M: no-such-symbol summary - drop "Symbol not found" ; - -M: no-such-symbol error-type drop +linkage-error+ ; - -: no-such-symbol ( name -- ) - \ no-such-symbol boa - compiling-word get compiler-error ; - : check-dlsym ( symbols dll -- ) dup dll-valid? [ dupd '[ _ dlsym ] any? - [ drop ] [ no-such-symbol ] if + [ drop ] [ compiling-word get no-such-symbol ] if ] [ - dll-path no-such-library drop + dll-path compiling-word get no-such-library drop ] if ; -: stdcall-mangle ( symbol node -- symbol ) - "@" - swap parameters>> parameter-sizes drop - number>string 3append ; +: stdcall-mangle ( symbol params -- symbol ) + parameters>> parameter-sizes drop number>string "@" glue ; : alien-invoke-dlsym ( params -- symbols dll ) - dup function>> dup pick stdcall-mangle 2array - swap library>> library dup [ dll>> ] when - 2dup check-dlsym ; + [ [ function>> dup ] keep stdcall-mangle 2array ] + [ library>> library dup [ dll>> ] when ] + bi 2dup check-dlsym ; M: ##alien-invoke generate-insn params>> diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 89b9b3cbe9..b96d5e573a 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -29,7 +29,7 @@ $nl $nl "The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:" { $list - { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring compile warnings generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } + { "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." } { "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." } { "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." } { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." } diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 6094efad87..ee91d04b3d 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors stack-checker -stack-checker.state stack-checker.inlining combinators.short-circuit -compiler.errors compiler.units compiler.tree.builder -compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer -compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen -compiler.utilities ; +combinators deques search-deques macros io source-files.errors +stack-checker stack-checker.state stack-checker.inlining +stack-checker.errors combinators.short-circuit compiler.errors +compiler.units compiler.tree.builder compiler.tree.optimizer +compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization +compiler.cfg.two-operand compiler.cfg.linear-scan +compiler.cfg.stack-frame compiler.codegen compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -39,10 +39,10 @@ SYMBOL: compiled "trace-compilation" get [ dup name>> print flush ] when H{ } clone dependencies set H{ } clone generic-dependencies set - f swap compiler-error ; + clear-compiler-error ; : ignore-error? ( word error -- ? ) - #! Ignore warnings on inline combinators, macros, and special + #! Ignore some errors on inline combinators, macros, and special #! words such as 'call'. [ { @@ -51,7 +51,12 @@ SYMBOL: compiled [ "special" word-prop ] [ "no-compile" word-prop ] } 1|| - ] [ error-type +compiler-warning+ eq? ] bi* and ; + ] [ + { + [ do-not-compile? ] + [ literal-expected? ] + } 1|| + ] bi* and ; : finish ( word -- ) #! Recompile callers if the word's stack effect changed, then @@ -80,10 +85,16 @@ SYMBOL: compiled #! non-optimizing compiler, using its definition. Otherwise, #! if the compiler error is not ignorable, use a dummy #! definition from 'not-compiled-def' which throws an error. - 2dup ignore-error? - [ drop f over def>> ] - [ 2dup not-compiled-def ] if - [ swap compiler-error ] [ deoptimize-with ] bi-curry* bi ; + 2dup ignore-error? [ + drop + [ dup def>> deoptimize-with ] + [ clear-compiler-error ] + bi + ] [ + [ swap compiler-error ] + [ [ drop ] [ not-compiled-def ] 2bi deoptimize-with ] + 2bi + ] if ; : frontend ( word -- nodes ) #! If the word contains breakpoints, don't optimize it, since diff --git a/basis/compiler/errors/errors.factor b/basis/compiler/errors/errors.factor index 7e2f3d95f8..3881439fc0 100644 --- a/basis/compiler/errors/errors.factor +++ b/basis/compiler/errors/errors.factor @@ -1,56 +1,72 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors source-files.errors kernel namespaces assocs ; +USING: accessors source-files.errors kernel namespaces assocs fry +summary ; IN: compiler.errors -TUPLE: compiler-error < source-file-error ; - -M: compiler-error error-type error>> error-type ; - +SYMBOL: +compiler-error+ SYMBOL: compiler-errors compiler-errors [ H{ } clone ] initialize -SYMBOLS: +compiler-error+ +compiler-warning+ +linkage-error+ ; +TUPLE: compiler-error < source-file-error ; -: errors-of-type ( type -- assoc ) - compiler-errors get-global - swap [ [ nip error-type ] dip eq? ] curry - assoc-filter ; +M: compiler-error error-type drop +compiler-error+ ; + +SYMBOL: +linkage-error+ +SYMBOL: linkage-errors + +linkage-errors [ H{ } clone ] initialize + +TUPLE: linkage-error < source-file-error ; + +M: linkage-error error-type drop +linkage-error+ ; + +: clear-compiler-error ( word -- ) + compiler-errors linkage-errors + [ get-global delete-at ] bi-curry@ bi ; + +: compiler-error ( error -- ) + dup asset>> compiler-errors get-global set-at ; T{ error-type { type +compiler-error+ } { word ":errors" } { plural "compiler errors" } { icon "vocab:ui/tools/error-list/icons/compiler-error.tiff" } - { quot [ +compiler-error+ errors-of-type values ] } + { quot [ compiler-errors get values ] } { forget-quot [ compiler-errors get delete-at ] } } define-error-type -T{ error-type - { type +compiler-warning+ } - { word ":warnings" } - { plural "compiler warnings" } - { icon "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } - { quot [ +compiler-warning+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } -} define-error-type +: ( error word -- compiler-error ) + \ compiler-error ; + +: ( error word -- linkage-error ) + \ linkage-error ; + +: linkage-error ( error word class -- ) + '[ _ boa ] dip dup asset>> linkage-errors get set-at ; inline T{ error-type { type +linkage-error+ } { word ":linkage" } { plural "linkage errors" } { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" } - { quot [ +linkage-error+ errors-of-type values ] } - { forget-quot [ compiler-errors get delete-at ] } + { quot [ linkage-errors get values ] } + { forget-quot [ linkage-errors get delete-at ] } { fatal? f } } define-error-type -: ( error word -- compiler-error ) - \ compiler-error ; +TUPLE: no-such-library name ; -: compiler-error ( error word -- ) - compiler-errors get-global pick - [ [ [ ] keep ] dip set-at ] [ delete-at drop ] if ; +M: no-such-library summary drop "Library not found" ; + +: no-such-library ( name word -- ) \ no-such-library linkage-error ; + +TUPLE: no-such-symbol name ; + +M: no-such-symbol summary drop "Symbol not found" ; + +: no-such-symbol ( name word -- ) \ no-such-symbol linkage-error ; ERROR: not-compiled word error ; \ No newline at end of file diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 3f00a3bb68..7f760650e7 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -15,7 +15,7 @@ IN: compiler.tree.builder GENERIC: (build-tree) ( quot -- ) -M: callable (build-tree) f initial-recursive-state infer-quot ; +M: callable (build-tree) infer-quot-here ; : check-no-compile ( word -- ) dup "no-compile" word-prop [ do-not-compile ] [ drop ] if ; @@ -31,15 +31,13 @@ M: callable (build-tree) f initial-recursive-state infer-quot ; dup inline-recursive? [ 1quotation ] [ specialized-def ] if ; M: word (build-tree) - { - [ initial-recursive-state recursive-state set ] - [ check-no-compile ] - [ word-body infer-quot-here ] - [ current-effect check-effect ] - } cleave ; + [ check-no-compile ] + [ word-body infer-quot-here ] + [ current-effect check-effect ] tri ; : build-tree-with ( in-stack word/quot -- nodes ) [ + recursive-state set V{ } clone stack-visitor set [ [ >vector \ meta-d set ] [ length d-in set ] bi ] [ (build-tree) ] diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index 3c36d95d1e..7a87ab988d 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -101,8 +101,6 @@ $nl { $subsection recursive-quotation-error } { $subsection too-many->r } { $subsection too-many-r> } -{ $subsection missing-effect } -"Main wrapper for all inference warnings and errors:" -{ $subsection inference-error } ; +{ $subsection missing-effect } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 550e283dbf..e036d4d81b 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -1,93 +1,36 @@ ! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel generic sequences io words arrays summary effects -continuations assocs accessors namespaces compiler.errors -stack-checker.values stack-checker.recursive-state -source-files.errors compiler.errors ; +USING: kernel stack-checker.values ; IN: stack-checker.errors -: pretty-word ( word -- word' ) - dup method-body? [ "method-generic" word-prop ] when ; +TUPLE: inference-error ; -TUPLE: inference-error error type word ; +ERROR: do-not-compile < inference-error word ; -M: inference-error error-type type>> ; +ERROR: literal-expected < inference-error what ; -: (inference-error) ( ... class type -- * ) - [ boa ] dip - recursive-state get word>> - \ inference-error boa rethrow ; inline +ERROR: unbalanced-branches-error < inference-error branches quots ; -: inference-error ( ... class -- * ) - +compiler-error+ (inference-error) ; inline +ERROR: too-many->r < inference-error ; -: inference-warning ( ... class -- * ) - +compiler-warning+ (inference-error) ; inline +ERROR: too-many-r> < inference-error ; -TUPLE: do-not-compile word ; +ERROR: missing-effect < inference-error word ; -: do-not-compile ( word -- * ) \ do-not-compile inference-warning ; +ERROR: effect-error < inference-error inferred declared ; -TUPLE: literal-expected what ; +ERROR: recursive-quotation-error < inference-error quot ; -: literal-expected ( what -- * ) \ literal-expected inference-warning ; +ERROR: undeclared-recursion-error < inference-error word ; -M: object (literal) "literal value" literal-expected ; +ERROR: diverging-recursion-error < inference-error word ; -TUPLE: unbalanced-branches-error branches quots ; +ERROR: unbalanced-recursion-error < inference-error word height ; -: unbalanced-branches-error ( branches quots -- * ) - \ unbalanced-branches-error inference-error ; +ERROR: inconsistent-recursive-call-error < inference-error word ; -TUPLE: too-many->r ; +ERROR: unknown-primitive-error < inference-error ; -: too-many->r ( -- * ) \ too-many->r inference-error ; +ERROR: transform-expansion-error < inference-error word error ; -TUPLE: too-many-r> ; - -: too-many-r> ( -- * ) \ too-many-r> inference-error ; - -TUPLE: missing-effect word ; - -: missing-effect ( word -- * ) - pretty-word \ missing-effect inference-error ; - -TUPLE: effect-error inferred declared ; - -: effect-error ( inferred declared -- * ) - \ effect-error inference-error ; - -TUPLE: recursive-quotation-error quot ; - -: recursive-quotation-error ( word -- * ) - \ recursive-quotation-error inference-error ; - -TUPLE: undeclared-recursion-error word ; - -: undeclared-recursion-error ( word -- * ) - \ undeclared-recursion-error inference-error ; - -TUPLE: diverging-recursion-error word ; - -: diverging-recursion-error ( word -- * ) - \ diverging-recursion-error inference-error ; - -TUPLE: unbalanced-recursion-error word height ; - -: unbalanced-recursion-error ( word height -- * ) - \ unbalanced-recursion-error inference-error ; - -TUPLE: inconsistent-recursive-call-error word ; - -: inconsistent-recursive-call-error ( word -- * ) - \ inconsistent-recursive-call-error inference-error ; - -TUPLE: unknown-primitive-error ; - -: unknown-primitive-error ( -- * ) - \ unknown-primitive-error inference-warning ; - -TUPLE: transform-expansion-error word error ; - -: transform-expansion-error ( word error -- * ) - \ transform-expansion-error inference-error ; \ No newline at end of file +M: object (literal) "literal value" literal-expected ; \ No newline at end of file diff --git a/basis/stack-checker/errors/prettyprint/prettyprint.factor b/basis/stack-checker/errors/prettyprint/prettyprint.factor index 97fe1522e0..5be5722c23 100644 --- a/basis/stack-checker/errors/prettyprint/prettyprint.factor +++ b/basis/stack-checker/errors/prettyprint/prettyprint.factor @@ -1,18 +1,11 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel prettyprint io debugger -sequences assocs stack-checker.errors summary effects make ; +sequences assocs stack-checker.errors summary effects ; IN: stack-checker.errors.prettyprint -M: inference-error summary error>> summary ; - -M: inference-error error-help error>> error-help ; - -M: inference-error error. - [ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ; - M: literal-expected summary - [ "Got a computed value where a " % what>> % " was expected" % ] "" make ; + what>> "Got a computed value where a " " was expected" surround ; M: literal-expected error. summary print ; @@ -25,63 +18,45 @@ M: unbalanced-branches-error error. [ [ first pprint-short bl ] [ second effect>string print ] bi ] each ; M: too-many->r summary - drop - "Quotation pushes elements on retain stack without popping them" ; + drop "Quotation pushes elements on retain stack without popping them" ; M: too-many-r> summary - drop - "Quotation pops retain stack elements which it did not push" ; + drop "Quotation pops retain stack elements which it did not push" ; M: missing-effect summary - [ - "The word " % - word>> name>> % - " must declare a stack effect" % - ] "" make ; + drop "Missing stack effect declaration" ; M: effect-error summary drop "Stack effect declaration is wrong" ; -M: recursive-quotation-error error. - "The quotation " write - quot>> pprint - " calls itself." print - "Stack effect inference is undecidable when quotation-level recursion is permitted." print ; +M: recursive-quotation-error summary + drop "Recursive quotation" ; M: undeclared-recursion-error summary - drop - "Inline recursive words must be declared recursive" ; + word>> name>> + "The inline recursive word " " must be declared recursive" surround ; M: diverging-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " digs arbitrarily deep into the stack" % - ] "" make ; + word>> name>> + "The recursive word " " digs arbitrarily deep into the stack" surround ; M: unbalanced-recursion-error summary - [ - "The recursive word " % - word>> name>> % - " leaves with the stack having the wrong height" % - ] "" make ; + word>> name>> + "The recursive word " " leaves with the stack having the wrong height" surround ; M: inconsistent-recursive-call-error summary - [ - "The recursive word " % - word>> name>> % - " calls itself with a different set of quotation parameters than were input" % - ] "" make ; + word>> name>> + "The recursive word " + " calls itself with a different set of quotation parameters than were input" surround ; M: unknown-primitive-error summary - drop - "Cannot determine stack effect statically" ; + word>> name>> "The " " word cannot be called from optimized words" surround ; M: transform-expansion-error summary - drop - "Compiler transform threw an error" ; + word>> name>> "Macro expansion of " " threw an error" surround ; M: transform-expansion-error error. - [ summary print ] - [ "Word: " write word>> . nl ] - [ error>> error. ] tri ; \ No newline at end of file + [ summary print ] [ error>> error. ] bi ; + +M: do-not-compile summary + word>> name>> "Cannot compile call to " prepend ; \ No newline at end of file diff --git a/basis/stack-checker/recursive-state/recursive-state.factor b/basis/stack-checker/recursive-state/recursive-state.factor index 7740bebf4c..345e69e653 100644 --- a/basis/stack-checker/recursive-state/recursive-state.factor +++ b/basis/stack-checker/recursive-state/recursive-state.factor @@ -1,25 +1,19 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays sequences kernel sequences assocs -namespaces stack-checker.recursive-state.tree ; +USING: accessors kernel namespaces stack-checker.recursive-state.tree ; IN: stack-checker.recursive-state -TUPLE: recursive-state word quotations inline-words ; +TUPLE: recursive-state quotations inline-words ; -: initial-recursive-state ( word -- state ) - recursive-state new - swap >>word - f >>quotations - f >>inline-words ; inline +: ( -- state ) recursive-state new ; inline -f initial-recursive-state recursive-state set-global + recursive-state set-global : add-local-quotation ( rstate quot -- rstate ) swap clone [ dupd store ] change-quotations ; : add-inline-word ( word label -- rstate ) - swap recursive-state get clone - [ store ] change-inline-words ; + swap recursive-state get clone [ store ] change-inline-words ; : inline-recursive-label ( word -- label/f ) recursive-state get inline-words>> lookup ; diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index 5bbb6c4721..eb7b465d30 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -2,34 +2,33 @@ IN: tools.errors USING: help.markup help.syntax source-files.errors words io compiler.errors ; -ARTICLE: "compiler-errors" "Compiler warnings and errors" -"After loading a vocabulary, you might see messages like:" +ARTICLE: "compiler-errors" "Compiler errors" +"After loading a vocabulary, you might see a message like:" { $code ":errors - print 2 compiler errors" - ":warnings - print 1 compiler warnings" } "This indicates that some words did not pass the stack checker. Stack checker error conditions are documented in " { $link "inference-errors" } ", and the stack checker itself in " { $link "inference" } "." $nl -"Words to view warnings and errors:" -{ $subsection :warnings } +"Words to view errors:" { $subsection :errors } { $subsection :linkage } -"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; +"Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error -{ $values { "error" "an error" } { "word" word } } -{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ; +{ $values { "error" compiler-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :errors } "." } ; + +HELP: linkage-error +{ $values { "error" linkage-error } { "word" word } } +{ $description "Saves the error for viewing with " { $link :linkage } "." } ; HELP: :errors -{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ; - -HELP: :warnings -{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all compiler errors." } ; HELP: :linkage -{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ; +{ $description "Prints all C library interface linkage errors." } ; -{ :errors :warnings :linkage } related-words +{ :errors :linkage } related-words HELP: errors. { $values { "errors" "a sequence of " { $link source-file-error } " instances" } } diff --git a/basis/tools/errors/errors.factor b/basis/tools/errors/errors.factor index ae55e9a1da..ccedf365e3 100644 --- a/basis/tools/errors/errors.factor +++ b/basis/tools/errors/errors.factor @@ -2,17 +2,15 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs debugger io kernel sequences source-files.errors summary accessors continuations make math.parser io.styles namespaces -compiler.errors ; +compiler.errors prettyprint ; IN: tools.errors #! Tools for source-files.errors. Used by tools.tests and others #! for error reporting -M: source-file-error compute-restarts - error>> compute-restarts ; +M: source-file-error compute-restarts error>> compute-restarts ; -M: source-file-error error-help - error>> error-help ; +M: source-file-error error-help error>> error-help ; CONSTANT: +listener-input+ "" @@ -20,11 +18,13 @@ M: source-file-error summary [ [ file>> [ % ": " % ] [ +listener-input+ % ] if* ] [ line#>> [ # ] when* ] bi - ] "" make - ; + ] "" make ; M: source-file-error error. - [ summary print nl ] [ error>> error. ] bi ; + [ summary print nl ] + [ "Asset: " write asset>> short. nl ] + [ error>> error. ] + tri ; : errors. ( errors -- ) group-by-source-file sort-errors @@ -34,14 +34,9 @@ M: source-file-error error. bi* ] assoc-each ; -: compiler-errors. ( type -- ) - errors-of-type values errors. ; +: :errors ( -- ) compiler-errors get values errors. ; -: :errors ( -- ) +compiler-error+ compiler-errors. ; - -: :warnings ( -- ) +compiler-warning+ compiler-errors. ; - -: :linkage ( -- ) +linkage-error+ compiler-errors. ; +: :linkage ( -- ) linkage-errors get values errors. ; M: not-compiled summary word>> name>> "The word " " cannot be executed because it failed to compile" surround ; diff --git a/basis/ui/tools/error-list/error-list-docs.factor b/basis/ui/tools/error-list/error-list-docs.factor index 10ca80d97d..5040a13be2 100644 --- a/basis/ui/tools/error-list/error-list-docs.factor +++ b/basis/ui/tools/error-list/error-list-docs.factor @@ -8,13 +8,12 @@ $nl { $heading "Message icons" } { $table { "Icon" "Message type" "Reference" } - { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } - { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } - { { $image "vocab:ui/tools/error-list/icons/compiler-warning.tiff" } "Compiler warning" { $link "compiler-errors" } } + ! { { $image "vocab:ui/tools/error-list/icons/note.tiff" } "Parser note" { $link "parser" } } + ! { { $image "vocab:ui/tools/error-list/icons/syntax-error.tiff" } "Syntax error" { $link "syntax" } } { { $image "vocab:ui/tools/error-list/icons/compiler-error.tiff" } "Compiler error" { $link "compiler-errors" } } + { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } - { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } } ; ABOUT: "ui.tools.error-list" diff --git a/basis/ui/tools/error-list/icons/compiler-warning.tiff b/basis/ui/tools/error-list/icons/compiler-warning.tiff deleted file mode 100644 index 405cfd4761c00b17a9be353006e56125a91d639c..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 1036 zcmebD)M8l2#K6#C|G8s@u=Z z)zR9fJ7i`BCY-vd(4W3V;8bdp=9Ei;5$iZMMLM!LX?!ydtUuvY6zRS0l-RFYM>b~- z<kYPd0xf}*J<@k-icBt~tY~SN4sx?EgW?z%M z`Y9WWJ`F_~cZGJx3r+lwe{tCKYbbCqDKtE=xU`mka!AyY_Z4n}4Xnx^jx2u8d8moi zF*xnkidIFBCXOU24hI1aMT0J#v&K?+vllSz;B8J|+>w@MDZ;q;UC{)NPG@LM2JNZgwtDg6< zKUT`lA9>s+%{XSnA={o4@W)=Eg_G&1#mOy|@^)vdUfM5dRyfflyyTUa7;A^(gcOAd zuR7f}UbsEo)8O>xPpvZTDj%9;j~59rG-xP>geo*GSg|&w*PCI7=?d@np*kxzamcl= zyS-}?qks_@Wj9awvYR2EHCwATEm|L&%_Hi^n z{C4zvZeqkOzGtd0yV7Po`2No}A?~M@SlhxEU20v6UYs)Pd+HIy#2~`Jz{t$N$iToL z0mO_*Y$hO^1t_+JnSp^BD$WYzvq9OwB+kGEWrOtdGBPoU0qHeB^@5BnU^6*@d?6$? zqEI%-Trns+6v!5bs$U8;REm)mtoIPm9BC-~6p$^0WR3=u4HRZD1lnr_q%Q$Ewoq}9 z+q|G=0+|d!Na7$q2NWjf=N4q Date: Thu, 23 Apr 2009 22:36:34 -0500 Subject: [PATCH 30/82] Split off some code into tools.errors.model and update UI listener's error summary when errors change --- basis/listener/listener.factor | 9 ++----- basis/tools/errors/errors.factor | 2 +- basis/tools/errors/model/authors.txt | 1 + basis/tools/errors/model/model.factor | 18 +++++++++++++ basis/ui/tools/error-list/error-list.factor | 22 +++------------- basis/ui/tools/listener/listener.factor | 29 ++++++++++----------- 6 files changed, 40 insertions(+), 41 deletions(-) create mode 100644 basis/tools/errors/model/authors.txt create mode 100644 basis/tools/errors/model/model.factor diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index 4234a0023b..d96e0df6c1 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -60,7 +60,7 @@ SYMBOL: max-stack-items 10 max-stack-items set-global -SYMBOL: error-summary-hook +SYMBOL: error-summary? > short. nl ] + [ asset>> [ "Asset: " write short. nl ] when* ] [ error>> error. ] tri ; diff --git a/basis/tools/errors/model/authors.txt b/basis/tools/errors/model/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/tools/errors/model/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/tools/errors/model/model.factor b/basis/tools/errors/model/model.factor new file mode 100644 index 0000000000..c874363fe6 --- /dev/null +++ b/basis/tools/errors/model/model.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: models source-files.errors namespaces models.delay init +kernel calendar ; +IN: tools.errors.model + +SYMBOLS: (error-list-model) error-list-model ; + +(error-list-model) [ f ] initialize + +error-list-model [ (error-list-model) get-global 100 milliseconds ] initialize + +SINGLETON: updater + +M: updater errors-changed drop f (error-list-model) get-global set-model ; + +[ updater add-error-observer ] "ui.tools.error-list" add-init-hook + diff --git a/basis/ui/tools/error-list/error-list.factor b/basis/ui/tools/error-list/error-list.factor index 5a4fb7376a..aa23a8ebe1 100644 --- a/basis/ui/tools/error-list/error-list.factor +++ b/basis/ui/tools/error-list/error-list.factor @@ -4,14 +4,14 @@ USING: accessors arrays sequences sorting assocs colors.constants fry combinators combinators.smart combinators.short-circuit editors make memoize compiler.units fonts kernel io.pathnames prettyprint source-files.errors math.parser init math.order models models.arrow -models.arrow.smart models.search models.mapping models.delay debugger +models.arrow.smart models.search models.mapping debugger namespaces summary locals ui ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.tables ui.gadgets.labeled ui.gadgets.tracks ui.gestures ui.operations ui.tools.browser ui.tools.common ui.gadgets.scrollers ui.tools.inspector ui.gadgets.status-bar ui.operations ui.gadgets.buttons ui.gadgets.borders ui.gadgets.packs ui.gadgets.labels ui.baseline-alignment ui.images ui.tools.listener -compiler.errors calendar tools.errors ; +compiler.errors tools.errors tools.errors.model ; IN: ui.tools.error-list CONSTANT: source-file-icon @@ -180,23 +180,9 @@ error-list-gadget "toolbar" f { { T{ key-down f f "F1" } error-list-help } } define-command-map -SYMBOL: error-list-model - -error-list-model [ f ] initialize - -SINGLETON: updater - -M: updater errors-changed - drop f error-list-model get-global set-model ; - -[ updater add-error-observer ] "ui.tools.error-list" add-init-hook - -: ( -- model ) - error-list-model get-global - 1/2 seconds [ drop all-errors ] ; - : error-list-window ( -- ) - "Errors" open-status-window ; + error-list-model get [ drop all-errors ] + "Errors" open-status-window ; : show-error-list ( -- ) [ error-list-gadget? ] find-window diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor index 3a1c68fa25..eca16e7286 100644 --- a/basis/ui/tools/listener/listener.factor +++ b/basis/ui/tools/listener/listener.factor @@ -13,7 +13,7 @@ ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures ui.operations ui.tools.browser ui.tools.common ui.tools.debugger ui.tools.listener.completion ui.tools.listener.popups -ui.tools.listener.history ui.tools.error-list ui.images ; +ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ; FROM: source-files.errors => all-errors ; IN: ui.tools.listener @@ -187,8 +187,18 @@ TUPLE: listener-gadget < tool error-summary output scroller input ; [ >>input ] [ pane new-pane t >>scrolls? >>output ] bi dup listener-streams >>output drop ; +: error-summary. ( -- ) + error-counts keys [ + H{ { table-gap { 3 3 } } } [ + [ [ [ icon>> write-image ] with-cell ] each ] with-row + ] tabular-output + { "Press " { $command tool "common" show-error-list } " to view errors." } + print-element + ] unless-empty ; + : ( -- gadget ) - COLOR: light-yellow >>interior ; + error-list-model get [ drop error-summary. ] + COLOR: light-yellow >>interior ; : init-error-summary ( listener -- listener ) >>error-summary @@ -366,22 +376,11 @@ interactor "completion" f { { T{ key-down f { C+ } "r" } history-completion-popup } } define-command-map -: error-summary. ( listener -- ) - error-summary>> [ - error-counts keys [ - H{ { table-gap { 3 3 } } } [ - [ [ [ icon>> write-image ] with-cell ] each ] with-row - ] tabular-output - { "Press " { $command tool "common" show-error-list } " to view errors." } - print-element - ] unless-empty - ] with-pane ; - : listener-thread ( listener -- ) dup listener-streams [ [ com-browse ] help-hook set - [ '[ [ _ input>> ] 2dip debugger-popup ] error-hook set ] - [ '[ _ error-summary. ] error-summary-hook set ] bi + '[ [ _ input>> ] 2dip debugger-popup ] error-hook set + error-summary? off tip-of-the-day. nl listener ] with-streams* ; From ba40acda282a056caf07c1593733528a4d97d0f8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 23 Apr 2009 22:39:31 -0500 Subject: [PATCH 31/82] Merge Joe Groff's booleans vocab into kernel --- basis/booleans/booleans-docs.factor | 7 ------- basis/booleans/booleans-tests.factor | 7 ------- basis/booleans/booleans.factor | 5 ----- core/combinators/combinators-docs.factor | 2 ++ core/kernel/kernel-docs.factor | 3 +++ core/kernel/kernel.factor | 6 ++++-- 6 files changed, 9 insertions(+), 21 deletions(-) delete mode 100644 basis/booleans/booleans-docs.factor delete mode 100644 basis/booleans/booleans-tests.factor delete mode 100644 basis/booleans/booleans.factor diff --git a/basis/booleans/booleans-docs.factor b/basis/booleans/booleans-docs.factor deleted file mode 100644 index d3e9dfaed3..0000000000 --- a/basis/booleans/booleans-docs.factor +++ /dev/null @@ -1,7 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: help.markup help.syntax ; -IN: booleans - -HELP: boolean -{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; - diff --git a/basis/booleans/booleans-tests.factor b/basis/booleans/booleans-tests.factor deleted file mode 100644 index 4b3154236d..0000000000 --- a/basis/booleans/booleans-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: booleans tools.test ; -IN: booleans.tests - -[ t ] [ t boolean? ] unit-test -[ t ] [ f boolean? ] unit-test -[ f ] [ 1 boolean? ] unit-test diff --git a/basis/booleans/booleans.factor b/basis/booleans/booleans.factor deleted file mode 100644 index 0ec7db33bf..0000000000 --- a/basis/booleans/booleans.factor +++ /dev/null @@ -1,5 +0,0 @@ -! (c)2009 Joe Groff, see bsd license -USING: kernel ; -IN: booleans - -UNION: boolean POSTPONE: t POSTPONE: f ; diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index e02103697d..cbef25ac38 100644 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -198,6 +198,8 @@ ARTICLE: "booleans" "Booleans" "In Factor, any object that is not " { $link f } " has a true value, and " { $link f } " has a false value. The " { $link t } " object is the canonical true value." { $subsection f } { $subsection t } +"A union class of the above:" +{ $subsection boolean } "There are some logical operations on booleans:" { $subsection >boolean } { $subsection not } diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 371edcf995..1d8c09a9b2 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -129,6 +129,9 @@ HELP: ? { $values { "?" "a generalized boolean" } { "true" object } { "false" object } { "true/false" "one two input objects" } } { $description "Chooses between two values depending on the boolean value of " { $snippet "cond" } "." } ; +HELP: boolean +{ $class-description "A union of the " { $link POSTPONE: t } " and " { $link POSTPONE: f } " classes." } ; + HELP: >boolean { $values { "obj" "a generalized boolean" } { "?" "a boolean" } } { $description "Convert a generalized boolean into a boolean. That is, " { $link f } " retains its value, whereas anything else becomes " { $link t } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index baccf56059..6245080225 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -176,12 +176,14 @@ PRIVATE> : tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline ! Booleans +UNION: boolean POSTPONE: t POSTPONE: f ; + +: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline + : not ( obj -- ? ) [ f ] [ t ] if ; inline : and ( obj1 obj2 -- ? ) over ? ; inline -: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline - : or ( obj1 obj2 -- ? ) dupd ? ; inline : xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline From 04c6e8fcf8d691919e7ed77439f6c15272f40ebb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:10:48 -0500 Subject: [PATCH 32/82] Fix tools.errors unit test and help lint --- basis/tools/errors/errors-docs.factor | 6 +++--- basis/tools/errors/errors-tests.factor | 9 +-------- 2 files changed, 4 insertions(+), 11 deletions(-) diff --git a/basis/tools/errors/errors-docs.factor b/basis/tools/errors/errors-docs.factor index eb7b465d30..4eb9115d05 100644 --- a/basis/tools/errors/errors-docs.factor +++ b/basis/tools/errors/errors-docs.factor @@ -1,6 +1,6 @@ IN: tools.errors USING: help.markup help.syntax source-files.errors words io -compiler.errors ; +compiler.errors classes ; ARTICLE: "compiler-errors" "Compiler errors" "After loading a vocabulary, you might see a message like:" @@ -15,11 +15,11 @@ $nl "Compiler errors are reported using the " { $link "tools.errors" } " mechanism, and as a result, they are also are shown in the " { $link "ui.tools.error-list" } "." ; HELP: compiler-error -{ $values { "error" compiler-error } { "word" word } } +{ $values { "error" compiler-error } } { $description "Saves the error for viewing with " { $link :errors } "." } ; HELP: linkage-error -{ $values { "error" linkage-error } { "word" word } } +{ $values { "error" linkage-error } { "word" word } { "class" class } } { $description "Saves the error for viewing with " { $link :linkage } "." } ; HELP: :errors diff --git a/basis/tools/errors/errors-tests.factor b/basis/tools/errors/errors-tests.factor index a70aa32be8..709adafb4e 100644 --- a/basis/tools/errors/errors-tests.factor +++ b/basis/tools/errors/errors-tests.factor @@ -6,14 +6,7 @@ DEFER: blah [ ] [ { T{ compiler-error - { error - T{ inference-error - f - T{ do-not-compile f blah } - +compiler-error+ - blah - } - } + { error T{ do-not-compile f blah } } { asset blah } } } errors. From 00b6107d3bd4efb2523625f311fcd029e38af6a0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:12:23 -0500 Subject: [PATCH 33/82] Add benchmark.gc1 --- extra/benchmark/gc1/authors.txt | 1 + extra/benchmark/gc1/gc1.factor | 8 ++++++++ 2 files changed, 9 insertions(+) create mode 100644 extra/benchmark/gc1/authors.txt create mode 100644 extra/benchmark/gc1/gc1.factor diff --git a/extra/benchmark/gc1/authors.txt b/extra/benchmark/gc1/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/gc1/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor new file mode 100644 index 0000000000..d201a08ecf --- /dev/null +++ b/extra/benchmark/gc1/gc1.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: math sequences kernel ; +IN: benchmark.gc1 + +: gc1 ( -- ) 6000000 [ >bignum 1+ ] map drop ; + +MAIN: gc1 \ No newline at end of file From 2e115dc5c398fbf0cdea6d3771dcb4d5c9ad65c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 00:20:33 -0500 Subject: [PATCH 34/82] Better prettyprinting of method-body instances --- basis/help/help.factor | 2 +- basis/prettyprint/backend/backend.factor | 15 ++++++++------- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/basis/help/help.factor b/basis/help/help.factor index 956bc220e1..6e09e298f4 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -54,7 +54,7 @@ M: word article-title dup [ parsing-word? ] [ symbol? ] bi or [ name>> ] [ - [ name>> ] + [ unparse ] [ stack-effect [ effect>string " " prepend ] [ "" ] if* ] bi append ] if ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 8004c1141f..1976c84fd1 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -35,8 +35,8 @@ M: effect pprint* effect>string "(" ")" surround text ; name>> "( no name )" or ; : pprint-word ( word -- ) - dup record-vocab - dup word-name* swap word-style styled-text ; + [ record-vocab ] + [ [ word-name* ] [ word-style ] bi styled-text ] bi ; : pprint-prefix ( word quot -- ) ; inline @@ -48,11 +48,12 @@ M: word pprint* [ pprint-word ] [ ?start-group ] [ ?end-group ] tri ; M: method-body pprint* - ; + [ + [ + [ "M\\ " % "method-class" word-prop word-name* % ] + [ " " % "method-generic" word-prop word-name* % ] bi + ] "" make + ] [ word-style ] bi styled-text ; M: real pprint* number>string text ; From d035c91e3fb21a49d34d774f71cd131e9a861178 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 24 Apr 2009 02:05:52 -0400 Subject: [PATCH 35/82] Add pidigits benchmark from language shootout --- extra/benchmark/pidigits/authors.txt | 1 + extra/benchmark/pidigits/pidigits.factor | 59 ++++++++++++++++++++++++ 2 files changed, 60 insertions(+) create mode 100644 extra/benchmark/pidigits/authors.txt create mode 100644 extra/benchmark/pidigits/pidigits.factor diff --git a/extra/benchmark/pidigits/authors.txt b/extra/benchmark/pidigits/authors.txt new file mode 100644 index 0000000000..4eec9c9a08 --- /dev/null +++ b/extra/benchmark/pidigits/authors.txt @@ -0,0 +1 @@ +Aaron Schaefer diff --git a/extra/benchmark/pidigits/pidigits.factor b/extra/benchmark/pidigits/pidigits.factor new file mode 100644 index 0000000000..5de5cc5e99 --- /dev/null +++ b/extra/benchmark/pidigits/pidigits.factor @@ -0,0 +1,59 @@ +! Copyright (c) 2009 Aaron Schaefer. All rights reserved. +! The contents of this file are licensed under the Simplified BSD License +! A copy of the license is available at http://factorcode.org/license.txt +USING: arrays formatting fry grouping io kernel locals math math.functions + math.matrices math.parser math.primes.factors math.vectors prettyprint + sequences sequences.deep sets ; +IN: benchmark.pidigits + +: extract ( z x -- n ) + 1 2array '[ _ v* sum ] map first2 /i ; + +: next ( z -- n ) + 3 extract ; + +: safe? ( z n -- ? ) + [ 4 extract ] dip = ; + +: >matrix ( q s r t -- z ) + 4array 2 group ; + +: produce ( z n -- z' ) + [ 10 ] dip -10 * 0 1 >matrix swap m. ; + +: gen-x ( x -- matrix ) + dup 2 * 1 + [ 2 * 0 ] keep >matrix ; + +: consume ( z k -- z' ) + gen-x m. ; + +:: (padded-total) ( row col -- str n format ) + "" row col + "%" "s\t:%d\n" + 10 col - number>string glue ; + +: padded-total ( row col -- ) + (padded-total) '[ _ printf ] call( str n -- ) ; + +:: (pidigits) ( k z n row col -- ) + n 0 > [ + z next :> y + z y safe? [ + col 10 = [ + row 10 + y "\t:%d\n%d" printf + k z y produce n 1 - row 10 + 1 (pidigits) + ] [ + y number>string write + k z y produce n 1 - row col 1 + (pidigits) + ] if + ] [ + k 1 + z k consume n row col (pidigits) + ] if + ] [ row col padded-total ] if ; + +: pidigits ( n -- ) + [ 1 { { 1 0 } { 0 1 } } ] dip 0 0 (pidigits) ; + +: pidigits-main ( -- ) + 10000 pidigits ; + +MAIN: pidigits-main From eb4981fb007d0527cf6325c238ed2b7d2ce5b13e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 01:14:02 -0500 Subject: [PATCH 36/82] ui.gadgets.tables: if model changes, try to preserve selection --- basis/ui/gadgets/tables/tables-tests.factor | 35 ++++++++++++++++--- basis/ui/gadgets/tables/tables.factor | 37 ++++++++++++++++----- 2 files changed, 59 insertions(+), 13 deletions(-) diff --git a/basis/ui/gadgets/tables/tables-tests.factor b/basis/ui/gadgets/tables/tables-tests.factor index 11f080af0a..3191753324 100644 --- a/basis/ui/gadgets/tables/tables-tests.factor +++ b/basis/ui/gadgets/tables/tables-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.tables.tests -USING: ui.gadgets.tables ui.gadgets.scrollers accessors -models namespaces tools.test kernel ; +USING: ui.gadgets.tables ui.gadgets.scrollers ui.gadgets.debug accessors +models namespaces tools.test kernel combinators ; SINGLETON: test-renderer @@ -8,15 +8,40 @@ M: test-renderer row-columns drop ; M: test-renderer column-titles drop { "First" "Last" } ; -[ ] [ +: test-table ( -- table ) { { "Britney" "Spears" } { "Justin" "Timberlake" } { "Don" "Stewart" } - } test-renderer - "table" set + } test-renderer
; + +[ ] [ + test-table "table" set ] unit-test [ ] [ "table" get "scroller" set +] unit-test + +[ { "Justin" "Timberlake" } { "Britney" "Spears" } ] [ + test-table t >>selection-required? dup [ + { + [ 1 select-row ] + [ + model>> { + { "Justin" "Timberlake" } + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + [ + model>> { + { "Britney" "Spears" } + { "Don" "Stewart" } + } swap set-model + ] + [ selected-row drop ] + } cleave + ] with-grafted-gadget ] unit-test \ No newline at end of file diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor index 3fe2156df0..d390b1e49b 100644 --- a/basis/ui/gadgets/tables/tables.factor +++ b/basis/ui/gadgets/tables/tables.factor @@ -5,8 +5,8 @@ math.functions math.rectangles math.order math.vectors namespaces opengl sequences ui.gadgets ui.gadgets.scrollers ui.gadgets.status-bar ui.gadgets.worlds ui.gestures ui.render ui.pens.solid ui.text ui.commands ui.images ui.gadgets.menus ui.gadgets.line-support -math.rectangles models math.ranges sequences combinators fonts locals -strings ; +math.rectangles models math.ranges sequences combinators +combinators.short-circuit fonts locals strings ; IN: ui.gadgets.tables ! Row rendererer protocol @@ -246,9 +246,6 @@ PRIVATE> : update-selected-value ( table -- ) [ selected-row drop ] [ selected-value>> ] bi set-model ; -: initial-selected-index ( model table -- n/f ) - [ value>> length 1 >= ] [ selection-required?>> ] bi* and 0 f ? ; - : show-row-summary ( table n -- ) over nth-row [ swap [ renderer>> row-value ] keep show-summary ] @@ -258,8 +255,28 @@ PRIVATE> : hide-mouse-help ( table -- ) f >>mouse-index [ hide-status ] [ relayout-1 ] bi ; +: find-row-index ( value table -- n/f ) + [ model>> value>> ] [ renderer>> '[ _ row-value ] map index ] bi ; + +: initial-selected-index ( table -- n/f ) + { + [ model>> value>> empty? not ] + [ selection-required?>> ] + [ drop 0 ] + } 1&& ; + +: (update-selected-index) ( table -- n/f ) + [ selected-value>> value>> ] keep over + [ find-row-index ] [ 2drop f ] if ; + +: update-selected-index ( table -- n/f ) + { + [ (update-selected-index) ] + [ initial-selected-index ] + } 1|| ; + M: table model-changed - [ nip ] [ initial-selected-index ] 2bi { + nip dup update-selected-index { [ >>selected-index f >>mouse-index drop ] [ show-row-summary ] [ drop update-selected-value ] @@ -302,6 +319,8 @@ PRIVATE> : table-button-up ( table -- ) dup row-action? [ row-action ] [ update-selected-value ] if ; +PRIVATE> + : select-row ( table n -- ) over validate-line [ (select-row) ] @@ -309,6 +328,8 @@ PRIVATE> [ show-row-summary ] 2tri ; +> ] dip '[ _ + ] [ 0 ] if* select-row ; @@ -354,9 +375,9 @@ PRIVATE> show-operations-menu ] [ drop ] if-mouse-row ; -: focus-table ( table -- ) t >>focused? drop ; +: focus-table ( table -- ) t >>focused? relayout-1 ; -: unfocus-table ( table -- ) f >>focused? drop ; +: unfocus-table ( table -- ) f >>focused? relayout-1 ; table "sundry" f { { mouse-enter show-mouse-help } From 0759ddcfcaf74a5853ba172af9eff4a4f285a0e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 01:18:29 -0500 Subject: [PATCH 37/82] fix io.directories.search -- doens't call link-info twice on every file now --- basis/io/directories/search/search.factor | 28 +++++++++++------------ 1 file changed, 13 insertions(+), 15 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 1346fbbdb8..87fbf67110 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -6,15 +6,20 @@ sequences system vocabs.loader locals math namespaces sorting assocs calendar threads ; IN: io.directories.search +: qualified-directory-entries ( path -- seq ) + dup directory-entries + [ [ append-path ] change-name ] with map ; + +: qualified-directory-files ( path -- seq ) + dup directory-files [ append-path ] with map ; + > ] when ] dip + [ qualified-directory-entries ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if ] each ; @@ -25,8 +30,9 @@ TUPLE: directory-iterator path bfs queue ; : next-file ( iter -- file/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup link-info directory? - [ over push-directory next-file ] [ nip ] if + dup queue>> pop-back dup directory? + [ over push-directory next-file ] + [ nip name>> ] if ] if ; :: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) @@ -70,14 +76,6 @@ ERROR: file-not-found ; : find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) '[ _ _ find-all-files ] map concat ; inline -: qualified-directory-entries ( path -- seq ) - directory-entries - current-directory get '[ [ _ prepend-path ] change-name ] map ; - -: qualified-directory-files ( path -- seq ) - directory-files - current-directory get '[ _ prepend-path ] map ; - : with-qualified-directory-files ( path quot -- ) '[ "" qualified-directory-files @ ] with-directory ; inline @@ -93,7 +91,7 @@ ERROR: file-not-found ; [ name>> dup ] [ directory? ] bi [ directory-size ] [ - [ link-info size-on-disk>> ] [ drop 0 ] recover + [ link-info size-on-disk>> ] [ 2drop 0 ] recover ] if ; : directory-usage ( path -- assoc ) From 7d0ae65adc84e4db9d7d87b7fd53902f4c22971c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 01:19:28 -0500 Subject: [PATCH 38/82] Don't call notify-error-observers if there weren't any new definitions --- core/compiler/units/units.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c84e8fa73e..c4a137b2ba 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -144,8 +144,8 @@ GENERIC: definitions-changed ( assoc obj -- ) update-tuples process-forgotten-definitions modify-code-heap - updated-definitions dup assoc-empty? [ drop ] [ notify-definition-observers ] if - notify-error-observers ; + updated-definitions dup assoc-empty? + [ drop ] [ notify-definition-observers notify-error-observers ] if ; : with-nested-compilation-unit ( quot -- ) [ From b00d81e47bfcd4e25640ec294091272f98829774 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 09:44:29 -0500 Subject: [PATCH 39/82] Add time spent scanning cards to 'time' output --- basis/tools/time/time.factor | 3 ++- vm/data_gc.c | 14 ++++++++++---- vm/data_gc.h | 1 + 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 58fc531623..0d1d9f6fa1 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -10,7 +10,7 @@ IN: tools.time : time. ( data -- ) unclip "==== RUNNING TIME" print nl 1000000 /f pprint " seconds" print nl - 4 cut* + 5 cut* "==== GARBAGE COLLECTION" print nl [ 6 group @@ -32,6 +32,7 @@ IN: tools.time "Total GC time (us):" "Cards scanned:" "Decks scanned:" + "Card scan time (us):" "Code heap literal scans:" } swap zip simple-table. ] bi* ; diff --git a/vm/data_gc.c b/vm/data_gc.c index cc1df13d58..50f38bc881 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -115,9 +115,13 @@ void copy_gen_cards(CELL gen) old->new references */ void copy_cards(void) { + u64 start = current_micros(); + int i; for(i = collecting_gen + 1; i < data_heap->gen_count; i++) copy_gen_cards(i); + + card_scan_time += (current_micros() - start); } /* Copy all tagged pointers in a range of memory */ @@ -435,7 +439,7 @@ void garbage_collection(CELL gen, return; } - s64 start = current_micros(); + u64 start = current_micros(); performing_gc = true; growing_data_heap = growing_data_heap_; @@ -539,9 +543,10 @@ void primitive_gc_stats(void) total_gc_time += s->gc_time; } - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(total_gc_time))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(cards_scanned))); - GROWABLE_ARRAY_ADD(stats,tag_bignum(long_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(total_gc_time))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(cards_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(decks_scanned))); + GROWABLE_ARRAY_ADD(stats,tag_bignum(ulong_long_to_bignum(card_scan_time))); GROWABLE_ARRAY_ADD(stats,allot_cell(code_heap_scans)); GROWABLE_ARRAY_TRIM(stats); @@ -556,6 +561,7 @@ void clear_gc_stats(void) cards_scanned = 0; decks_scanned = 0; + card_scan_time = 0; code_heap_scans = 0; } diff --git a/vm/data_gc.h b/vm/data_gc.h index feae26706d..52d8b603ad 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -28,6 +28,7 @@ typedef struct { F_GC_STATS gc_stats[MAX_GEN_COUNT]; u64 cards_scanned; u64 decks_scanned; +u64 card_scan_time; CELL code_heap_scans; /* What generation was being collected when copy_code_heap_roots() was last From b1c790da416e845786bbc7203dcc3034f36d4693 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 12:29:29 -0500 Subject: [PATCH 40/82] benchmark.javascript: new benchmark --- extra/benchmark/javascript/authors.txt | 1 + extra/benchmark/javascript/javascript.factor | 10 ++++++++++ .../benchmark/javascript/jquery-1.3.2.min.js | 19 +++++++++++++++++++ 3 files changed, 30 insertions(+) create mode 100644 extra/benchmark/javascript/authors.txt create mode 100644 extra/benchmark/javascript/javascript.factor create mode 100644 extra/benchmark/javascript/jquery-1.3.2.min.js diff --git a/extra/benchmark/javascript/authors.txt b/extra/benchmark/javascript/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/javascript/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/javascript/javascript.factor b/extra/benchmark/javascript/javascript.factor new file mode 100644 index 0000000000..4c05439e99 --- /dev/null +++ b/extra/benchmark/javascript/javascript.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.encodings.utf8 io.files kernel peg.javascript ; +IN: benchmark.javascript + +: javascript-parser-benchmark ( -- ) + "vocab:benchmark/javascript/jquery-1.3.2.min.js" + utf8 file-contents parse-javascript drop ; + +MAIN: javascript-parser-benchmark \ No newline at end of file diff --git a/extra/benchmark/javascript/jquery-1.3.2.min.js b/extra/benchmark/javascript/jquery-1.3.2.min.js new file mode 100644 index 0000000000..b1ae21d8b2 --- /dev/null +++ b/extra/benchmark/javascript/jquery-1.3.2.min.js @@ -0,0 +1,19 @@ +/* + * jQuery JavaScript Library v1.3.2 + * http://jquery.com/ + * + * Copyright (c) 2009 John Resig + * Dual licensed under the MIT and GPL licenses. + * http://docs.jquery.com/License + * + * Date: 2009-02-19 17:34:21 -0500 (Thu, 19 Feb 2009) + * Revision: 6246 + */ +(function(){var l=this,g,y=l.jQuery,p=l.$,o=l.jQuery=l.$=function(E,F){return new o.fn.init(E,F)},D=/^[^<]*(<(.|\s)+>)[^>]*$|^#([\w-]+)$/,f=/^.[^:#\[\.,]*$/;o.fn=o.prototype={init:function(E,H){E=E||document;if(E.nodeType){this[0]=E;this.length=1;this.context=E;return this}if(typeof E==="string"){var G=D.exec(E);if(G&&(G[1]||!H)){if(G[1]){E=o.clean([G[1]],H)}else{var I=document.getElementById(G[3]);if(I&&I.id!=G[3]){return o().find(E)}var F=o(I||[]);F.context=document;F.selector=E;return F}}else{return o(H).find(E)}}else{if(o.isFunction(E)){return o(document).ready(E)}}if(E.selector&&E.context){this.selector=E.selector;this.context=E.context}return this.setArray(o.isArray(E)?E:o.makeArray(E))},selector:"",jquery:"1.3.2",size:function(){return this.length},get:function(E){return E===g?Array.prototype.slice.call(this):this[E]},pushStack:function(F,H,E){var G=o(F);G.prevObject=this;G.context=this.context;if(H==="find"){G.selector=this.selector+(this.selector?" ":"")+E}else{if(H){G.selector=this.selector+"."+H+"("+E+")"}}return G},setArray:function(E){this.length=0;Array.prototype.push.apply(this,E);return this},each:function(F,E){return o.each(this,F,E)},index:function(E){return o.inArray(E&&E.jquery?E[0]:E,this)},attr:function(F,H,G){var E=F;if(typeof F==="string"){if(H===g){return this[0]&&o[G||"attr"](this[0],F)}else{E={};E[F]=H}}return this.each(function(I){for(F in E){o.attr(G?this.style:this,F,o.prop(this,E[F],G,I,F))}})},css:function(E,F){if((E=="width"||E=="height")&&parseFloat(F)<0){F=g}return this.attr(E,F,"curCSS")},text:function(F){if(typeof F!=="object"&&F!=null){return this.empty().append((this[0]&&this[0].ownerDocument||document).createTextNode(F))}var E="";o.each(F||this,function(){o.each(this.childNodes,function(){if(this.nodeType!=8){E+=this.nodeType!=1?this.nodeValue:o.fn.text([this])}})});return E},wrapAll:function(E){if(this[0]){var F=o(E,this[0].ownerDocument).clone();if(this[0].parentNode){F.insertBefore(this[0])}F.map(function(){var G=this;while(G.firstChild){G=G.firstChild}return G}).append(this)}return this},wrapInner:function(E){return this.each(function(){o(this).contents().wrapAll(E)})},wrap:function(E){return this.each(function(){o(this).wrapAll(E)})},append:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.appendChild(E)}})},prepend:function(){return this.domManip(arguments,true,function(E){if(this.nodeType==1){this.insertBefore(E,this.firstChild)}})},before:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this)})},after:function(){return this.domManip(arguments,false,function(E){this.parentNode.insertBefore(E,this.nextSibling)})},end:function(){return this.prevObject||o([])},push:[].push,sort:[].sort,splice:[].splice,find:function(E){if(this.length===1){var F=this.pushStack([],"find",E);F.length=0;o.find(E,this[0],F);return F}else{return this.pushStack(o.unique(o.map(this,function(G){return o.find(E,G)})),"find",E)}},clone:function(G){var E=this.map(function(){if(!o.support.noCloneEvent&&!o.isXMLDoc(this)){var I=this.outerHTML;if(!I){var J=this.ownerDocument.createElement("div");J.appendChild(this.cloneNode(true));I=J.innerHTML}return o.clean([I.replace(/ jQuery\d+="(?:\d+|null)"/g,"").replace(/^\s*/,"")])[0]}else{return this.cloneNode(true)}});if(G===true){var H=this.find("*").andSelf(),F=0;E.find("*").andSelf().each(function(){if(this.nodeName!==H[F].nodeName){return}var I=o.data(H[F],"events");for(var K in I){for(var J in I[K]){o.event.add(this,K,I[K][J],I[K][J].data)}}F++})}return E},filter:function(E){return this.pushStack(o.isFunction(E)&&o.grep(this,function(G,F){return E.call(G,F)})||o.multiFilter(E,o.grep(this,function(F){return F.nodeType===1})),"filter",E)},closest:function(E){var G=o.expr.match.POS.test(E)?o(E):null,F=0;return this.map(function(){var H=this;while(H&&H.ownerDocument){if(G?G.index(H)>-1:o(H).is(E)){o.data(H,"closest",F);return H}H=H.parentNode;F++}})},not:function(E){if(typeof E==="string"){if(f.test(E)){return this.pushStack(o.multiFilter(E,this,true),"not",E)}else{E=o.multiFilter(E,this)}}var F=E.length&&E[E.length-1]!==g&&!E.nodeType;return this.filter(function(){return F?o.inArray(this,E)<0:this!=E})},add:function(E){return this.pushStack(o.unique(o.merge(this.get(),typeof E==="string"?o(E):o.makeArray(E))))},is:function(E){return !!E&&o.multiFilter(E,this).length>0},hasClass:function(E){return !!E&&this.is("."+E)},val:function(K){if(K===g){var E=this[0];if(E){if(o.nodeName(E,"option")){return(E.attributes.value||{}).specified?E.value:E.text}if(o.nodeName(E,"select")){var I=E.selectedIndex,L=[],M=E.options,H=E.type=="select-one";if(I<0){return null}for(var F=H?I:0,J=H?I+1:M.length;F=0||o.inArray(this.name,K)>=0)}else{if(o.nodeName(this,"select")){var N=o.makeArray(K);o("option",this).each(function(){this.selected=(o.inArray(this.value,N)>=0||o.inArray(this.text,N)>=0)});if(!N.length){this.selectedIndex=-1}}else{this.value=K}}})},html:function(E){return E===g?(this[0]?this[0].innerHTML.replace(/ jQuery\d+="(?:\d+|null)"/g,""):null):this.empty().append(E)},replaceWith:function(E){return this.after(E).remove()},eq:function(E){return this.slice(E,+E+1)},slice:function(){return this.pushStack(Array.prototype.slice.apply(this,arguments),"slice",Array.prototype.slice.call(arguments).join(","))},map:function(E){return this.pushStack(o.map(this,function(G,F){return E.call(G,F,G)}))},andSelf:function(){return this.add(this.prevObject)},domManip:function(J,M,L){if(this[0]){var I=(this[0].ownerDocument||this[0]).createDocumentFragment(),F=o.clean(J,(this[0].ownerDocument||this[0]),I),H=I.firstChild;if(H){for(var G=0,E=this.length;G1||G>0?I.cloneNode(true):I)}}if(F){o.each(F,z)}}return this;function K(N,O){return M&&o.nodeName(N,"table")&&o.nodeName(O,"tr")?(N.getElementsByTagName("tbody")[0]||N.appendChild(N.ownerDocument.createElement("tbody"))):N}}};o.fn.init.prototype=o.fn;function z(E,F){if(F.src){o.ajax({url:F.src,async:false,dataType:"script"})}else{o.globalEval(F.text||F.textContent||F.innerHTML||"")}if(F.parentNode){F.parentNode.removeChild(F)}}function e(){return +new Date}o.extend=o.fn.extend=function(){var J=arguments[0]||{},H=1,I=arguments.length,E=false,G;if(typeof J==="boolean"){E=J;J=arguments[1]||{};H=2}if(typeof J!=="object"&&!o.isFunction(J)){J={}}if(I==H){J=this;--H}for(;H-1}},swap:function(H,G,I){var E={};for(var F in G){E[F]=H.style[F];H.style[F]=G[F]}I.call(H);for(var F in G){H.style[F]=E[F]}},css:function(H,F,J,E){if(F=="width"||F=="height"){var L,G={position:"absolute",visibility:"hidden",display:"block"},K=F=="width"?["Left","Right"]:["Top","Bottom"];function I(){L=F=="width"?H.offsetWidth:H.offsetHeight;if(E==="border"){return}o.each(K,function(){if(!E){L-=parseFloat(o.curCSS(H,"padding"+this,true))||0}if(E==="margin"){L+=parseFloat(o.curCSS(H,"margin"+this,true))||0}else{L-=parseFloat(o.curCSS(H,"border"+this+"Width",true))||0}})}if(H.offsetWidth!==0){I()}else{o.swap(H,G,I)}return Math.max(0,Math.round(L))}return o.curCSS(H,F,J)},curCSS:function(I,F,G){var L,E=I.style;if(F=="opacity"&&!o.support.opacity){L=o.attr(E,"opacity");return L==""?"1":L}if(F.match(/float/i)){F=w}if(!G&&E&&E[F]){L=E[F]}else{if(q.getComputedStyle){if(F.match(/float/i)){F="float"}F=F.replace(/([A-Z])/g,"-$1").toLowerCase();var M=q.getComputedStyle(I,null);if(M){L=M.getPropertyValue(F)}if(F=="opacity"&&L==""){L="1"}}else{if(I.currentStyle){var J=F.replace(/\-(\w)/g,function(N,O){return O.toUpperCase()});L=I.currentStyle[F]||I.currentStyle[J];if(!/^\d+(px)?$/i.test(L)&&/^\d/.test(L)){var H=E.left,K=I.runtimeStyle.left;I.runtimeStyle.left=I.currentStyle.left;E.left=L||0;L=E.pixelLeft+"px";E.left=H;I.runtimeStyle.left=K}}}}return L},clean:function(F,K,I){K=K||document;if(typeof K.createElement==="undefined"){K=K.ownerDocument||K[0]&&K[0].ownerDocument||document}if(!I&&F.length===1&&typeof F[0]==="string"){var H=/^<(\w+)\s*\/?>$/.exec(F[0]);if(H){return[K.createElement(H[1])]}}var G=[],E=[],L=K.createElement("div");o.each(F,function(P,S){if(typeof S==="number"){S+=""}if(!S){return}if(typeof S==="string"){S=S.replace(/(<(\w+)[^>]*?)\/>/g,function(U,V,T){return T.match(/^(abbr|br|col|img|input|link|meta|param|hr|area|embed)$/i)?U:V+">"});var O=S.replace(/^\s+/,"").substring(0,10).toLowerCase();var Q=!O.indexOf("",""]||!O.indexOf("",""]||O.match(/^<(thead|tbody|tfoot|colg|cap)/)&&[1,"
","
"]||!O.indexOf("",""]||(!O.indexOf("",""]||!O.indexOf("",""]||!o.support.htmlSerialize&&[1,"div
","
"]||[0,"",""];L.innerHTML=Q[1]+S+Q[2];while(Q[0]--){L=L.lastChild}if(!o.support.tbody){var R=/"&&!R?L.childNodes:[];for(var M=N.length-1;M>=0;--M){if(o.nodeName(N[M],"tbody")&&!N[M].childNodes.length){N[M].parentNode.removeChild(N[M])}}}if(!o.support.leadingWhitespace&&/^\s/.test(S)){L.insertBefore(K.createTextNode(S.match(/^\s*/)[0]),L.firstChild)}S=o.makeArray(L.childNodes)}if(S.nodeType){G.push(S)}else{G=o.merge(G,S)}});if(I){for(var J=0;G[J];J++){if(o.nodeName(G[J],"script")&&(!G[J].type||G[J].type.toLowerCase()==="text/javascript")){E.push(G[J].parentNode?G[J].parentNode.removeChild(G[J]):G[J])}else{if(G[J].nodeType===1){G.splice.apply(G,[J+1,0].concat(o.makeArray(G[J].getElementsByTagName("script"))))}I.appendChild(G[J])}}return E}return G},attr:function(J,G,K){if(!J||J.nodeType==3||J.nodeType==8){return g}var H=!o.isXMLDoc(J),L=K!==g;G=H&&o.props[G]||G;if(J.tagName){var F=/href|src|style/.test(G);if(G=="selected"&&J.parentNode){J.parentNode.selectedIndex}if(G in J&&H&&!F){if(L){if(G=="type"&&o.nodeName(J,"input")&&J.parentNode){throw"type property can't be changed"}J[G]=K}if(o.nodeName(J,"form")&&J.getAttributeNode(G)){return J.getAttributeNode(G).nodeValue}if(G=="tabIndex"){var I=J.getAttributeNode("tabIndex");return I&&I.specified?I.value:J.nodeName.match(/(button|input|object|select|textarea)/i)?0:J.nodeName.match(/^(a|area)$/i)&&J.href?0:g}return J[G]}if(!o.support.style&&H&&G=="style"){return o.attr(J.style,"cssText",K)}if(L){J.setAttribute(G,""+K)}var E=!o.support.hrefNormalized&&H&&F?J.getAttribute(G,2):J.getAttribute(G);return E===null?g:E}if(!o.support.opacity&&G=="opacity"){if(L){J.zoom=1;J.filter=(J.filter||"").replace(/alpha\([^)]*\)/,"")+(parseInt(K)+""=="NaN"?"":"alpha(opacity="+K*100+")")}return J.filter&&J.filter.indexOf("opacity=")>=0?(parseFloat(J.filter.match(/opacity=([^)]*)/)[1])/100)+"":""}G=G.replace(/-([a-z])/ig,function(M,N){return N.toUpperCase()});if(L){J[G]=K}return J[G]},trim:function(E){return(E||"").replace(/^\s+|\s+$/g,"")},makeArray:function(G){var E=[];if(G!=null){var F=G.length;if(F==null||typeof G==="string"||o.isFunction(G)||G.setInterval){E[0]=G}else{while(F){E[--F]=G[F]}}}return E},inArray:function(G,H){for(var E=0,F=H.length;E0?this.clone(true):this).get();o.fn[F].apply(o(L[K]),I);J=J.concat(I)}return this.pushStack(J,E,G)}});o.each({removeAttr:function(E){o.attr(this,E,"");if(this.nodeType==1){this.removeAttribute(E)}},addClass:function(E){o.className.add(this,E)},removeClass:function(E){o.className.remove(this,E)},toggleClass:function(F,E){if(typeof E!=="boolean"){E=!o.className.has(this,F)}o.className[E?"add":"remove"](this,F)},remove:function(E){if(!E||o.filter(E,[this]).length){o("*",this).add([this]).each(function(){o.event.remove(this);o.removeData(this)});if(this.parentNode){this.parentNode.removeChild(this)}}},empty:function(){o(this).children().remove();while(this.firstChild){this.removeChild(this.firstChild)}}},function(E,F){o.fn[E]=function(){return this.each(F,arguments)}});function j(E,F){return E[0]&&parseInt(o.curCSS(E[0],F,true),10)||0}var h="jQuery"+e(),v=0,A={};o.extend({cache:{},data:function(F,E,G){F=F==l?A:F;var H=F[h];if(!H){H=F[h]=++v}if(E&&!o.cache[H]){o.cache[H]={}}if(G!==g){o.cache[H][E]=G}return E?o.cache[H][E]:H},removeData:function(F,E){F=F==l?A:F;var H=F[h];if(E){if(o.cache[H]){delete o.cache[H][E];E="";for(E in o.cache[H]){break}if(!E){o.removeData(F)}}}else{try{delete F[h]}catch(G){if(F.removeAttribute){F.removeAttribute(h)}}delete o.cache[H]}},queue:function(F,E,H){if(F){E=(E||"fx")+"queue";var G=o.data(F,E);if(!G||o.isArray(H)){G=o.data(F,E,o.makeArray(H))}else{if(H){G.push(H)}}}return G},dequeue:function(H,G){var E=o.queue(H,G),F=E.shift();if(!G||G==="fx"){F=E[0]}if(F!==g){F.call(H)}}});o.fn.extend({data:function(E,G){var H=E.split(".");H[1]=H[1]?"."+H[1]:"";if(G===g){var F=this.triggerHandler("getData"+H[1]+"!",[H[0]]);if(F===g&&this.length){F=o.data(this[0],E)}return F===g&&H[1]?this.data(H[0]):F}else{return this.trigger("setData"+H[1]+"!",[H[0],G]).each(function(){o.data(this,E,G)})}},removeData:function(E){return this.each(function(){o.removeData(this,E)})},queue:function(E,F){if(typeof E!=="string"){F=E;E="fx"}if(F===g){return o.queue(this[0],E)}return this.each(function(){var G=o.queue(this,E,F);if(E=="fx"&&G.length==1){G[0].call(this)}})},dequeue:function(E){return this.each(function(){o.dequeue(this,E)})}}); +/* + * Sizzle CSS Selector Engine - v0.9.3 + * Copyright 2009, The Dojo Foundation + * Released under the MIT, BSD, and GPL Licenses. + * More information: http://sizzlejs.com/ + */ +(function(){var R=/((?:\((?:\([^()]+\)|[^()]+)+\)|\[(?:\[[^[\]]*\]|['"][^'"]*['"]|[^[\]'"]+)+\]|\\.|[^ >+~,(\[\\]+)+|[>+~])(\s*,\s*)?/g,L=0,H=Object.prototype.toString;var F=function(Y,U,ab,ac){ab=ab||[];U=U||document;if(U.nodeType!==1&&U.nodeType!==9){return[]}if(!Y||typeof Y!=="string"){return ab}var Z=[],W,af,ai,T,ad,V,X=true;R.lastIndex=0;while((W=R.exec(Y))!==null){Z.push(W[1]);if(W[2]){V=RegExp.rightContext;break}}if(Z.length>1&&M.exec(Y)){if(Z.length===2&&I.relative[Z[0]]){af=J(Z[0]+Z[1],U)}else{af=I.relative[Z[0]]?[U]:F(Z.shift(),U);while(Z.length){Y=Z.shift();if(I.relative[Y]){Y+=Z.shift()}af=J(Y,af)}}}else{var ae=ac?{expr:Z.pop(),set:E(ac)}:F.find(Z.pop(),Z.length===1&&U.parentNode?U.parentNode:U,Q(U));af=F.filter(ae.expr,ae.set);if(Z.length>0){ai=E(af)}else{X=false}while(Z.length){var ah=Z.pop(),ag=ah;if(!I.relative[ah]){ah=""}else{ag=Z.pop()}if(ag==null){ag=U}I.relative[ah](ai,ag,Q(U))}}if(!ai){ai=af}if(!ai){throw"Syntax error, unrecognized expression: "+(ah||Y)}if(H.call(ai)==="[object Array]"){if(!X){ab.push.apply(ab,ai)}else{if(U.nodeType===1){for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&(ai[aa]===true||ai[aa].nodeType===1&&K(U,ai[aa]))){ab.push(af[aa])}}}else{for(var aa=0;ai[aa]!=null;aa++){if(ai[aa]&&ai[aa].nodeType===1){ab.push(af[aa])}}}}}else{E(ai,ab)}if(V){F(V,U,ab,ac);if(G){hasDuplicate=false;ab.sort(G);if(hasDuplicate){for(var aa=1;aa":function(Z,U,aa){var X=typeof U==="string";if(X&&!/\W/.test(U)){U=aa?U:U.toUpperCase();for(var V=0,T=Z.length;V=0)){if(!V){T.push(Y)}}else{if(V){U[X]=false}}}}return false},ID:function(T){return T[1].replace(/\\/g,"")},TAG:function(U,T){for(var V=0;T[V]===false;V++){}return T[V]&&Q(T[V])?U[1]:U[1].toUpperCase()},CHILD:function(T){if(T[1]=="nth"){var U=/(-?)(\d*)n((?:\+|-)?\d*)/.exec(T[2]=="even"&&"2n"||T[2]=="odd"&&"2n+1"||!/\D/.test(T[2])&&"0n+"+T[2]||T[2]);T[2]=(U[1]+(U[2]||1))-0;T[3]=U[3]-0}T[0]=L++;return T},ATTR:function(X,U,V,T,Y,Z){var W=X[1].replace(/\\/g,"");if(!Z&&I.attrMap[W]){X[1]=I.attrMap[W]}if(X[2]==="~="){X[4]=" "+X[4]+" "}return X},PSEUDO:function(X,U,V,T,Y){if(X[1]==="not"){if(X[3].match(R).length>1||/^\w/.test(X[3])){X[3]=F(X[3],null,null,U)}else{var W=F.filter(X[3],U,V,true^Y);if(!V){T.push.apply(T,W)}return false}}else{if(I.match.POS.test(X[0])||I.match.CHILD.test(X[0])){return true}}return X},POS:function(T){T.unshift(true);return T}},filters:{enabled:function(T){return T.disabled===false&&T.type!=="hidden"},disabled:function(T){return T.disabled===true},checked:function(T){return T.checked===true},selected:function(T){T.parentNode.selectedIndex;return T.selected===true},parent:function(T){return !!T.firstChild},empty:function(T){return !T.firstChild},has:function(V,U,T){return !!F(T[3],V).length},header:function(T){return/h\d/i.test(T.nodeName)},text:function(T){return"text"===T.type},radio:function(T){return"radio"===T.type},checkbox:function(T){return"checkbox"===T.type},file:function(T){return"file"===T.type},password:function(T){return"password"===T.type},submit:function(T){return"submit"===T.type},image:function(T){return"image"===T.type},reset:function(T){return"reset"===T.type},button:function(T){return"button"===T.type||T.nodeName.toUpperCase()==="BUTTON"},input:function(T){return/input|select|textarea|button/i.test(T.nodeName)}},setFilters:{first:function(U,T){return T===0},last:function(V,U,T,W){return U===W.length-1},even:function(U,T){return T%2===0},odd:function(U,T){return T%2===1},lt:function(V,U,T){return UT[3]-0},nth:function(V,U,T){return T[3]-0==U},eq:function(V,U,T){return T[3]-0==U}},filter:{PSEUDO:function(Z,V,W,aa){var U=V[1],X=I.filters[U];if(X){return X(Z,W,V,aa)}else{if(U==="contains"){return(Z.textContent||Z.innerText||"").indexOf(V[3])>=0}else{if(U==="not"){var Y=V[3];for(var W=0,T=Y.length;W=0)}}},ID:function(U,T){return U.nodeType===1&&U.getAttribute("id")===T},TAG:function(U,T){return(T==="*"&&U.nodeType===1)||U.nodeName===T},CLASS:function(U,T){return(" "+(U.className||U.getAttribute("class"))+" ").indexOf(T)>-1},ATTR:function(Y,W){var V=W[1],T=I.attrHandle[V]?I.attrHandle[V](Y):Y[V]!=null?Y[V]:Y.getAttribute(V),Z=T+"",X=W[2],U=W[4];return T==null?X==="!=":X==="="?Z===U:X==="*="?Z.indexOf(U)>=0:X==="~="?(" "+Z+" ").indexOf(U)>=0:!U?Z&&T!==false:X==="!="?Z!=U:X==="^="?Z.indexOf(U)===0:X==="$="?Z.substr(Z.length-U.length)===U:X==="|="?Z===U||Z.substr(0,U.length+1)===U+"-":false},POS:function(X,U,V,Y){var T=U[2],W=I.setFilters[T];if(W){return W(X,V,U,Y)}}}};var M=I.match.POS;for(var O in I.match){I.match[O]=RegExp(I.match[O].source+/(?![^\[]*\])(?![^\(]*\))/.source)}var E=function(U,T){U=Array.prototype.slice.call(U);if(T){T.push.apply(T,U);return T}return U};try{Array.prototype.slice.call(document.documentElement.childNodes)}catch(N){E=function(X,W){var U=W||[];if(H.call(X)==="[object Array]"){Array.prototype.push.apply(U,X)}else{if(typeof X.length==="number"){for(var V=0,T=X.length;V";var T=document.documentElement;T.insertBefore(U,T.firstChild);if(!!document.getElementById(V)){I.find.ID=function(X,Y,Z){if(typeof Y.getElementById!=="undefined"&&!Z){var W=Y.getElementById(X[1]);return W?W.id===X[1]||typeof W.getAttributeNode!=="undefined"&&W.getAttributeNode("id").nodeValue===X[1]?[W]:g:[]}};I.filter.ID=function(Y,W){var X=typeof Y.getAttributeNode!=="undefined"&&Y.getAttributeNode("id");return Y.nodeType===1&&X&&X.nodeValue===W}}T.removeChild(U)})();(function(){var T=document.createElement("div");T.appendChild(document.createComment(""));if(T.getElementsByTagName("*").length>0){I.find.TAG=function(U,Y){var X=Y.getElementsByTagName(U[1]);if(U[1]==="*"){var W=[];for(var V=0;X[V];V++){if(X[V].nodeType===1){W.push(X[V])}}X=W}return X}}T.innerHTML="";if(T.firstChild&&typeof T.firstChild.getAttribute!=="undefined"&&T.firstChild.getAttribute("href")!=="#"){I.attrHandle.href=function(U){return U.getAttribute("href",2)}}})();if(document.querySelectorAll){(function(){var T=F,U=document.createElement("div");U.innerHTML="

";if(U.querySelectorAll&&U.querySelectorAll(".TEST").length===0){return}F=function(Y,X,V,W){X=X||document;if(!W&&X.nodeType===9&&!Q(X)){try{return E(X.querySelectorAll(Y),V)}catch(Z){}}return T(Y,X,V,W)};F.find=T.find;F.filter=T.filter;F.selectors=T.selectors;F.matches=T.matches})()}if(document.getElementsByClassName&&document.documentElement.getElementsByClassName){(function(){var T=document.createElement("div");T.innerHTML="
";if(T.getElementsByClassName("e").length===0){return}T.lastChild.className="e";if(T.getElementsByClassName("e").length===1){return}I.order.splice(1,0,"CLASS");I.find.CLASS=function(U,V,W){if(typeof V.getElementsByClassName!=="undefined"&&!W){return V.getElementsByClassName(U[1])}}})()}function P(U,Z,Y,ad,aa,ac){var ab=U=="previousSibling"&&!ac;for(var W=0,V=ad.length;W0){X=T;break}}}T=T[U]}ad[W]=X}}}var K=document.compareDocumentPosition?function(U,T){return U.compareDocumentPosition(T)&16}:function(U,T){return U!==T&&(U.contains?U.contains(T):true)};var Q=function(T){return T.nodeType===9&&T.documentElement.nodeName!=="HTML"||!!T.ownerDocument&&Q(T.ownerDocument)};var J=function(T,aa){var W=[],X="",Y,V=aa.nodeType?[aa]:aa;while((Y=I.match.PSEUDO.exec(T))){X+=Y[0];T=T.replace(I.match.PSEUDO,"")}T=I.relative[T]?T+"*":T;for(var Z=0,U=V.length;Z0||T.offsetHeight>0};F.selectors.filters.animated=function(T){return o.grep(o.timers,function(U){return T===U.elem}).length};o.multiFilter=function(V,T,U){if(U){V=":not("+V+")"}return F.matches(V,T)};o.dir=function(V,U){var T=[],W=V[U];while(W&&W!=document){if(W.nodeType==1){T.push(W)}W=W[U]}return T};o.nth=function(X,T,V,W){T=T||1;var U=0;for(;X;X=X[V]){if(X.nodeType==1&&++U==T){break}}return X};o.sibling=function(V,U){var T=[];for(;V;V=V.nextSibling){if(V.nodeType==1&&V!=U){T.push(V)}}return T};return;l.Sizzle=F})();o.event={add:function(I,F,H,K){if(I.nodeType==3||I.nodeType==8){return}if(I.setInterval&&I!=l){I=l}if(!H.guid){H.guid=this.guid++}if(K!==g){var G=H;H=this.proxy(G);H.data=K}var E=o.data(I,"events")||o.data(I,"events",{}),J=o.data(I,"handle")||o.data(I,"handle",function(){return typeof o!=="undefined"&&!o.event.triggered?o.event.handle.apply(arguments.callee.elem,arguments):g});J.elem=I;o.each(F.split(/\s+/),function(M,N){var O=N.split(".");N=O.shift();H.type=O.slice().sort().join(".");var L=E[N];if(o.event.specialAll[N]){o.event.specialAll[N].setup.call(I,K,O)}if(!L){L=E[N]={};if(!o.event.special[N]||o.event.special[N].setup.call(I,K,O)===false){if(I.addEventListener){I.addEventListener(N,J,false)}else{if(I.attachEvent){I.attachEvent("on"+N,J)}}}}L[H.guid]=H;o.event.global[N]=true});I=null},guid:1,global:{},remove:function(K,H,J){if(K.nodeType==3||K.nodeType==8){return}var G=o.data(K,"events"),F,E;if(G){if(H===g||(typeof H==="string"&&H.charAt(0)==".")){for(var I in G){this.remove(K,I+(H||""))}}else{if(H.type){J=H.handler;H=H.type}o.each(H.split(/\s+/),function(M,O){var Q=O.split(".");O=Q.shift();var N=RegExp("(^|\\.)"+Q.slice().sort().join(".*\\.")+"(\\.|$)");if(G[O]){if(J){delete G[O][J.guid]}else{for(var P in G[O]){if(N.test(G[O][P].type)){delete G[O][P]}}}if(o.event.specialAll[O]){o.event.specialAll[O].teardown.call(K,Q)}for(F in G[O]){break}if(!F){if(!o.event.special[O]||o.event.special[O].teardown.call(K,Q)===false){if(K.removeEventListener){K.removeEventListener(O,o.data(K,"handle"),false)}else{if(K.detachEvent){K.detachEvent("on"+O,o.data(K,"handle"))}}}F=null;delete G[O]}}})}for(F in G){break}if(!F){var L=o.data(K,"handle");if(L){L.elem=null}o.removeData(K,"events");o.removeData(K,"handle")}}},trigger:function(I,K,H,E){var G=I.type||I;if(!E){I=typeof I==="object"?I[h]?I:o.extend(o.Event(G),I):o.Event(G);if(G.indexOf("!")>=0){I.type=G=G.slice(0,-1);I.exclusive=true}if(!H){I.stopPropagation();if(this.global[G]){o.each(o.cache,function(){if(this.events&&this.events[G]){o.event.trigger(I,K,this.handle.elem)}})}}if(!H||H.nodeType==3||H.nodeType==8){return g}I.result=g;I.target=H;K=o.makeArray(K);K.unshift(I)}I.currentTarget=H;var J=o.data(H,"handle");if(J){J.apply(H,K)}if((!H[G]||(o.nodeName(H,"a")&&G=="click"))&&H["on"+G]&&H["on"+G].apply(H,K)===false){I.result=false}if(!E&&H[G]&&!I.isDefaultPrevented()&&!(o.nodeName(H,"a")&&G=="click")){this.triggered=true;try{H[G]()}catch(L){}}this.triggered=false;if(!I.isPropagationStopped()){var F=H.parentNode||H.ownerDocument;if(F){o.event.trigger(I,K,F,true)}}},handle:function(K){var J,E;K=arguments[0]=o.event.fix(K||l.event);K.currentTarget=this;var L=K.type.split(".");K.type=L.shift();J=!L.length&&!K.exclusive;var I=RegExp("(^|\\.)"+L.slice().sort().join(".*\\.")+"(\\.|$)");E=(o.data(this,"events")||{})[K.type];for(var G in E){var H=E[G];if(J||I.test(H.type)){K.handler=H;K.data=H.data;var F=H.apply(this,arguments);if(F!==g){K.result=F;if(F===false){K.preventDefault();K.stopPropagation()}}if(K.isImmediatePropagationStopped()){break}}}},props:"altKey attrChange attrName bubbles button cancelable charCode clientX clientY ctrlKey currentTarget data detail eventPhase fromElement handler keyCode metaKey newValue originalTarget pageX pageY prevValue relatedNode relatedTarget screenX screenY shiftKey srcElement target toElement view wheelDelta which".split(" "),fix:function(H){if(H[h]){return H}var F=H;H=o.Event(F);for(var G=this.props.length,J;G;){J=this.props[--G];H[J]=F[J]}if(!H.target){H.target=H.srcElement||document}if(H.target.nodeType==3){H.target=H.target.parentNode}if(!H.relatedTarget&&H.fromElement){H.relatedTarget=H.fromElement==H.target?H.toElement:H.fromElement}if(H.pageX==null&&H.clientX!=null){var I=document.documentElement,E=document.body;H.pageX=H.clientX+(I&&I.scrollLeft||E&&E.scrollLeft||0)-(I.clientLeft||0);H.pageY=H.clientY+(I&&I.scrollTop||E&&E.scrollTop||0)-(I.clientTop||0)}if(!H.which&&((H.charCode||H.charCode===0)?H.charCode:H.keyCode)){H.which=H.charCode||H.keyCode}if(!H.metaKey&&H.ctrlKey){H.metaKey=H.ctrlKey}if(!H.which&&H.button){H.which=(H.button&1?1:(H.button&2?3:(H.button&4?2:0)))}return H},proxy:function(F,E){E=E||function(){return F.apply(this,arguments)};E.guid=F.guid=F.guid||E.guid||this.guid++;return E},special:{ready:{setup:B,teardown:function(){}}},specialAll:{live:{setup:function(E,F){o.event.add(this,F[0],c)},teardown:function(G){if(G.length){var E=0,F=RegExp("(^|\\.)"+G[0]+"(\\.|$)");o.each((o.data(this,"events").live||{}),function(){if(F.test(this.type)){E++}});if(E<1){o.event.remove(this,G[0],c)}}}}}};o.Event=function(E){if(!this.preventDefault){return new o.Event(E)}if(E&&E.type){this.originalEvent=E;this.type=E.type}else{this.type=E}this.timeStamp=e();this[h]=true};function k(){return false}function u(){return true}o.Event.prototype={preventDefault:function(){this.isDefaultPrevented=u;var E=this.originalEvent;if(!E){return}if(E.preventDefault){E.preventDefault()}E.returnValue=false},stopPropagation:function(){this.isPropagationStopped=u;var E=this.originalEvent;if(!E){return}if(E.stopPropagation){E.stopPropagation()}E.cancelBubble=true},stopImmediatePropagation:function(){this.isImmediatePropagationStopped=u;this.stopPropagation()},isDefaultPrevented:k,isPropagationStopped:k,isImmediatePropagationStopped:k};var a=function(F){var E=F.relatedTarget;while(E&&E!=this){try{E=E.parentNode}catch(G){E=this}}if(E!=this){F.type=F.data;o.event.handle.apply(this,arguments)}};o.each({mouseover:"mouseenter",mouseout:"mouseleave"},function(F,E){o.event.special[E]={setup:function(){o.event.add(this,F,a,E)},teardown:function(){o.event.remove(this,F,a)}}});o.fn.extend({bind:function(F,G,E){return F=="unload"?this.one(F,G,E):this.each(function(){o.event.add(this,F,E||G,E&&G)})},one:function(G,H,F){var E=o.event.proxy(F||H,function(I){o(this).unbind(I,E);return(F||H).apply(this,arguments)});return this.each(function(){o.event.add(this,G,E,F&&H)})},unbind:function(F,E){return this.each(function(){o.event.remove(this,F,E)})},trigger:function(E,F){return this.each(function(){o.event.trigger(E,F,this)})},triggerHandler:function(E,G){if(this[0]){var F=o.Event(E);F.preventDefault();F.stopPropagation();o.event.trigger(F,G,this[0]);return F.result}},toggle:function(G){var E=arguments,F=1;while(F=0){var E=G.slice(I,G.length);G=G.slice(0,I)}var H="GET";if(J){if(o.isFunction(J)){K=J;J=null}else{if(typeof J==="object"){J=o.param(J);H="POST"}}}var F=this;o.ajax({url:G,type:H,dataType:"html",data:J,complete:function(M,L){if(L=="success"||L=="notmodified"){F.html(E?o("
").append(M.responseText.replace(//g,"")).find(E):M.responseText)}if(K){F.each(K,[M.responseText,L,M])}}});return this},serialize:function(){return o.param(this.serializeArray())},serializeArray:function(){return this.map(function(){return this.elements?o.makeArray(this.elements):this}).filter(function(){return this.name&&!this.disabled&&(this.checked||/select|textarea/i.test(this.nodeName)||/text|hidden|password|search/i.test(this.type))}).map(function(E,F){var G=o(this).val();return G==null?null:o.isArray(G)?o.map(G,function(I,H){return{name:F.name,value:I}}):{name:F.name,value:G}}).get()}});o.each("ajaxStart,ajaxStop,ajaxComplete,ajaxError,ajaxSuccess,ajaxSend".split(","),function(E,F){o.fn[F]=function(G){return this.bind(F,G)}});var r=e();o.extend({get:function(E,G,H,F){if(o.isFunction(G)){H=G;G=null}return o.ajax({type:"GET",url:E,data:G,success:H,dataType:F})},getScript:function(E,F){return o.get(E,null,F,"script")},getJSON:function(E,F,G){return o.get(E,F,G,"json")},post:function(E,G,H,F){if(o.isFunction(G)){H=G;G={}}return o.ajax({type:"POST",url:E,data:G,success:H,dataType:F})},ajaxSetup:function(E){o.extend(o.ajaxSettings,E)},ajaxSettings:{url:location.href,global:true,type:"GET",contentType:"application/x-www-form-urlencoded",processData:true,async:true,xhr:function(){return l.ActiveXObject?new ActiveXObject("Microsoft.XMLHTTP"):new XMLHttpRequest()},accepts:{xml:"application/xml, text/xml",html:"text/html",script:"text/javascript, application/javascript",json:"application/json, text/javascript",text:"text/plain",_default:"*/*"}},lastModified:{},ajax:function(M){M=o.extend(true,M,o.extend(true,{},o.ajaxSettings,M));var W,F=/=\?(&|$)/g,R,V,G=M.type.toUpperCase();if(M.data&&M.processData&&typeof M.data!=="string"){M.data=o.param(M.data)}if(M.dataType=="jsonp"){if(G=="GET"){if(!M.url.match(F)){M.url+=(M.url.match(/\?/)?"&":"?")+(M.jsonp||"callback")+"=?"}}else{if(!M.data||!M.data.match(F)){M.data=(M.data?M.data+"&":"")+(M.jsonp||"callback")+"=?"}}M.dataType="json"}if(M.dataType=="json"&&(M.data&&M.data.match(F)||M.url.match(F))){W="jsonp"+r++;if(M.data){M.data=(M.data+"").replace(F,"="+W+"$1")}M.url=M.url.replace(F,"="+W+"$1");M.dataType="script";l[W]=function(X){V=X;I();L();l[W]=g;try{delete l[W]}catch(Y){}if(H){H.removeChild(T)}}}if(M.dataType=="script"&&M.cache==null){M.cache=false}if(M.cache===false&&G=="GET"){var E=e();var U=M.url.replace(/(\?|&)_=.*?(&|$)/,"$1_="+E+"$2");M.url=U+((U==M.url)?(M.url.match(/\?/)?"&":"?")+"_="+E:"")}if(M.data&&G=="GET"){M.url+=(M.url.match(/\?/)?"&":"?")+M.data;M.data=null}if(M.global&&!o.active++){o.event.trigger("ajaxStart")}var Q=/^(\w+:)?\/\/([^\/?#]+)/.exec(M.url);if(M.dataType=="script"&&G=="GET"&&Q&&(Q[1]&&Q[1]!=location.protocol||Q[2]!=location.host)){var H=document.getElementsByTagName("head")[0];var T=document.createElement("script");T.src=M.url;if(M.scriptCharset){T.charset=M.scriptCharset}if(!W){var O=false;T.onload=T.onreadystatechange=function(){if(!O&&(!this.readyState||this.readyState=="loaded"||this.readyState=="complete")){O=true;I();L();T.onload=T.onreadystatechange=null;H.removeChild(T)}}}H.appendChild(T);return g}var K=false;var J=M.xhr();if(M.username){J.open(G,M.url,M.async,M.username,M.password)}else{J.open(G,M.url,M.async)}try{if(M.data){J.setRequestHeader("Content-Type",M.contentType)}if(M.ifModified){J.setRequestHeader("If-Modified-Since",o.lastModified[M.url]||"Thu, 01 Jan 1970 00:00:00 GMT")}J.setRequestHeader("X-Requested-With","XMLHttpRequest");J.setRequestHeader("Accept",M.dataType&&M.accepts[M.dataType]?M.accepts[M.dataType]+", */*":M.accepts._default)}catch(S){}if(M.beforeSend&&M.beforeSend(J,M)===false){if(M.global&&!--o.active){o.event.trigger("ajaxStop")}J.abort();return false}if(M.global){o.event.trigger("ajaxSend",[J,M])}var N=function(X){if(J.readyState==0){if(P){clearInterval(P);P=null;if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}}else{if(!K&&J&&(J.readyState==4||X=="timeout")){K=true;if(P){clearInterval(P);P=null}R=X=="timeout"?"timeout":!o.httpSuccess(J)?"error":M.ifModified&&o.httpNotModified(J,M.url)?"notmodified":"success";if(R=="success"){try{V=o.httpData(J,M.dataType,M)}catch(Z){R="parsererror"}}if(R=="success"){var Y;try{Y=J.getResponseHeader("Last-Modified")}catch(Z){}if(M.ifModified&&Y){o.lastModified[M.url]=Y}if(!W){I()}}else{o.handleError(M,J,R)}L();if(X){J.abort()}if(M.async){J=null}}}};if(M.async){var P=setInterval(N,13);if(M.timeout>0){setTimeout(function(){if(J&&!K){N("timeout")}},M.timeout)}}try{J.send(M.data)}catch(S){o.handleError(M,J,null,S)}if(!M.async){N()}function I(){if(M.success){M.success(V,R)}if(M.global){o.event.trigger("ajaxSuccess",[J,M])}}function L(){if(M.complete){M.complete(J,R)}if(M.global){o.event.trigger("ajaxComplete",[J,M])}if(M.global&&!--o.active){o.event.trigger("ajaxStop")}}return J},handleError:function(F,H,E,G){if(F.error){F.error(H,E,G)}if(F.global){o.event.trigger("ajaxError",[H,F,G])}},active:0,httpSuccess:function(F){try{return !F.status&&location.protocol=="file:"||(F.status>=200&&F.status<300)||F.status==304||F.status==1223}catch(E){}return false},httpNotModified:function(G,E){try{var H=G.getResponseHeader("Last-Modified");return G.status==304||H==o.lastModified[E]}catch(F){}return false},httpData:function(J,H,G){var F=J.getResponseHeader("content-type"),E=H=="xml"||!H&&F&&F.indexOf("xml")>=0,I=E?J.responseXML:J.responseText;if(E&&I.documentElement.tagName=="parsererror"){throw"parsererror"}if(G&&G.dataFilter){I=G.dataFilter(I,H)}if(typeof I==="string"){if(H=="script"){o.globalEval(I)}if(H=="json"){I=l["eval"]("("+I+")")}}return I},param:function(E){var G=[];function H(I,J){G[G.length]=encodeURIComponent(I)+"="+encodeURIComponent(J)}if(o.isArray(E)||E.jquery){o.each(E,function(){H(this.name,this.value)})}else{for(var F in E){if(o.isArray(E[F])){o.each(E[F],function(){H(F,this)})}else{H(F,o.isFunction(E[F])?E[F]():E[F])}}}return G.join("&").replace(/%20/g,"+")}});var m={},n,d=[["height","marginTop","marginBottom","paddingTop","paddingBottom"],["width","marginLeft","marginRight","paddingLeft","paddingRight"],["opacity"]];function t(F,E){var G={};o.each(d.concat.apply([],d.slice(0,E)),function(){G[this]=F});return G}o.fn.extend({show:function(J,L){if(J){return this.animate(t("show",3),J,L)}else{for(var H=0,F=this.length;H").appendTo("body");K=I.css("display");if(K==="none"){K="block"}I.remove();m[G]=K}o.data(this[H],"olddisplay",K)}}for(var H=0,F=this.length;H=0;H--){if(G[H].elem==this){if(E){G[H](true)}G.splice(H,1)}}});if(!E){this.dequeue()}return this}});o.each({slideDown:t("show",1),slideUp:t("hide",1),slideToggle:t("toggle",1),fadeIn:{opacity:"show"},fadeOut:{opacity:"hide"}},function(E,F){o.fn[E]=function(G,H){return this.animate(F,G,H)}});o.extend({speed:function(G,H,F){var E=typeof G==="object"?G:{complete:F||!F&&H||o.isFunction(G)&&G,duration:G,easing:F&&H||H&&!o.isFunction(H)&&H};E.duration=o.fx.off?0:typeof E.duration==="number"?E.duration:o.fx.speeds[E.duration]||o.fx.speeds._default;E.old=E.complete;E.complete=function(){if(E.queue!==false){o(this).dequeue()}if(o.isFunction(E.old)){E.old.call(this)}};return E},easing:{linear:function(G,H,E,F){return E+F*G},swing:function(G,H,E,F){return((-Math.cos(G*Math.PI)/2)+0.5)*F+E}},timers:[],fx:function(F,E,G){this.options=E;this.elem=F;this.prop=G;if(!E.orig){E.orig={}}}});o.fx.prototype={update:function(){if(this.options.step){this.options.step.call(this.elem,this.now,this)}(o.fx.step[this.prop]||o.fx.step._default)(this);if((this.prop=="height"||this.prop=="width")&&this.elem.style){this.elem.style.display="block"}},cur:function(F){if(this.elem[this.prop]!=null&&(!this.elem.style||this.elem.style[this.prop]==null)){return this.elem[this.prop]}var E=parseFloat(o.css(this.elem,this.prop,F));return E&&E>-10000?E:parseFloat(o.curCSS(this.elem,this.prop))||0},custom:function(I,H,G){this.startTime=e();this.start=I;this.end=H;this.unit=G||this.unit||"px";this.now=this.start;this.pos=this.state=0;var E=this;function F(J){return E.step(J)}F.elem=this.elem;if(F()&&o.timers.push(F)&&!n){n=setInterval(function(){var K=o.timers;for(var J=0;J=this.options.duration+this.startTime){this.now=this.end;this.pos=this.state=1;this.update();this.options.curAnim[this.prop]=true;var E=true;for(var F in this.options.curAnim){if(this.options.curAnim[F]!==true){E=false}}if(E){if(this.options.display!=null){this.elem.style.overflow=this.options.overflow;this.elem.style.display=this.options.display;if(o.css(this.elem,"display")=="none"){this.elem.style.display="block"}}if(this.options.hide){o(this.elem).hide()}if(this.options.hide||this.options.show){for(var I in this.options.curAnim){o.attr(this.elem.style,I,this.options.orig[I])}}this.options.complete.call(this.elem)}return false}else{var J=G-this.startTime;this.state=J/this.options.duration;this.pos=o.easing[this.options.easing||(o.easing.swing?"swing":"linear")](this.state,J,0,1,this.options.duration);this.now=this.start+((this.end-this.start)*this.pos);this.update()}return true}};o.extend(o.fx,{speeds:{slow:600,fast:200,_default:400},step:{opacity:function(E){o.attr(E.elem.style,"opacity",E.now)},_default:function(E){if(E.elem.style&&E.elem.style[E.prop]!=null){E.elem.style[E.prop]=E.now+E.unit}else{E.elem[E.prop]=E.now}}}});if(document.documentElement.getBoundingClientRect){o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}var G=this[0].getBoundingClientRect(),J=this[0].ownerDocument,F=J.body,E=J.documentElement,L=E.clientTop||F.clientTop||0,K=E.clientLeft||F.clientLeft||0,I=G.top+(self.pageYOffset||o.boxModel&&E.scrollTop||F.scrollTop)-L,H=G.left+(self.pageXOffset||o.boxModel&&E.scrollLeft||F.scrollLeft)-K;return{top:I,left:H}}}else{o.fn.offset=function(){if(!this[0]){return{top:0,left:0}}if(this[0]===this[0].ownerDocument.body){return o.offset.bodyOffset(this[0])}o.offset.initialized||o.offset.initialize();var J=this[0],G=J.offsetParent,F=J,O=J.ownerDocument,M,H=O.documentElement,K=O.body,L=O.defaultView,E=L.getComputedStyle(J,null),N=J.offsetTop,I=J.offsetLeft;while((J=J.parentNode)&&J!==K&&J!==H){M=L.getComputedStyle(J,null);N-=J.scrollTop,I-=J.scrollLeft;if(J===G){N+=J.offsetTop,I+=J.offsetLeft;if(o.offset.doesNotAddBorder&&!(o.offset.doesAddBorderForTableAndCells&&/^t(able|d|h)$/i.test(J.tagName))){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}F=G,G=J.offsetParent}if(o.offset.subtractsBorderForOverflowNotVisible&&M.overflow!=="visible"){N+=parseInt(M.borderTopWidth,10)||0,I+=parseInt(M.borderLeftWidth,10)||0}E=M}if(E.position==="relative"||E.position==="static"){N+=K.offsetTop,I+=K.offsetLeft}if(E.position==="fixed"){N+=Math.max(H.scrollTop,K.scrollTop),I+=Math.max(H.scrollLeft,K.scrollLeft)}return{top:N,left:I}}}o.offset={initialize:function(){if(this.initialized){return}var L=document.body,F=document.createElement("div"),H,G,N,I,M,E,J=L.style.marginTop,K='
';M={position:"absolute",top:0,left:0,margin:0,border:0,width:"1px",height:"1px",visibility:"hidden"};for(E in M){F.style[E]=M[E]}F.innerHTML=K;L.insertBefore(F,L.firstChild);H=F.firstChild,G=H.firstChild,I=H.nextSibling.firstChild.firstChild;this.doesNotAddBorder=(G.offsetTop!==5);this.doesAddBorderForTableAndCells=(I.offsetTop===5);H.style.overflow="hidden",H.style.position="relative";this.subtractsBorderForOverflowNotVisible=(G.offsetTop===-5);L.style.marginTop="1px";this.doesNotIncludeMarginInBodyOffset=(L.offsetTop===0);L.style.marginTop=J;L.removeChild(F);this.initialized=true},bodyOffset:function(E){o.offset.initialized||o.offset.initialize();var G=E.offsetTop,F=E.offsetLeft;if(o.offset.doesNotIncludeMarginInBodyOffset){G+=parseInt(o.curCSS(E,"marginTop",true),10)||0,F+=parseInt(o.curCSS(E,"marginLeft",true),10)||0}return{top:G,left:F}}};o.fn.extend({position:function(){var I=0,H=0,F;if(this[0]){var G=this.offsetParent(),J=this.offset(),E=/^body|html$/i.test(G[0].tagName)?{top:0,left:0}:G.offset();J.top-=j(this,"marginTop");J.left-=j(this,"marginLeft");E.top+=j(G,"borderTopWidth");E.left+=j(G,"borderLeftWidth");F={top:J.top-E.top,left:J.left-E.left}}return F},offsetParent:function(){var E=this[0].offsetParent||document.body;while(E&&(!/^body|html$/i.test(E.tagName)&&o.css(E,"position")=="static")){E=E.offsetParent}return o(E)}});o.each(["Left","Top"],function(F,E){var G="scroll"+E;o.fn[G]=function(H){if(!this[0]){return null}return H!==g?this.each(function(){this==l||this==document?l.scrollTo(!F?H:o(l).scrollLeft(),F?H:o(l).scrollTop()):this[G]=H}):this[0]==l||this[0]==document?self[F?"pageYOffset":"pageXOffset"]||o.boxModel&&document.documentElement[G]||document.body[G]:this[0][G]}});o.each(["Height","Width"],function(I,G){var E=I?"Left":"Top",H=I?"Right":"Bottom",F=G.toLowerCase();o.fn["inner"+G]=function(){return this[0]?o.css(this[0],F,false,"padding"):null};o.fn["outer"+G]=function(K){return this[0]?o.css(this[0],F,false,K?"margin":"border"):null};var J=G.toLowerCase();o.fn[J]=function(K){return this[0]==l?document.compatMode=="CSS1Compat"&&document.documentElement["client"+G]||document.body["client"+G]:this[0]==document?Math.max(document.documentElement["client"+G],document.body["scroll"+G],document.documentElement["scroll"+G],document.body["offset"+G],document.documentElement["offset"+G]):K===g?(this.length?o.css(this[0],J):null):this.css(J,typeof K==="string"?K:K+"px")}})})(); \ No newline at end of file From 33743c1a3d0a240ca6150ac872b4eab80d32b1db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 14:49:31 -0500 Subject: [PATCH 41/82] refactor io.directories.search --- .../io/directories/search/search-docs.factor | 4 +- basis/io/directories/search/search.factor | 98 +++++++++++-------- 2 files changed, 58 insertions(+), 44 deletions(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 818899606d..fb172b78e0 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -41,11 +41,11 @@ HELP: find-all-files { "path" "a pathname string" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } -{ $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ; +{ $description "Recursively finds all files in the input directory matching the predicate quotation." } ; HELP: find-all-in-directories { $values - { "directories" "a sequence of directory paths" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } + { "directories" "a sequence of directory paths" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } { $description "Finds all files in the input directories matching the predicate quotation in a breadth-first or depth-first traversal." } ; diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 87fbf67110..440c3a0326 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -3,7 +3,7 @@ USING: accessors arrays continuations deques dlists fry io.directories io.files io.files.info io.pathnames kernel sequences system vocabs.loader locals math namespaces -sorting assocs calendar threads ; +sorting assocs calendar threads io math.parser ; IN: io.directories.search : qualified-directory-entries ( path -- seq ) @@ -13,12 +13,17 @@ IN: io.directories.search : qualified-directory-files ( path -- seq ) dup directory-files [ append-path ] with map ; +: with-qualified-directory-files ( path quot -- ) + '[ "" qualified-directory-files @ ] with-directory ; inline + +: with-qualified-directory-entries ( path quot -- ) + '[ "" qualified-directory-entries @ ] with-directory ; inline + > ] when ] dip +: push-directory-entries ( path iter -- ) [ qualified-directory-entries ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if @@ -26,77 +31,86 @@ TUPLE: directory-iterator path bfs queue ; : ( path bfs? -- iterator ) directory-iterator boa - dup path>> over push-directory ; + dup path>> over push-directory-entries ; -: next-file ( iter -- file/f ) +: next-directory-entry ( iter -- directory-entry/f ) dup queue>> deque-empty? [ drop f ] [ - dup queue>> pop-back dup directory? - [ over push-directory next-file ] - [ nip name>> ] if - ] if ; + dup queue>> pop-back + dup directory? + [ name>> over push-directory-entries next-directory-entry ] + [ nip ] if + ] if ; recursive -:: iterate-directory ( iter quot: ( obj -- ? ) -- obj ) - iter next-file [ - quot call [ iter quot iterate-directory ] unless* +:: iterate-directory-entries ( iter quot -- directory-entry/f ) + iter next-directory-entry [ + quot call( obj -- obj ) [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive +: iterate-directory ( iter quot -- path/f ) + [ name>> ] prepose iterate-directory-entries ; + +: setup-traversal ( path bfs quot -- iterator quot' ) + [ ] dip [ f ] compose ; + PRIVATE> -: each-file ( path bfs? quot: ( obj -- ) -- ) - [ ] dip - [ f ] compose iterate-directory drop ; inline +: each-file ( path bfs? quot -- ) + setup-traversal [ name>> ] prepose + iterate-directory-entries drop ; inline -: recursive-directory ( path bfs? -- paths ) +: each-directory-entry ( path bfs? quot -- ) + setup-traversal iterate-directory-entries drop ; + +: recursive-directory-files ( path bfs? -- paths ) [ ] accumulator [ each-file ] dip ; -: find-file ( path bfs? quot: ( obj -- ? ) -- path/f ) +: recursive-directory-entries ( path bfs? -- paths ) + [ ] accumulator [ each-directory-entry ] dip ; + +: find-file ( path bfs? quot -- path/f ) '[ _ _ _ [ ] dip [ keep and ] curry iterate-directory - ] [ drop f ] recover ; inline + ] [ drop f ] recover ; -: find-all-files ( path quot: ( obj -- ? ) -- paths/f ) - f swap +: find-all-files ( path quot -- paths/f ) '[ - _ _ _ [ ] dip + _ _ [ f ] dip pusher [ [ f ] compose iterate-directory drop ] dip - ] [ drop f ] recover ; inline + ] [ drop f ] recover ; -ERROR: file-not-found ; +ERROR: file-not-found path bfs? quot ; -: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f ) +: find-file-throws ( path bfs? quot -- path ) + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; + +: find-in-directories ( directories bfs? quot -- path'/f ) '[ - _ [ _ _ find-file [ file-not-found ] unless* ] attempt-all + _ [ _ _ find-file-throws ] attempt-all ] [ drop f - ] recover ; inline + ] recover ; -: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f ) - '[ _ _ find-all-files ] map concat ; inline +: find-all-in-directories ( directories quot -- paths/f ) + '[ _ find-all-files ] map concat ; -: with-qualified-directory-files ( path quot -- ) - '[ "" qualified-directory-files @ ] with-directory ; inline - -: with-qualified-directory-entries ( path quot -- ) - '[ "" qualified-directory-entries @ ] with-directory ; inline +: link-size/0 ( path -- n ) + [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; : directory-size ( path -- n ) - 0 swap t [ - [ link-info size-on-disk>> + ] [ 2drop ] recover - ] each-file ; + 0 swap t [ link-size/0 + ] each-file ; : path>usage ( directory-entry -- name size ) - [ name>> dup ] [ directory? ] bi [ - directory-size - ] [ - [ link-info size-on-disk>> ] [ 2drop 0 ] recover - ] if ; + [ name>> dup ] [ directory? ] bi + [ directory-size ] [ link-size/0 ] if ; : directory-usage ( path -- assoc ) [ - [ [ path>usage ] [ drop name>> 0 ] recover ] { } map>assoc + [ + [ path>usage ] [ drop name>> 0 ] recover + ] { } map>assoc ] with-qualified-directory-entries sort-values ; os windows? [ "io.directories.search.windows" require ] when From ad19fd7cbd94b80da080d4ca07590c855b707c8e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 24 Apr 2009 15:02:53 -0500 Subject: [PATCH 42/82] Web 2.0 style assoc syntax. H{ "foo" => 1 "bar" => { 2 3 } } --- extra/pair-rocket/authors.txt | 1 + extra/pair-rocket/pair-rocket-docs.factor | 15 +++++++++++++++ extra/pair-rocket/pair-rocket-tests.factor | 9 +++++++++ extra/pair-rocket/pair-rocket.factor | 6 ++++++ extra/pair-rocket/summary.txt | 1 + 5 files changed, 32 insertions(+) create mode 100644 extra/pair-rocket/authors.txt create mode 100644 extra/pair-rocket/pair-rocket-docs.factor create mode 100644 extra/pair-rocket/pair-rocket-tests.factor create mode 100644 extra/pair-rocket/pair-rocket.factor create mode 100644 extra/pair-rocket/summary.txt diff --git a/extra/pair-rocket/authors.txt b/extra/pair-rocket/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-rocket/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-rocket/pair-rocket-docs.factor b/extra/pair-rocket/pair-rocket-docs.factor new file mode 100644 index 0000000000..d66df62347 --- /dev/null +++ b/extra/pair-rocket/pair-rocket-docs.factor @@ -0,0 +1,15 @@ +! (c)2009 Joe Groff bsd license +USING: help.markup help.syntax multiline ; +IN: pair-rocket + +HELP: => +{ $syntax "a => b" } +{ $description "Constructs a two-element array from the objects immediately before and after the " { $snippet "=>" } ". This syntax can be used inside sequence and assoc literals." } +{ $examples +{ $unchecked-example <" USING: pair-rocket prettyprint ; + +H{ "foo" => 1 "bar" => 2 } . +"> <" H{ { "foo" 1 } { "bar" 2 } } "> } +} +; + diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor new file mode 100644 index 0000000000..0e3d27beb1 --- /dev/null +++ b/extra/pair-rocket/pair-rocket-tests.factor @@ -0,0 +1,9 @@ +USING: kernel pair-rocket tools.test ; +IN: pair-rocket.tests + +[ { "a" 1 } ] [ "a" => 1 ] unit-test +[ { { "a" } { 1 } } ] [ { "a" } => { 1 } ] unit-test +[ { drop 1 } ] [ drop => 1 ] unit-test + +[ H{ { "zippity" 5 } { "doo" 2 } { "dah" 7 } } ] +[ H{ "zippity" => 5 "doo" => 2 "dah" => 7 } ] unit-test diff --git a/extra/pair-rocket/pair-rocket.factor b/extra/pair-rocket/pair-rocket.factor new file mode 100644 index 0000000000..3bd8a098f6 --- /dev/null +++ b/extra/pair-rocket/pair-rocket.factor @@ -0,0 +1,6 @@ +! (c)2009 Joe Groff bsd license +USING: arrays kernel parser sequences ; +IN: pair-rocket + +SYNTAX: => dup pop scan-object 2array parsed ; + diff --git a/extra/pair-rocket/summary.txt b/extra/pair-rocket/summary.txt new file mode 100644 index 0000000000..79c8d60149 --- /dev/null +++ b/extra/pair-rocket/summary.txt @@ -0,0 +1 @@ +H{ "foo" => 1 "bar" => 2 } style literal syntax From c3c51e2c60d6409b95e237c9f1dd559b1fbdff6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 15:22:12 -0500 Subject: [PATCH 43/82] more tests for io.directories.search, fix docs, refactoring --- .../io/directories/search/search-docs.factor | 12 ++++++++-- .../io/directories/search/search-tests.factor | 23 ++++++++++++++++--- basis/io/directories/search/search.factor | 13 ++++------- 3 files changed, 35 insertions(+), 13 deletions(-) diff --git a/basis/io/directories/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index fb172b78e0..a6c82a1bff 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -15,13 +15,20 @@ HELP: each-file } } ; -HELP: recursive-directory +HELP: recursive-directory-files { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "paths" "a sequence of pathname strings" } } { $description "Traverses a directory path recursively and returns a sequence of files in a breadth-first or depth-first manner." } ; +HELP: recursive-directory-entries +{ $values + { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } + { "directory-entries" "a sequence of directory-entries" } +} +{ $description "Traverses a directory path recursively and returns a sequence of directory-entries in a breadth-first or depth-first manner." } ; + HELP: find-file { $values { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } @@ -55,7 +62,8 @@ HELP: find-all-in-directories ARTICLE: "io.directories.search" "Searching directories" "The " { $vocab-link "io.directories.search" } " vocabulary contains words used for recursively iterating over a directory and for finding files in a directory tree." $nl "Traversing directories:" -{ $subsection recursive-directory } +{ $subsection recursive-directory-files } +{ $subsection recursive-directory-entries } { $subsection each-file } "Finding files:" { $subsection find-file } diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor index 5281ca9c2b..db4b58c4fd 100644 --- a/basis/io/directories/search/search-tests.factor +++ b/basis/io/directories/search/search-tests.factor @@ -1,12 +1,14 @@ -USING: io.directories.search io.files io.files.unique -io.pathnames kernel namespaces sequences sorting tools.test ; +USING: combinators.smart io.directories +io.directories.hierarchy io.directories.search io.files +io.files.unique io.pathnames kernel namespaces sequences +sorting strings tools.test ; IN: io.directories.search.tests [ t ] [ [ 10 [ "io.paths.test" "gogogo" make-unique-file ] replicate current-temporary-directory get [ ] find-all-files - ] with-unique-directory drop [ natural-sort ] bi@ = + ] cleanup-unique-directory [ natural-sort ] bi@ = ] unit-test [ f ] [ @@ -18,3 +20,18 @@ IN: io.directories.search.tests [ f ] [ { } t [ "asdfasdfasdfasdfasdf" tail? ] find-in-directories ] unit-test + +[ t ] [ + [ + current-temporary-directory get + "the-head" unique-file drop t + [ file-name "the-head" head? ] find-file string? + ] cleanup-unique-directory +] unit-test + +[ t ] [ + [ unique-directory unique-directory ] output>array + [ [ "abcd" append-path touch-file ] each ] + [ [ file-name "abcd" = ] find-all-in-directories length 2 = ] + [ [ delete-tree ] each ] tri +] unit-test diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 440c3a0326..dc97d4fe45 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -43,7 +43,8 @@ TUPLE: directory-iterator path bfs queue ; :: iterate-directory-entries ( iter quot -- directory-entry/f ) iter next-directory-entry [ - quot call( obj -- obj ) [ iter quot iterate-directory-entries ] unless* + quot call( obj -- obj ) + [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive @@ -57,8 +58,7 @@ TUPLE: directory-iterator path bfs queue ; PRIVATE> : each-file ( path bfs? quot -- ) - setup-traversal [ name>> ] prepose - iterate-directory-entries drop ; inline + setup-traversal iterate-directory drop ; : each-directory-entry ( path bfs? quot -- ) setup-traversal iterate-directory-entries drop ; @@ -87,11 +87,8 @@ ERROR: file-not-found path bfs? quot ; 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; : find-in-directories ( directories bfs? quot -- path'/f ) - '[ - _ [ _ _ find-file-throws ] attempt-all - ] [ - drop f - ] recover ; + '[ _ [ _ _ find-file-throws ] attempt-all ] + [ drop f ] recover ; : find-all-in-directories ( directories quot -- paths/f ) '[ _ find-all-files ] map concat ; From 0220609928a6561195225a89761c19458645386b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 16:24:31 -0500 Subject: [PATCH 44/82] handle errors when traversing directories --- basis/io/directories/search/search.factor | 14 +++++--------- 1 file changed, 5 insertions(+), 9 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index dc97d4fe45..2202f7aa08 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -24,7 +24,7 @@ IN: io.directories.search TUPLE: directory-iterator path bfs queue ; : push-directory-entries ( path iter -- ) - [ qualified-directory-entries ] dip '[ + [ [ qualified-directory-entries ] [ 2drop f ] recover ] dip '[ _ [ queue>> ] [ bfs>> ] bi [ push-front ] [ push-back ] if ] each ; @@ -70,16 +70,12 @@ PRIVATE> [ ] accumulator [ each-directory-entry ] dip ; : find-file ( path bfs? quot -- path/f ) - '[ - _ _ _ [ ] dip - [ keep and ] curry iterate-directory - ] [ drop f ] recover ; + [ ] dip + [ keep and ] curry iterate-directory ; : find-all-files ( path quot -- paths/f ) - '[ - _ _ [ f ] dip - pusher [ [ f ] compose iterate-directory drop ] dip - ] [ drop f ] recover ; + [ f ] dip pusher + [ [ f ] compose iterate-directory drop ] dip ; ERROR: file-not-found path bfs? quot ; From 5e5042fe5ff15fa5e4b4d60ccefa6cb3e8d9b9d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 24 Apr 2009 19:01:26 -0500 Subject: [PATCH 45/82] fix help-lint, compilation issue in io.directories.search --- basis/io/directories/search/search.factor | 30 +++++++++++------------ 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index 2202f7aa08..f7d18306f8 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -39,55 +39,55 @@ TUPLE: directory-iterator path bfs queue ; dup directory? [ name>> over push-directory-entries next-directory-entry ] [ nip ] if - ] if ; recursive + ] if ; -:: iterate-directory-entries ( iter quot -- directory-entry/f ) +:: iterate-directory-entries ( iter quot: ( obj -- obj ) -- directory-entry/f ) iter next-directory-entry [ - quot call( obj -- obj ) + quot call [ iter quot iterate-directory-entries ] unless* ] [ f ] if* ; inline recursive : iterate-directory ( iter quot -- path/f ) - [ name>> ] prepose iterate-directory-entries ; + [ name>> ] prepose iterate-directory-entries ; inline : setup-traversal ( path bfs quot -- iterator quot' ) - [ ] dip [ f ] compose ; + [ ] dip [ f ] compose ; inline PRIVATE> : each-file ( path bfs? quot -- ) - setup-traversal iterate-directory drop ; + setup-traversal iterate-directory drop ; inline : each-directory-entry ( path bfs? quot -- ) - setup-traversal iterate-directory-entries drop ; + setup-traversal iterate-directory-entries drop ; inline : recursive-directory-files ( path bfs? -- paths ) - [ ] accumulator [ each-file ] dip ; + [ ] accumulator [ each-file ] dip ; inline -: recursive-directory-entries ( path bfs? -- paths ) - [ ] accumulator [ each-directory-entry ] dip ; +: recursive-directory-entries ( path bfs? -- directory-entries ) + [ ] accumulator [ each-directory-entry ] dip ; inline : find-file ( path bfs? quot -- path/f ) [ ] dip - [ keep and ] curry iterate-directory ; + [ keep and ] curry iterate-directory ; inline : find-all-files ( path quot -- paths/f ) [ f ] dip pusher - [ [ f ] compose iterate-directory drop ] dip ; + [ [ f ] compose iterate-directory drop ] dip ; inline ERROR: file-not-found path bfs? quot ; : find-file-throws ( path bfs? quot -- path ) - 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; + 3dup find-file dup [ 2nip nip ] [ drop file-not-found ] if ; inline : find-in-directories ( directories bfs? quot -- path'/f ) '[ _ [ _ _ find-file-throws ] attempt-all ] - [ drop f ] recover ; + [ drop f ] recover ; inline : find-all-in-directories ( directories quot -- paths/f ) - '[ _ find-all-files ] map concat ; + '[ _ find-all-files ] map concat ; inline : link-size/0 ( path -- n ) [ link-info size-on-disk>> ] [ 2drop 0 ] recover ; From f24bf512890bc009b47f54113e395eada3510606 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 16:52:23 -0500 Subject: [PATCH 46/82] mason: some fixes --- extra/mason/notify/notify.factor | 4 ++-- extra/mason/report/report.factor | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 6bf4ae090d..96e31c4a45 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays accessors io io.sockets io.encodings.utf8 io.files io.launcher kernel make mason.config mason.common mason.email -mason.twitter namespaces sequences ; +mason.twitter namespaces sequences prettyprint ; IN: mason.notify : status-notify ( input-file args -- ) @@ -38,7 +38,7 @@ IN: mason.notify f { "test" } status-notify ; : notify-report ( status -- ) - [ "Build finished with status: " write print flush ] + [ "Build finished with status: " write . flush ] [ [ "report" utf8 file-contents ] dip email-report "report" { "report" } status-notify diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index edc8416235..64d31b4368 100644 --- a/extra/mason/report/report.factor +++ b/extra/mason/report/report.factor @@ -28,7 +28,7 @@ IN: mason.report common-report _ call( -- xml ) [XML <-><-> XML] - pprint-xml + write-xml ] with-file-writer ; inline :: failed-report ( error file what -- status ) From 66b4d42e133a412bbf6f844fab4168ed16804440 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 25 Apr 2009 17:03:50 -0500 Subject: [PATCH 47/82] math.blas: use gfortran by default on linux-x86-64 since latest ubuntu blas packages are compiled with gfortran abi --- basis/math/blas/config/config.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor index 327c546963..09f736c036 100644 --- a/basis/math/blas/config/config.factor +++ b/basis/math/blas/config/config.factor @@ -18,7 +18,7 @@ blas-fortran-abi [ { [ os netbsd? cpu x86.64? and ] [ g95-abi ] } { [ os windows? cpu x86.64? and ] [ gfortran-abi ] } { [ os freebsd? ] [ gfortran-abi ] } - { [ os linux? cpu x86.32? and ] [ gfortran-abi ] } + { [ os linux? ] [ gfortran-abi ] } [ f2c-abi ] } cond ] initialize From 2330ec3042f986abd8714837ca359563ad5f6c55 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 18:59:03 -0500 Subject: [PATCH 48/82] use ui.images drawing code in images.viewer --- extra/images/viewer/viewer.factor | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor index cf9e9c836a..2818c16f9f 100644 --- a/extra/images/viewer/viewer.factor +++ b/extra/images/viewer/viewer.factor @@ -2,33 +2,26 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors images images.loader io.pathnames kernel namespaces opengl opengl.gl opengl.textures sequences strings ui ui.gadgets -ui.gadgets.panes ui.render ; +ui.gadgets.panes ui.render ui.images ; IN: images.viewer -TUPLE: image-gadget < gadget { image image } ; +TUPLE: image-gadget < gadget image-name ; M: image-gadget pref-dim* - image>> dim>> ; - -: draw-image ( image -- ) - 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom - [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri - glDrawPixels ; + image-name>> image-dim ; M: image-gadget draw-gadget* ( gadget -- ) - image>> draw-image ; + image-name>> draw-image ; -: ( image -- gadget ) +: ( image-name -- gadget ) \ image-gadget new - swap >>image ; + swap >>image-name ; : image-window ( path -- gadget ) - [ load-image dup ] [ open-window ] bi ; + [ dup ] [ open-window ] bi ; GENERIC: image. ( object -- ) -M: string image. ( image -- ) load-image image. ; +M: string image. ( image -- ) gadget. ; -M: pathname image. ( image -- ) load-image image. ; - -M: image image. ( image -- ) gadget. ; +M: pathname image. ( image -- ) gadget. ; From 2484ea07b0f7de236bbb5260116a8243f35ea453 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:22:00 -0500 Subject: [PATCH 49/82] support read-only mmap --- basis/io/mmap/functor/functor.factor | 12 ++++++++---- basis/io/mmap/mmap-docs.factor | 8 +++++++- basis/io/mmap/mmap.factor | 24 ++++++++++++++++++++---- basis/io/mmap/unix/unix.factor | 7 ++++++- basis/io/mmap/windows/windows.factor | 11 ++++++++++- 5 files changed, 51 insertions(+), 11 deletions(-) diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 21b3d294c9..a80ce3bc82 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -9,13 +9,14 @@ SLOT: length : mapped-file>direct ( mapped-file type -- alien length ) [ [ address>> ] [ length>> ] bi ] dip - heap-size [ 1- + ] keep /i ; + heap-size [ 1 - + ] keep /i ; FUNCTOR: define-mapped-array ( T -- ) - DEFINES - IS -with-mapped-A-file DEFINES with-mapped-${T}-file + DEFINES + IS +with-mapped-A-file DEFINES with-mapped-${T}-file +with-mapped-A-file-reader DEFINES with-mapped-${T}-file-reader WHERE @@ -25,4 +26,7 @@ WHERE : with-mapped-A-file ( path quot -- ) '[ @ ] with-mapped-file ; inline +: with-mapped-A-file-reader ( path quot -- ) + '[ @ ] with-mapped-file-reader ; inline + ;FUNCTOR diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor index f0adb47321..1da82e42e2 100644 --- a/basis/io/mmap/mmap-docs.factor +++ b/basis/io/mmap/mmap-docs.factor @@ -18,7 +18,13 @@ HELP: HELP: with-mapped-file { $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } -{ $contract "Opens a file and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $contract "Opens a file for read/write access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } +{ $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } +{ $errors "Throws an error if a memory mapping could not be established." } ; + +HELP: with-mapped-file-reader +{ $values { "path" "a pathname string" } { "quot" { $quotation "( mmap -- )" } } } +{ $contract "Opens a file for read-only access and maps its contents into memory, passing the " { $link mapped-file } " instance to the quotation. The mapped file is disposed of when the quotation returns, or if an error is thrown." } { $notes "This is a low-level word, because " { $link mapped-file } " objects simply expose their base address and length. Most applications should use " { $link "io.mmap.arrays" } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 1a58471514..e03d5fb30b 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -8,14 +8,27 @@ IN: io.mmap TUPLE: mapped-file address handle length disposed ; -HOOK: (mapped-file) os ( path length -- address handle ) +HOOK: (mapped-file-reader) os ( path length -- address handle ) +HOOK: (mapped-file-r/w) os ( path length -- address handle ) ERROR: bad-mmap-size path size ; -: ( path -- mmap ) +> ] bi - dup 0 <= [ bad-mmap-size ] when - [ (mapped-file) ] keep + dup 0 <= [ bad-mmap-size ] when ; + +PRIVATE> + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-reader) ] keep + f mapped-file boa ; + +: ( path -- mmap ) + prepare-mapped-file + [ (mapped-file-r/w) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) @@ -25,6 +38,9 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ; : with-mapped-file ( path quot -- ) [ ] dip with-disposal ; inline +: with-mapped-file-reader ( path quot -- ) + [ ] dip with-disposal ; inline + { { [ os unix? ] [ "io.mmap.unix" require ] } { [ os winnt? ] [ "io.mmap.windows" require ] } diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0fa8e1151f..0424321b84 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -13,11 +13,16 @@ IN: io.mmap.unix [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; -M: unix (mapped-file) +M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags mmap-open ; +M: unix (mapped-file-reader) + { PROT_READ } flags + { MAP_FILE MAP_SHARED } flags + mmap-open ; + M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] [ handle>> close-file ] diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index fcdf416511..ebd8109d14 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -28,7 +28,7 @@ M: win32-mapped-file dispose C: win32-mapped-file -M: windows (mapped-file) +M: windows (mapped-file-r/w) [ { GENERIC_WRITE GENERIC_READ } flags OPEN_ALWAYS @@ -37,6 +37,15 @@ M: windows (mapped-file) -rot ] with-destructors ; +M: windows (mapped-file-reader) + [ + GENERIC_READ + OPEN_ALWAYS + { PAGE_READONLY SEC_COMMIT } flags + FILE_MAP_READ mmap-open + -rot + ] with-destructors ; + M: windows close-mapped-file ( mapped-file -- ) [ [ handle>> &dispose drop ] From 345b27a67327d9db425b3c8f3f208105ef1121ab Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:22:03 -0500 Subject: [PATCH 50/82] dog tag for pair-rocket --- extra/pair-rocket/pair-rocket-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/pair-rocket/pair-rocket-tests.factor b/extra/pair-rocket/pair-rocket-tests.factor index 0e3d27beb1..695e50ea7e 100644 --- a/extra/pair-rocket/pair-rocket-tests.factor +++ b/extra/pair-rocket/pair-rocket-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: kernel pair-rocket tools.test ; IN: pair-rocket.tests From 90d40a7650c16dda91e8bc01c33676a8cb0c71cd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:22:46 -0500 Subject: [PATCH 51/82] calculate a magic number in md5 --- basis/checksums/md5/md5.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor index 04c6c2497e..29620b089d 100644 --- a/basis/checksums/md5/md5.factor +++ b/basis/checksums/md5/md5.factor @@ -14,7 +14,7 @@ IN: checksums.md5 SYMBOLS: a b c d old-a old-b old-c old-d ; : T ( N -- Y ) - sin abs 4294967296 * >integer ; foldable + sin abs 32 2^ * >integer ; foldable : initialize-md5 ( -- ) 0 bytes-read set From 592a840c52ad322ef7cf2841e06ea02d1cfd7563 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:22:47 -0500 Subject: [PATCH 52/82] a syntax pearl for literal string arrays --- extra/qw/authors.txt | 1 + extra/qw/qw-docs.factor | 11 +++++++++++ extra/qw/qw-tests.factor | 5 +++++ extra/qw/qw.factor | 5 +++++ extra/qw/summary.txt | 1 + 5 files changed, 23 insertions(+) create mode 100644 extra/qw/authors.txt create mode 100644 extra/qw/qw-docs.factor create mode 100644 extra/qw/qw-tests.factor create mode 100644 extra/qw/qw.factor create mode 100644 extra/qw/summary.txt diff --git a/extra/qw/authors.txt b/extra/qw/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qw/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor new file mode 100644 index 0000000000..8af2c14f1e --- /dev/null +++ b/extra/qw/qw-docs.factor @@ -0,0 +1,11 @@ +USING: help.markup help.syntax multiline ; +IN: qw + +HELP: qw{ +{ $syntax "qw{ lorem ipsum }" } +{ $description "Marks the beginning of a literal array of strings. Component strings are delimited by whitespace." } +{ $examples +{ $unchecked-example <" USING: prettyprint qw ; +qw{ pop quiz my hive of big wild ex tranny jocks } . "> +<" { "pop" "quiz" "my" "hive" "of" "big" "wild" "ex" "tranny" "jocks" } "> } +} ; diff --git a/extra/qw/qw-tests.factor b/extra/qw/qw-tests.factor new file mode 100644 index 0000000000..c9d9208751 --- /dev/null +++ b/extra/qw/qw-tests.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: qw tools.test ; +IN: qw.tests + +[ { "zippity" "doo" "dah" } ] [ qw{ zippity doo dah } ] unit-test diff --git a/extra/qw/qw.factor b/extra/qw/qw.factor new file mode 100644 index 0000000000..ce96587c92 --- /dev/null +++ b/extra/qw/qw.factor @@ -0,0 +1,5 @@ +! (c)2009 Joe Groff bsd license +USING: lexer parser ; +IN: qw + +SYNTAX: qw{ "}" parse-tokens parsed ; diff --git a/extra/qw/summary.txt b/extra/qw/summary.txt new file mode 100644 index 0000000000..8c31961dc8 --- /dev/null +++ b/extra/qw/summary.txt @@ -0,0 +1 @@ +Perlish syntax for literal arrays of whitespace-delimited strings (qw{ foo bar }) From a1fc4616e93dfa85cb991c7d0f9a446fcd312493 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 19:24:01 -0500 Subject: [PATCH 53/82] dog tag again --- extra/qw/qw-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/qw/qw-docs.factor b/extra/qw/qw-docs.factor index 8af2c14f1e..4709ef620d 100644 --- a/extra/qw/qw-docs.factor +++ b/extra/qw/qw-docs.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: help.markup help.syntax multiline ; IN: qw From 71f2e997a6febc2787413bcb28877aac99a4f953 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:26:16 -0500 Subject: [PATCH 54/82] use read-only mmap in id3. save id3 parsing errors --- extra/id3/id3.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index a5671a5822..6025af4926 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -6,7 +6,7 @@ combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser combinators.short-circuit fry namespaces combinators.smart splitting io.encodings.ascii arrays io.files.info unicode.case -io.directories.search literals math.functions ; +io.directories.search literals math.functions continuations ; IN: id3 id3) ( path -- id3v2/f ) +PRIVATE> + +: mp3>id3 ( path -- id3v2/f ) [ [ ] dip { @@ -213,12 +215,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] [ dup id3v1+? [ read-v1+-tags merge-id3v1 ] [ drop ] if ] [ dup id3v2? [ read-v2-tags ] [ drop ] if ] } cleave - ] with-mapped-uchar-file ; - -PRIVATE> - -: mp3>id3 ( path -- id3/f ) - dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; + ] with-mapped-uchar-file-reader ; : find-id3-frame ( id3 name -- obj/f ) swap frames>> at* [ data>> ] when ; @@ -239,8 +236,14 @@ PRIVATE> : find-mp3s ( path -- seq ) [ >lower ".mp3" tail? ] find-all-files ; +ERROR: id3-parse-error path error ; + +: (mp3-paths>id3s) ( seq -- seq' ) + [ dup [ mp3>id3 ] [ \ id3-parse-error boa ] recover ] { } map>assoc ; + : mp3-paths>id3s ( seq -- seq' ) - [ dup mp3>id3 ] { } map>assoc ; + (mp3-paths>id3s) + [ dup second id3-parse-error? [ f over set-second ] when ] map ; : parse-mp3-directory ( path -- seq ) find-mp3s mp3-paths>id3s ; From c44349c74eaca7dea0b41ec86673625ce8480248 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 19:32:44 -0500 Subject: [PATCH 55/82] test read-only mmap --- basis/io/mmap/mmap-tests.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/io/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index a4d55f3c1e..0e1cd1a036 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -7,6 +7,7 @@ IN: io.mmap.tests [ ] [ "12345" "mmap-test-file.txt" temp-file ascii set-file-contents ] unit-test [ ] [ "mmap-test-file.txt" temp-file [ CHAR: 2 0 pick set-nth drop ] with-mapped-char-file ] unit-test [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test +[ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file-reader ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors From 3f764fc8720469b77ed3d37b7069d5bc0b8e675a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 20:02:41 -0500 Subject: [PATCH 56/82] fix file mode for read only mmap in unix --- basis/io/mmap/unix/unix.factor | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 0424321b84..7d12d52361 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -4,26 +4,23 @@ USING: alien io io.files kernel math math.bitwise system unix io.backend.unix io.ports io.mmap destructors locals accessors ; IN: io.mmap.unix -: open-r/w ( path -- fd ) O_RDWR file-mode open-file ; - -:: mmap-open ( path length prot flags -- alien fd ) +:: mmap-open ( path length prot flags open-mode -- alien fd ) [ f length prot flags - path open-r/w [ |dispose drop ] keep + path open-mode file-mode open-file [ |dispose drop ] keep [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; M: unix (mapped-file-r/w) { PROT_READ PROT_WRITE } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDWR mmap-open ; M: unix (mapped-file-reader) { PROT_READ } flags { MAP_FILE MAP_SHARED } flags - mmap-open ; + O_RDONLY mmap-open ; M: unix close-mapped-file ( mmap -- ) [ [ address>> ] [ length>> ] bi munmap io-error ] - [ handle>> close-file ] - bi ; + [ handle>> close-file ] bi ; From e32869b0c305cfea8f932fc2856399aab04c26f0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 20:07:54 -0500 Subject: [PATCH 57/82] =?UTF-8?q?r=C3=B4les?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- extra/roles/roles-tests.factor | 55 +++++++++++++++++++++++++++ extra/roles/roles.factor | 69 ++++++++++++++++++++++++++++++++++ 2 files changed, 124 insertions(+) create mode 100644 extra/roles/roles-tests.factor create mode 100644 extra/roles/roles.factor diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor new file mode 100644 index 0000000000..aaa197f5ed --- /dev/null +++ b/extra/roles/roles-tests.factor @@ -0,0 +1,55 @@ +! (c)2009 Joe Groff bsd license +USING: accessors classes.tuple compiler.units kernel qw roles sequences +tools.test ; +IN: roles.tests + +ROLE: fork tines ; +ROLE: spoon bowl ; +ROLE: instrument tone ; +ROLE: tuning-fork <{ fork instrument } volume ; + +TUPLE: utensil handle ; + +! role consumption and tuple inheritance can be mixed +TUPLE: foon <{ utensil fork spoon } ; +TUPLE: tuning-spork <{ utensil spoon tuning-fork } ; + +! role class testing +[ t ] [ fork role? ] unit-test +[ f ] [ foon role? ] unit-test + +! roles aren't tuple classes by themselves and can't be instantiated +[ f ] [ fork tuple-class? ] unit-test +[ fork new ] must-fail + +! tuples which consume roles fall under their class +[ t ] [ foon new fork? ] unit-test +[ t ] [ foon new spoon? ] unit-test +[ f ] [ foon new tuning-fork? ] unit-test +[ f ] [ foon new instrument? ] unit-test + +[ t ] [ tuning-spork new fork? ] unit-test +[ t ] [ tuning-spork new spoon? ] unit-test +[ t ] [ tuning-spork new tuning-fork? ] unit-test +[ t ] [ tuning-spork new instrument? ] unit-test + +! consumed role slots are placed in tuples in order +[ qw{ handle tines bowl } ] [ foon all-slots [ name>> ] map ] unit-test +[ qw{ handle bowl tines tone volume } ] [ tuning-spork all-slots [ name>> ] map ] unit-test + +! can't combine roles whose slots overlap +ROLE: bong bowl ; +SYMBOL: spong + +[ [ spong { spoon bong } { } define-tuple-class-with-roles ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +[ [ spong { spoon bong } { } define-role ] with-compilation-unit ] +[ role-slot-overlap? ] must-fail-with + +! can't try to inherit multiple tuple classes +TUPLE: tool blade ; +SYMBOL: knife + +[ knife { utensil tool } { } define-tuple-class-with-roles ] +[ multiple-inheritance-attempted? ] must-fail-with diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor new file mode 100644 index 0000000000..f9ce808eb8 --- /dev/null +++ b/extra/roles/roles.factor @@ -0,0 +1,69 @@ +! (c)2009 Joe Groff bsd license +USING: accessors arrays classes classes.mixin classes.parser +classes.tuple classes.tuple.parser combinators +combinators.short-circuit kernel lexer make parser sequences +sets strings words ; +IN: roles + +ERROR: role-slot-overlap class slots ; +ERROR: multiple-inheritance-attempted classes ; + +PREDICATE: role < class + { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ; + +: parse-role-definition ( -- class superroles slots ) + CREATE-CLASS scan { + { ";" [ { } { } ] } + { "<" [ scan-word 1array [ parse-tuple-slots ] { } make ] } + { "<{" [ \ } parse-until >array [ parse-tuple-slots ] { } make ] } + [ { } swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ] + } case ; + +: slot-name ( name/array -- name ) + dup string? [ ] [ first ] if ; +: slot-names ( array -- names ) + [ slot-name ] map ; + +: role-slots ( role -- slots ) + [ "superroles" word-prop [ role-slots ] map concat ] + [ "role-slots" word-prop ] bi append ; + +: role-or-tuple-slot-names ( role-or-tuple -- names ) + dup role? + [ role-slots slot-names ] + [ all-slots [ name>> ] map ] if ; + +: check-for-slot-overlap ( class roles-and-superclass slots -- ) + [ [ role-or-tuple-slot-names ] map concat ] [ slot-names ] bi* append + duplicates dup empty? [ 2drop ] [ role-slot-overlap ] if ; + +: roles>slots ( roles-and-superclass slots -- superclass slots' ) + [ + [ role? ] partition + dup length { + { 0 [ drop tuple ] } + { 1 [ first ] } + [ drop multiple-inheritance-attempted ] + } case + swap [ role-slots ] map concat + ] dip append ; + +: add-to-roles ( class roles -- ) + [ add-mixin-instance ] with each ; + +: (define-role) ( class superroles slots -- ) + [ "superroles" set-word-prop ] [ "role-slots" set-word-prop ] bi-curry* + [ define-mixin-class ] tri ; + +: define-role ( class superroles slots -- ) + [ check-for-slot-overlap ] [ (define-role) ] [ drop add-to-roles ] 3tri ; + +: define-tuple-class-with-roles ( class roles-and-superclass slots -- ) + [ check-for-slot-overlap ] + [ roles>slots define-tuple-class ] + [ drop [ role? ] filter add-to-roles ] 3tri ; + +SYNTAX: ROLE: parse-role-definition define-role ; +SYNTAX: TUPLE: parse-role-definition define-tuple-class-with-roles ; + + From 32d2377df1f0799354e0d21bcae371e5d41d239b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 20:18:45 -0500 Subject: [PATCH 58/82] test method dispatch on roles --- extra/roles/roles-tests.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/extra/roles/roles-tests.factor b/extra/roles/roles-tests.factor index aaa197f5ed..fcbc20db16 100644 --- a/extra/roles/roles-tests.factor +++ b/extra/roles/roles-tests.factor @@ -53,3 +53,15 @@ SYMBOL: knife [ knife { utensil tool } { } define-tuple-class-with-roles ] [ multiple-inheritance-attempted? ] must-fail-with + +! make sure method dispatch works +GENERIC: poke ( pokee poker -- result ) +GENERIC: scoop ( scoopee scooper -- result ) +GENERIC: tune ( tunee tuner -- result ) + +M: fork poke drop " got poked" append ; +M: spoon scoop drop " got scooped" append ; +M: instrument tune drop " got tuned" append ; + +[ "potato got poked" "potato got scooped" "potato got tuned" ] +[ "potato" tuning-spork new [ poke ] [ scoop ] [ tune ] 2tri ] unit-test From 81bef5d62c6f893110871211798168eb5b4f709b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 21:03:12 -0500 Subject: [PATCH 59/82] fix help lint for id3 --- extra/id3/id3.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index 6025af4926..79df00ff5e 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -207,7 +207,7 @@ CONSTANT: id3v1+-offset $[ 128 227 + ] PRIVATE> -: mp3>id3 ( path -- id3v2/f ) +: mp3>id3 ( path -- id3/f ) [ [ ] dip { From 395e4267fd68142716861ec4468441092ddbfc28 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 25 Apr 2009 21:20:19 -0500 Subject: [PATCH 60/82] docs for roles --- extra/roles/authors.txt | 1 + extra/roles/roles-docs.factor | 48 +++++++++++++++++++++++++++++++++++ extra/roles/summary.txt | 1 + 3 files changed, 50 insertions(+) create mode 100644 extra/roles/authors.txt create mode 100644 extra/roles/roles-docs.factor create mode 100644 extra/roles/summary.txt diff --git a/extra/roles/authors.txt b/extra/roles/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/roles/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/roles/roles-docs.factor b/extra/roles/roles-docs.factor new file mode 100644 index 0000000000..412a7b8dcb --- /dev/null +++ b/extra/roles/roles-docs.factor @@ -0,0 +1,48 @@ +! (c)2009 Joe Groff bsd license +USING: classes.mixin help.markup help.syntax kernel multiline roles ; +IN: roles + +HELP: ROLE: +{ $syntax <" ROLE: name slots... ; +ROLE: name < role slots... ; +ROLE: name <{ roles... } slots... ; "> } +{ $description "Defines a new " { $link role } ". " { $link tuple } " classes which inherit this role will contain the specified " { $snippet "slots" } " as well as the slots associated with the optional inherited " { $snippet "roles" } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +HELP: TUPLE: +{ $syntax <" TUPLE: name slots ; +TUPLE: name < estate slots ; +TUPLE: name <{ estates... } slots... ; "> } +{ $description "Defines a new " { $link tuple } " class." +$nl +"The list of inherited " { $snippet "estates" } " is optional; a single tuple superclass and/or a set of " { $link role } "s can be specified. If no superclass is provided, it defaults to " { $link tuple } "." +$nl +"Slot specifiers take one of the following three forms:" +{ $list + { { $snippet "name" } " - a slot which can hold any object, with no attributes" } + { { $snippet "{ name attributes... }" } " - a slot which can hold any object, with optional attributes" } + { { $snippet "{ name class attributes... }" } " - a slot specialized to a specific class, with optional attributes" } +} +"Slot attributes are lists of slot attribute specifiers followed by values; a slot attribute specifier is one of " { $link initial: } " or " { $link read-only } ". See " { $link "tuple-declarations" } " for details." } ; + +{ + POSTPONE: ROLE: + POSTPONE: TUPLE: +} related-words + +HELP: role +{ $class-description "The superclass of all role classes. A " { $snippet "role" } " is a " { $link mixin-class } " that includes a set of slot definitions that can be added to " { $link tuple } " classes alongside other " { $snippet "role" } "s." } ; + +HELP: multiple-inheritance-attempted +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " definition attempts to inherit more than one " { $link tuple } " class." } ; + +HELP: role-slot-overlap +{ $class-description "This error is thrown if a " { $link POSTPONE: TUPLE: } " or " { $link POSTPONE: ROLE: } " definition attempts to inherit a set of " { $link role } "s in which more than one attempts to define the same slot." } ; + diff --git a/extra/roles/summary.txt b/extra/roles/summary.txt new file mode 100644 index 0000000000..a14aae4838 --- /dev/null +++ b/extra/roles/summary.txt @@ -0,0 +1 @@ +Mixins for tuples From bada2176bc6af9bd3cd736aaaf639dcd01bbad1b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Apr 2009 21:21:15 -0500 Subject: [PATCH 61/82] use new locals syntax in calendar, add routine for calculating easter --- basis/calendar/calendar-tests.factor | 9 +++- basis/calendar/calendar.factor | 64 +++++++++++++++++++--------- 2 files changed, 52 insertions(+), 21 deletions(-) diff --git a/basis/calendar/calendar-tests.factor b/basis/calendar/calendar-tests.factor index 256b4e1b42..8d1071122d 100644 --- a/basis/calendar/calendar-tests.factor +++ b/basis/calendar/calendar-tests.factor @@ -1,5 +1,5 @@ USING: arrays calendar kernel math sequences tools.test -continuations system math.order threads ; +continuations system math.order threads accessors ; IN: calendar.tests [ f ] [ 2004 12 32 0 0 0 instant valid-timestamp? ] unit-test @@ -163,3 +163,10 @@ IN: calendar.tests [ t ] [ now 50 milliseconds sleep now before? ] unit-test [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test + +[ 4 12 ] [ 2009 easter [ month>> ] [ day>> ] bi ] unit-test +[ 4 2 ] [ 1961 easter [ month>> ] [ day>> ] bi ] unit-test + +[ f ] [ now dup midnight eq? ] unit-test +[ f ] [ now dup easter eq? ] unit-test +[ f ] [ now dup beginning-of-year eq? ] unit-test diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor index 7a03fe4408..4b58b1b496 100644 --- a/basis/calendar/calendar.factor +++ b/basis/calendar/calendar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays classes.tuple combinators combinators.short-circuit - kernel locals math math.functions math.order namespaces sequences strings - summary system threads vocabs.loader ; +USING: accessors arrays classes.tuple combinators +combinators.short-circuit kernel locals math math.functions +math.order sequences summary system threads vocabs.loader ; IN: calendar HOOK: gmt-offset os ( -- hours minutes seconds ) @@ -94,26 +94,50 @@ CONSTANT: day-abbreviations3 :: julian-day-number ( year month day -- n ) #! Returns a composite date number #! Not valid before year -4800 - [let* | a [ 14 month - 12 /i ] - y [ year 4800 + a - ] - m [ month 12 a * + 3 - ] | - day 153 m * 2 + 5 /i + 365 y * + - y 4 /i + y 100 /i - y 400 /i + 32045 - - ] ; + 14 month - 12 /i :> a + year 4800 + a - :> y + month 12 a * + 3 - :> m + + day 153 m * 2 + 5 /i + 365 y * + + y 4 /i + y 100 /i - y 400 /i + 32045 - ; :: julian-day-number>date ( n -- year month day ) #! Inverse of julian-day-number - [let* | a [ n 32044 + ] - b [ 4 a * 3 + 146097 /i ] - c [ a 146097 b * 4 /i - ] - d [ 4 c * 3 + 1461 /i ] - e [ c 1461 d * 4 /i - ] - m [ 5 e * 2 + 153 /i ] | - 100 b * d + 4800 - - m 10 /i + m 3 + - 12 m 10 /i * - - e 153 m * 2 + 5 /i - 1+ - ] ; + n 32044 + :> a + 4 a * 3 + 146097 /i :> b + a 146097 b * 4 /i - :> c + 4 c * 3 + 1461 /i :> d + c 1461 d * 4 /i - :> e + 5 e * 2 + 153 /i :> m + + 100 b * d + 4800 - + m 10 /i + m 3 + + 12 m 10 /i * - + e 153 m * 2 + 5 /i - 1+ ; + +GENERIC: easter ( obj -- obj' ) + +:: easter-month-day ( year -- month day ) + year 19 mod :> a + year 100 /mod :> c :> b + b 4 /mod :> e :> d + b 8 + 25 /i :> f + b f - 1 + 3 /i :> g + 19 a * b + d - g - 15 + 30 mod :> h + c 4 /mod :> k :> i + 32 2 e * + 2 i * + h - k - 7 mod :> l + a 11 h * + 22 l * + 451 /i :> m + + h l + 7 m * - 114 + 31 /mod 1 + :> day :> month + month day ; + +M: integer easter ( year -- timestamp ) + dup easter-month-day ; + +M: timestamp easter ( timestamp -- timestamp ) + clone + dup year>> easter-month-day + swapd >>day swap >>month ; : >date< ( timestamp -- year month day ) [ year>> ] [ month>> ] [ day>> ] tri ; From cdb17b74333d3cd13f6516cb46ea4d60d4b2dc99 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 00:45:03 -0500 Subject: [PATCH 62/82] make fasta work again --- extra/benchmark/fasta/fasta.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 2ae5ada8a1..f457b90c30 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -46,8 +46,8 @@ CONSTANT: homo-sapiens } : make-cumulative ( freq -- chars floats ) - dup keys >byte-array - swap values >double-array unclip [ + ] accumulate swap suffix ; + [ keys >byte-array ] + [ values >double-array ] bi unclip [ + ] accumulate swap suffix ; :: select-random ( seed chars floats -- seed elt ) floats seed random -rot @@ -55,7 +55,7 @@ CONSTANT: homo-sapiens chars nth-unsafe ; inline : make-random-fasta ( seed len chars floats -- seed ) - [ rot drop select-random ] 2curry B{ } map-as print ; inline + [ rot drop select-random ] 2curry "" map-as print ; inline : write-description ( desc id -- ) ">" write write bl print ; inline @@ -71,7 +71,7 @@ CONSTANT: homo-sapiens :: make-repeat-fasta ( k len alu -- k' ) [let | kn [ alu length ] | - len [ k + kn mod alu nth-unsafe ] B{ } map-as print + len [ k + kn mod alu nth-unsafe ] "" map-as print k len + ] ; inline From a25376278b4cf396fb81c9fbe8b4f36cd112a12c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 00:45:14 -0500 Subject: [PATCH 63/82] set error-summary? to true by default --- basis/listener/listener.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/listener/listener.factor b/basis/listener/listener.factor index d96e0df6c1..68777f2f73 100644 --- a/basis/listener/listener.factor +++ b/basis/listener/listener.factor @@ -62,6 +62,8 @@ SYMBOL: max-stack-items SYMBOL: error-summary? +t error-summary? set-global + Date: Sun, 26 Apr 2009 00:51:47 -0500 Subject: [PATCH 64/82] fix IN: for compiler tests --- basis/compiler/tests/alien.factor | 2 +- basis/compiler/tests/codegen.factor | 4 ++-- basis/compiler/tests/curry.factor | 2 +- basis/compiler/tests/float.factor | 2 +- basis/compiler/tests/folding.factor | 2 +- basis/compiler/tests/intrinsics.factor | 2 +- basis/compiler/tests/optimizer.factor | 2 +- basis/compiler/tests/peg-regression-2.factor | 4 ++-- basis/compiler/tests/peg-regression.factor | 2 +- basis/compiler/tests/redefine0.factor | 2 +- basis/compiler/tests/redefine1.factor | 2 +- basis/compiler/tests/redefine10.factor | 2 +- basis/compiler/tests/redefine11.factor | 2 +- basis/compiler/tests/redefine15.factor | 2 +- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- basis/compiler/tests/redefine5.factor | 2 +- basis/compiler/tests/redefine6.factor | 2 +- basis/compiler/tests/redefine7.factor | 2 +- basis/compiler/tests/redefine8.factor | 2 +- basis/compiler/tests/redefine9.factor | 2 +- basis/compiler/tests/reload.factor | 2 +- basis/compiler/tests/simple.factor | 2 +- basis/compiler/tests/spilling.factor | 2 +- basis/compiler/tests/stack-trace.factor | 2 +- basis/compiler/tests/tuples.factor | 2 +- 27 files changed, 29 insertions(+), 29 deletions(-) diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 4d7882ad08..42ed90d64a 100755 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -5,7 +5,7 @@ continuations effects namespaces.private io io.streams.string memory system threads tools.test math accessors combinators specialized-arrays.float alien.libraries io.pathnames io.backend ; -IN: compiler.tests +IN: compiler.tests.alien << : libfactor-ffi-tests-path ( -- string ) diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 2e02e5476c..c746fdfb45 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -4,7 +4,7 @@ sequences sequences.private tools.test namespaces.private slots.private sequences.private byte-arrays alien alien.accessors layouts words definitions compiler.units io combinators vectors grouping make ; -IN: compiler.tests +IN: compiler.tests.codegen ! Originally, this file did black box testing of templating ! optimization. We now have a different codegen, but the tests @@ -281,4 +281,4 @@ TUPLE: cucumber ; M: cucumber equal? "The cucumber has no equal" throw ; -[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test \ No newline at end of file +[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor index 2d1f15b9a8..32611ba87a 100644 --- a/basis/compiler/tests/curry.factor +++ b/basis/compiler/tests/curry.factor @@ -1,6 +1,6 @@ USING: tools.test quotations math kernel sequences assocs namespaces make compiler.units compiler ; -IN: compiler.tests +IN: compiler.tests.curry [ 3 ] [ 5 [ [ 2 - ] curry call ] compile-call ] unit-test [ 3 ] [ [ 5 [ 2 - ] curry call ] compile-call ] unit-test diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index b439b5f6a4..1a604dbd8e 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.float USING: compiler.units compiler kernel kernel.private memory math math.private tools.test math.floats.private ; diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor index fe2f801de2..5050ce1950 100644 --- a/basis/compiler/tests/folding.factor +++ b/basis/compiler/tests/folding.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.folding ! Calls to generic words were not folded away. diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index 93860db924..a6e827ea33 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -6,7 +6,7 @@ sbufs strings.private slots.private alien math.order alien.accessors alien.c-types alien.syntax alien.strings namespaces libc sequences.private io.encodings.ascii classes compiler ; -IN: compiler.tests +IN: compiler.tests.intrinsics ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index 99bdb18812..bd7008f909 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -5,7 +5,7 @@ quotations classes classes.algebra classes.tuple.private continuations growable namespaces hints alien.accessors compiler.tree.builder compiler.tree.optimizer sequences.deep compiler ; -IN: optimizer.tests +IN: compiler.tests.optimizer GENERIC: xyz ( obj -- obj ) M: array xyz xyz ; diff --git a/basis/compiler/tests/peg-regression-2.factor b/basis/compiler/tests/peg-regression-2.factor index 1efadba3aa..7929d9e6f6 100644 --- a/basis/compiler/tests/peg-regression-2.factor +++ b/basis/compiler/tests/peg-regression-2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.peg-regression-2 USING: peg.ebnf strings tools.test ; GENERIC: ( times -- term' ) @@ -12,4 +12,4 @@ Regexp = Times:t => [[ t ]] ;EBNF -[ "foo" ] [ "a" parse-regexp ] unit-test \ No newline at end of file +[ "foo" ] [ "a" parse-regexp ] unit-test diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor index 56a4021eed..e107135305 100644 --- a/basis/compiler/tests/peg-regression.factor +++ b/basis/compiler/tests/peg-regression.factor @@ -5,7 +5,7 @@ ! end of a compilation unit. USING: kernel accessors peg.ebnf ; -IN: compiler.tests +IN: compiler.tests.peg-regression TUPLE: pipeline-expr background ; diff --git a/basis/compiler/tests/redefine0.factor b/basis/compiler/tests/redefine0.factor index 87b63aa029..3d7a05a74b 100644 --- a/basis/compiler/tests/redefine0.factor +++ b/basis/compiler/tests/redefine0.factor @@ -104,4 +104,4 @@ quot global delete-at \ test-11 forget \ quot forget ] with-compilation-unit -] unit-test \ No newline at end of file +] unit-test diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index a28b183fb6..af0fd52a47 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -1,7 +1,7 @@ USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval strings ; -IN: compiler.tests +IN: compiler.tests.redefine1 GENERIC: method-redefine-generic-1 ( a -- b ) diff --git a/basis/compiler/tests/redefine10.factor b/basis/compiler/tests/redefine10.factor index faae7b8ed1..66edd75097 100644 --- a/basis/compiler/tests/redefine10.factor +++ b/basis/compiler/tests/redefine10.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine10 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine11.factor b/basis/compiler/tests/redefine11.factor index 57f9f9caf0..dbec57e3d5 100644 --- a/basis/compiler/tests/redefine11.factor +++ b/basis/compiler/tests/redefine11.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel classes.mixin arrays ; -IN: compiler.tests +IN: compiler.tests.redefine11 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine15.factor b/basis/compiler/tests/redefine15.factor index 797460a411..33aa080bac 100644 --- a/basis/compiler/tests/redefine15.factor +++ b/basis/compiler/tests/redefine15.factor @@ -17,4 +17,4 @@ DEFER: word-1 [ \ word-3 [ [ 2 + ] bi@ ] (( a b -- c d )) define-declared ] with-compilation-unit -[ 2 3 ] [ 0 word-4 ] unit-test \ No newline at end of file +[ 2 3 ] [ 0 word-4 ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index 6a7b7a6941..f74ba46fd4 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine2 USING: compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval words.symbol ; diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index 87ab100879..a5962ff91a 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine3 USING: accessors compiler compiler.units tools.test math parser kernel sequences sequences.private classes.mixin generic definitions arrays words assocs eval ; diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 88b40f0c5a..5e0c6c0270 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.redefine4 USING: io.streams.string kernel tools.test eval ; : declaration-test-1 ( -- a ) 3 ; flushable diff --git a/basis/compiler/tests/redefine5.factor b/basis/compiler/tests/redefine5.factor index c390f9a1ec..7613987852 100644 --- a/basis/compiler/tests/redefine5.factor +++ b/basis/compiler/tests/redefine5.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine5 ! Regression: if dispatch was eliminated but method was not inlined, ! compiled usage information was not recorded. diff --git a/basis/compiler/tests/redefine6.factor b/basis/compiler/tests/redefine6.factor index 7f1be973e7..fdf3e7edbb 100644 --- a/basis/compiler/tests/redefine6.factor +++ b/basis/compiler/tests/redefine6.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine6 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine7.factor b/basis/compiler/tests/redefine7.factor index d6dfdf20fd..cfe29603f9 100644 --- a/basis/compiler/tests/redefine7.factor +++ b/basis/compiler/tests/redefine7.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine7 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine8.factor b/basis/compiler/tests/redefine8.factor index 3499c5070a..a79bfb5af5 100644 --- a/basis/compiler/tests/redefine8.factor +++ b/basis/compiler/tests/redefine8.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel ; -IN: compiler.tests +IN: compiler.tests.redefine8 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/redefine9.factor b/basis/compiler/tests/redefine9.factor index 25ed5f15db..2598246472 100644 --- a/basis/compiler/tests/redefine9.factor +++ b/basis/compiler/tests/redefine9.factor @@ -1,6 +1,6 @@ USING: eval tools.test compiler.units vocabs multiline words kernel generic.math ; -IN: compiler.tests +IN: compiler.tests.redefine9 ! Mixin redefinition did not recompile all necessary words. diff --git a/basis/compiler/tests/reload.factor b/basis/compiler/tests/reload.factor index b2b65b5868..62c7c31bc2 100644 --- a/basis/compiler/tests/reload.factor +++ b/basis/compiler/tests/reload.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.reload USE: vocabs.loader ! "parser" reload diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor index 11b27979d5..82cc97e0f6 100644 --- a/basis/compiler/tests/simple.factor +++ b/basis/compiler/tests/simple.factor @@ -1,7 +1,7 @@ USING: compiler compiler.units tools.test kernel kernel.private sequences.private math.private math combinators strings alien arrays memory vocabs parser eval ; -IN: compiler.tests +IN: compiler.tests.simple ! Test empty word [ ] [ [ ] compile-call ] unit-test diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor index 4092352fd5..2ec6fbde95 100644 --- a/basis/compiler/tests/spilling.factor +++ b/basis/compiler/tests/spilling.factor @@ -1,6 +1,6 @@ USING: math.private kernel combinators accessors arrays generalizations tools.test ; -IN: compiler.tests +IN: compiler.tests.spilling : float-spill-bug ( a -- b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b b ) { diff --git a/basis/compiler/tests/stack-trace.factor b/basis/compiler/tests/stack-trace.factor index b317ed3eb5..1cb11571ef 100755 --- a/basis/compiler/tests/stack-trace.factor +++ b/basis/compiler/tests/stack-trace.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.stack-trace USING: compiler tools.test namespaces sequences kernel.private kernel math continuations continuations.private words splitting grouping sorting accessors ; diff --git a/basis/compiler/tests/tuples.factor b/basis/compiler/tests/tuples.factor index caa214b70c..fc249d99db 100644 --- a/basis/compiler/tests/tuples.factor +++ b/basis/compiler/tests/tuples.factor @@ -1,4 +1,4 @@ -IN: compiler.tests +IN: compiler.tests.tuples USING: kernel tools.test compiler.units compiler ; TUPLE: color red green blue ; From dd15bd0fee3df59f137754361cb8647b198a561a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 01:25:19 -0500 Subject: [PATCH 65/82] fix morse for characters that don't exist like "\n". "resource:core/kernel/kernel.factor" utf8 file-contents play-as-morse listen to factor! --- extra/morse/morse-tests.factor | 1 + extra/morse/morse.factor | 11 +++++++---- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index fd52df1c4d..13818a06a0 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -41,3 +41,4 @@ IN: morse.tests MORSE] ] unit-test ! [ ] [ "sos" 0.075 play-as-morse* ] unit-test ! [ ] [ "Factor rocks!" play-as-morse ] unit-test +! [ ] [ "\n" play-as-morse ] unit-test diff --git a/extra/morse/morse.factor b/extra/morse/morse.factor index ef4b9d4b88..20989f2f2f 100644 --- a/extra/morse/morse.factor +++ b/extra/morse/morse.factor @@ -3,13 +3,15 @@ USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ; IN: morse +ERROR: no-morse-code ch ; + @@ -74,10 +76,10 @@ CONSTANT: morse-code-table $[ ] : ch>morse ( ch -- morse ) - ch>lower morse-code-table at [ unknown-char ] unless* ; + ch>lower morse-code-table at unknown-char or ; : morse>ch ( str -- ch ) - morse-code-table value-at [ char-gap-char ] unless* ; + morse-code-table value-at char-gap-char or ; Date: Sun, 26 Apr 2009 02:23:33 -0500 Subject: [PATCH 66/82] fix some compiler tests --- basis/compiler/tests/redefine1.factor | 4 ++-- basis/compiler/tests/redefine2.factor | 2 +- basis/compiler/tests/redefine3.factor | 2 +- basis/compiler/tests/redefine4.factor | 2 +- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor index af0fd52a47..6bb623cac4 100644 --- a/basis/compiler/tests/redefine1.factor +++ b/basis/compiler/tests/redefine1.factor @@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ; [ 6 ] [ method-redefine-test-1 ] unit-test -[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-1 ] unit-test @@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ; [ 6 ] [ method-redefine-test-2 ] unit-test -[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine1 USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test [ 7 ] [ method-redefine-test-2 ] unit-test diff --git a/basis/compiler/tests/redefine2.factor b/basis/compiler/tests/redefine2.factor index f74ba46fd4..9112a1e1af 100644 --- a/basis/compiler/tests/redefine2.factor +++ b/basis/compiler/tests/redefine2.factor @@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ; DEFER: redefine2-test -[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test +[ ] [ "USE: sequences USE: kernel IN: compiler.tests.redefine2 TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test [ t ] [ \ redefine2-test symbol? ] unit-test diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor index a5962ff91a..51ce33c1bd 100644 --- a/basis/compiler/tests/redefine3.factor +++ b/basis/compiler/tests/redefine3.factor @@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ; [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test -[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine3 USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test [ "wake up" ] [ sheeple-test ] unit-test [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test diff --git a/basis/compiler/tests/redefine4.factor b/basis/compiler/tests/redefine4.factor index 5e0c6c0270..2320f64af6 100644 --- a/basis/compiler/tests/redefine4.factor +++ b/basis/compiler/tests/redefine4.factor @@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ; [ "" ] [ [ declaration-test ] with-string-writer ] unit-test -[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test +[ ] [ "IN: compiler.tests.redefine4 USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test From fc8b04466a70e6729b964976945d4438979bd588 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 26 Apr 2009 03:26:15 -0500 Subject: [PATCH 67/82] fix morse unit test --- extra/morse/morse-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/morse/morse-tests.factor b/extra/morse/morse-tests.factor index 13818a06a0..f1da7ce139 100644 --- a/extra/morse/morse-tests.factor +++ b/extra/morse/morse-tests.factor @@ -3,7 +3,7 @@ USING: arrays morse strings tools.test ; IN: morse.tests -[ CHAR: ? ] [ CHAR: \\ ch>morse ] unit-test +[ "?" ] [ CHAR: \\ ch>morse ] unit-test [ "..." ] [ CHAR: s ch>morse ] unit-test [ CHAR: s ] [ "..." morse>ch ] unit-test [ CHAR: \s ] [ "..--..--.." morse>ch ] unit-test From 6688cf1c9779dce87529392f3bbdcdcabcd81baa Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 08:42:31 -0500 Subject: [PATCH 68/82] mopping up some noobsauce --- extra/roles/roles.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/roles/roles.factor b/extra/roles/roles.factor index f9ce808eb8..d54b4339a7 100644 --- a/extra/roles/roles.factor +++ b/extra/roles/roles.factor @@ -8,8 +8,8 @@ IN: roles ERROR: role-slot-overlap class slots ; ERROR: multiple-inheritance-attempted classes ; -PREDICATE: role < class - { [ mixin-class? ] [ "role-slots" word-prop >boolean ] } 1&& ; +PREDICATE: role < mixin-class + "role-slots" word-prop >boolean ; : parse-role-definition ( -- class superroles slots ) CREATE-CLASS scan { From 5f756a8019c208e268737282d5a3b93b08a2b658 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 09:15:58 -0500 Subject: [PATCH 69/82] Code GC: segregated free list for faster allocation, combine unmark/build free list/update literals passes into one pass for faster deallocation --- vm/code_gc.c | 166 ++++++++++++++++++++++++++++++++------------------- vm/code_gc.h | 14 ++++- vm/data_gc.c | 9 +-- 3 files changed, 119 insertions(+), 70 deletions(-) diff --git a/vm/code_gc.c b/vm/code_gc.c index c3c5bc9a10..e7fcfd3289 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -1,5 +1,10 @@ #include "master.h" +static void clear_free_list(F_HEAP *heap) +{ + memset(&heap->free,0,sizeof(F_HEAP_FREE_LIST)); +} + /* This malloc-style heap code is reasonably generic. Maybe in the future, it will be used for the data heap too, if we ever get incremental mark/sweep/compact GC. */ @@ -8,17 +13,23 @@ void new_heap(F_HEAP *heap, CELL size) heap->segment = alloc_segment(align_page(size)); if(!heap->segment) fatal_error("Out of memory in new_heap",size); - heap->free_list = NULL; + + clear_free_list(heap); } -/* If there is no previous block, next_free becomes the head of the free list, -else its linked in */ -INLINE void update_free_list(F_HEAP *heap, F_FREE_BLOCK *prev, F_FREE_BLOCK *next_free) +void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) { - if(prev) - prev->next_free = next_free; + if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = block->block.size / BLOCK_SIZE_INCREMENT; + block->next_free = heap->free.small[index]; + heap->free.small[index] = block; + } else - heap->free_list = next_free; + { + block->next_free = heap->free.large; + heap->free.large = block; + } } /* Called after reading the code heap from the image file, and after code GC. @@ -28,7 +39,11 @@ compiling.limit. */ void build_free_list(F_HEAP *heap, CELL size) { F_BLOCK *prev = NULL; - F_FREE_BLOCK *prev_free = NULL; + + clear_free_list(heap); + + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); + F_BLOCK *scan = first_block(heap); F_FREE_BLOCK *end = (F_FREE_BLOCK *)(heap->segment->start + size); @@ -38,8 +53,7 @@ void build_free_list(F_HEAP *heap, CELL size) switch(scan->status) { case B_FREE: - update_free_list(heap,prev_free,(F_FREE_BLOCK *)scan); - prev_free = (F_FREE_BLOCK *)scan; + add_to_free_list(heap,(F_FREE_BLOCK *)scan); break; case B_ALLOCATED: break; @@ -58,10 +72,9 @@ void build_free_list(F_HEAP *heap, CELL size) { end->block.status = B_FREE; end->block.size = heap->segment->end - (CELL)end; - end->next_free = NULL; /* add final free block */ - update_free_list(heap,prev_free,end); + add_to_free_list(heap,end); } /* This branch is taken if the newly loaded image fits exactly, or after code GC */ @@ -70,63 +83,88 @@ void build_free_list(F_HEAP *heap, CELL size) /* even if there's no room at the end of the heap for a new free block, we might have to jigger it up by a few bytes in case prev + prev->size */ - if(prev) - prev->size = heap->segment->end - (CELL)prev; - - /* this is the last free block */ - update_free_list(heap,prev_free,NULL); + if(prev) prev->size = heap->segment->end - (CELL)prev; } } +static void assert_free_block(F_FREE_BLOCK *block) +{ + if(block->block.status != B_FREE) + critical_error("Invalid block in free list",(CELL)block); +} + +F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) +{ + CELL attempt = size; + + while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) + { + int index = attempt / BLOCK_SIZE_INCREMENT; + F_FREE_BLOCK *block = heap->free.small[index]; + if(block) + { + assert_free_block(block); + heap->free.small[index] = block->next_free; + return block; + } + + attempt *= 2; + } + + F_FREE_BLOCK *prev = NULL; + F_FREE_BLOCK *block = heap->free.large; + + while(block) + { + assert_free_block(block); + if(block->block.size >= size) + { + if(prev) + prev->next_free = block->next_free; + else + heap->free.large = block->next_free; + return block; + } + + prev = block; + block = block->next_free; + } + + return NULL; +} + +F_FREE_BLOCK *split_free_block(F_HEAP *heap, F_FREE_BLOCK *block, CELL size) +{ + if(block->block.size != size ) + { + /* split the block in two */ + F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)block + size); + split->block.status = B_FREE; + split->block.size = block->block.size - size; + split->next_free = block->next_free; + block->block.size = size; + add_to_free_list(heap,split); + } + + return block; +} + /* Allocate a block of memory from the mark and sweep GC heap */ F_BLOCK *heap_allot(F_HEAP *heap, CELL size) { - F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *scan = heap->free_list; + size = (size + BLOCK_SIZE_INCREMENT - 1) & ~(BLOCK_SIZE_INCREMENT - 1); - size = (size + 31) & ~31; - - while(scan) + F_FREE_BLOCK *block = find_free_block(heap,size); + if(block) { - if(scan->block.status != B_FREE) - critical_error("Invalid block in free list",(CELL)scan); + block = split_free_block(heap,block,size); - if(scan->block.size < size) - { - prev = scan; - scan = scan->next_free; - continue; - } - - /* we found a candidate block */ - F_FREE_BLOCK *next_free; - - if(scan->block.size - size <= sizeof(F_BLOCK) * 2) - { - /* too small to be split */ - next_free = scan->next_free; - } - else - { - /* split the block in two */ - F_FREE_BLOCK *split = (F_FREE_BLOCK *)((CELL)scan + size); - split->block.status = B_FREE; - split->block.size = scan->block.size - size; - split->next_free = scan->next_free; - scan->block.size = size; - next_free = split; - } - - /* update the free list */ - update_free_list(heap,prev,next_free); - - /* this is our new block */ - scan->block.status = B_ALLOCATED; - return &scan->block; + block->block.status = B_ALLOCATED; + return &block->block; } - - return NULL; + else + return NULL; } void mark_block(F_BLOCK *block) @@ -162,8 +200,10 @@ void unmark_marked(F_HEAP *heap) /* After code GC, all referenced code blocks have status set to B_MARKED, so any which are allocated and not marked can be reclaimed. */ -void free_unmarked(F_HEAP *heap) +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter) { + clear_free_list(heap); + F_BLOCK *prev = NULL; F_BLOCK *scan = first_block(heap); @@ -183,10 +223,15 @@ void free_unmarked(F_HEAP *heap) case B_FREE: if(prev && prev->status == B_FREE) prev->size += scan->size; + else + prev = scan; break; case B_MARKED: + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); scan->status = B_ALLOCATED; prev = scan; + iter(scan); break; default: critical_error("Invalid scan->status",(CELL)scan); @@ -195,7 +240,8 @@ void free_unmarked(F_HEAP *heap) scan = next_block(heap,scan); } - build_free_list(heap,heap->segment->size); + if(prev && prev->status == B_FREE) + add_to_free_list(heap,(F_FREE_BLOCK *)prev); } /* Compute total sum of sizes of free blocks, and size of largest free block */ diff --git a/vm/code_gc.h b/vm/code_gc.h index cc2c42f120..9b1e768a7b 100644 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -1,14 +1,24 @@ +#define FREE_LIST_COUNT 16 +#define BLOCK_SIZE_INCREMENT 32 + +typedef struct { + F_FREE_BLOCK *small[FREE_LIST_COUNT]; + F_FREE_BLOCK *large; +} F_HEAP_FREE_LIST; + typedef struct { F_SEGMENT *segment; - F_FREE_BLOCK *free_list; + F_HEAP_FREE_LIST free; } F_HEAP; +typedef void (*HEAP_ITERATOR)(F_BLOCK *compiled); + void new_heap(F_HEAP *heap, CELL size); void build_free_list(F_HEAP *heap, CELL size); F_BLOCK *heap_allot(F_HEAP *heap, CELL size); void mark_block(F_BLOCK *block); void unmark_marked(F_HEAP *heap); -void free_unmarked(F_HEAP *heap); +void free_unmarked(F_HEAP *heap, HEAP_ITERATOR iter); void heap_usage(F_HEAP *heap, CELL *used, CELL *total_free, CELL *max_free); CELL heap_size(F_HEAP *heap); CELL compute_heap_forwarding(F_HEAP *heap); diff --git a/vm/data_gc.c b/vm/data_gc.c index 50f38bc881..3ab2055d82 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -416,13 +416,6 @@ void end_gc(CELL gc_elapsed) reset_generations(NURSERY,collecting_gen); } - if(collecting_gen == TENURED) - { - /* now that all reachable code blocks have been marked, - deallocate the rest */ - free_unmarked(&code_heap); - } - collecting_aging_again = false; } @@ -491,7 +484,7 @@ void garbage_collection(CELL gen, code_heap_scans++; if(collecting_gen == TENURED) - update_code_heap_roots(); + free_unmarked(&code_heap,(HEAP_ITERATOR)update_literal_references); else copy_code_heap_roots(); From d2e293eb5ea779d2bfbbde84b76009748ab8de6b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 09:39:38 -0500 Subject: [PATCH 70/82] product virtual sequence --- extra/sequences/product/product-tests.factor | 24 ++++++++++------- extra/sequences/product/product.factor | 28 ++++++++++++++++++++ 2 files changed, 42 insertions(+), 10 deletions(-) create mode 100644 extra/sequences/product/product.factor diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index dfabc166ac..0a984072e0 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,19 +1,23 @@ -USING: arrays kernel sequences sequences.cartesian-product tools.test ; +USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests -[ - { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } -] [ { { 0 1 2 } { "a" "b" } } [ ] cartesian-product-map ] unit-test + +[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] +[ { { 0 1 2 } { "a" "b" } } >array ] unit-test + +[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] +[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test [ { { 0 "a" t } { 1 "a" t } { 2 "a" t } { 0 "b" t } { 1 "b" t } { 2 "b" t } { 0 "a" f } { 1 "a" f } { 2 "a" f } { 0 "b" f } { 1 "b" f } { 2 "b" f } } -] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] cartesian-product-map ] unit-test - -[ - { "012012" "aaabbb" } -] [ { { "0" "1" "2" } { "a" "b" } } [ [ first2 ] bi* [ append ] bi@ 2array ] cartesian-product-each ] unit-test - +] [ { { 0 1 2 } { "a" "b" } { t f } } [ ] product-map ] unit-test +[ "a1b1c1a2b2c2" ] [ + [ + { { "a" "b" "c" } { "1" "2" } } + [ [ % ] each ] product-each + ] "" make +] unit-test diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor new file mode 100644 index 0000000000..73ba1e4e01 --- /dev/null +++ b/extra/sequences/product/product.factor @@ -0,0 +1,28 @@ +USING: accessors arrays kernel math sequences ; +IN: sequences.product + +TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; + +: ( sequences -- product-sequence ) + >array dup [ length ] map product-sequence boa ; + +INSTANCE: product-sequence sequence + +M: product-sequence length lengths>> product ; + +: ns ( n lengths -- ns ) + [ V{ } clone ] 2dip [ /mod swap [ over push ] dip ] each drop ; + +: product@ ( n product-sequence -- ns seqs ) + [ lengths>> ns ] [ nip sequences>> ] 2bi ; + +M: product-sequence nth + product@ [ nth ] { } 2map-as ; + +M: product-sequence set-nth + immutable ; + +: product-map ( sequences quot -- sequence ) + [ ] dip map ; inline +: product-each ( sequences quot -- ) + [ ] dip each ; inline From e0f6825757892b7226853af7d54d38c33795bb71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 10:02:52 -0500 Subject: [PATCH 71/82] Rename some fields to avoid conflicting with windows.h macros 'small' and 'large' --- vm/code_gc.c | 16 ++++++++-------- vm/code_gc.h | 4 ++-- 2 files changed, 10 insertions(+), 10 deletions(-) mode change 100644 => 100755 vm/code_gc.h diff --git a/vm/code_gc.c b/vm/code_gc.c index e7fcfd3289..1405daa93f 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -22,13 +22,13 @@ void add_to_free_list(F_HEAP *heap, F_FREE_BLOCK *block) if(block->block.size < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { int index = block->block.size / BLOCK_SIZE_INCREMENT; - block->next_free = heap->free.small[index]; - heap->free.small[index] = block; + block->next_free = heap->free.small_blocks[index]; + heap->free.small_blocks[index] = block; } else { - block->next_free = heap->free.large; - heap->free.large = block; + block->next_free = heap->free.large_blocks; + heap->free.large_blocks = block; } } @@ -101,11 +101,11 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) while(attempt < FREE_LIST_COUNT * BLOCK_SIZE_INCREMENT) { int index = attempt / BLOCK_SIZE_INCREMENT; - F_FREE_BLOCK *block = heap->free.small[index]; + F_FREE_BLOCK *block = heap->free.small_blocks[index]; if(block) { assert_free_block(block); - heap->free.small[index] = block->next_free; + heap->free.small_blocks[index] = block->next_free; return block; } @@ -113,7 +113,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) } F_FREE_BLOCK *prev = NULL; - F_FREE_BLOCK *block = heap->free.large; + F_FREE_BLOCK *block = heap->free.large_blocks; while(block) { @@ -123,7 +123,7 @@ F_FREE_BLOCK *find_free_block(F_HEAP *heap, CELL size) if(prev) prev->next_free = block->next_free; else - heap->free.large = block->next_free; + heap->free.large_blocks = block->next_free; return block; } diff --git a/vm/code_gc.h b/vm/code_gc.h old mode 100644 new mode 100755 index 9b1e768a7b..d71dee29c5 --- a/vm/code_gc.h +++ b/vm/code_gc.h @@ -2,8 +2,8 @@ #define BLOCK_SIZE_INCREMENT 32 typedef struct { - F_FREE_BLOCK *small[FREE_LIST_COUNT]; - F_FREE_BLOCK *large; + F_FREE_BLOCK *small_blocks[FREE_LIST_COUNT]; + F_FREE_BLOCK *large_blocks; } F_HEAP_FREE_LIST; typedef struct { From 303ce55dc6d9ed566d05f36a995ba21200a56626 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 12:27:50 -0500 Subject: [PATCH 72/82] more efficient product-each and product-map that don't /mod all over the place --- extra/sequences/product/product-tests.factor | 6 ++- extra/sequences/product/product.factor | 50 ++++++++++++++++---- 2 files changed, 46 insertions(+), 10 deletions(-) diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 0a984072e0..087d7a6175 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -5,8 +5,10 @@ IN: sequences.product.tests [ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] [ { { 0 1 2 } { "a" "b" } } >array ] unit-test -[ { { 0 "a" } { 1 "a" } { 2 "a" } { 0 "b" } { 1 "b" } { 2 "b" } } ] -[ { { 0 1 2 } { "a" "b" } } [ ] product-map ] unit-test +: x ( n s -- sss ) concat ; + +[ { "a" "aa" "aaa" "b" "bb" "bbb" } ] +[ { { 1 2 3 } { "a" "b" } } [ first2 x ] product-map ] unit-test [ { diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 73ba1e4e01..0c5bb88f32 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,4 +1,4 @@ -USING: accessors arrays kernel math sequences ; +USING: accessors arrays kernel locals math sequences ; IN: sequences.product TUPLE: product-sequence { sequences array read-only } { lengths array read-only } ; @@ -10,19 +10,53 @@ INSTANCE: product-sequence sequence M: product-sequence length lengths>> product ; +> ns ] [ nip sequences>> ] 2bi ; +:: (carry-n) ( ns lengths i -- ) + ns length i 1+ = [ + i ns nth i lengths nth = [ + 0 i ns set-nth + i 1+ ns [ 1+ ] change-nth + ns lengths i 1+ (carry-n) + ] when + ] unless ; + +: carry-ns ( ns lengths -- ) + 0 (carry-n) ; + +: product-iter ( ns lengths -- ) + [ 0 over [ 1+ ] change-nth ] dip carry-ns ; + +: start-product-iter ( sequence-product -- ns lengths ) + [ [ drop 0 ] map ] [ [ length ] map ] bi ; + +: end-product-iter? ( ns lengths -- ? ) + [ 1 tail* first ] bi@ = ; + +PRIVATE> + M: product-sequence nth - product@ [ nth ] { } 2map-as ; + product@ nths ; -M: product-sequence set-nth - immutable ; +:: product-each ( sequences quot -- ) + sequences start-product-iter :> lengths :> ns + [ ns lengths end-product-iter? ] + [ ns sequences nths quot call ns lengths product-iter ] until ; inline + +:: product-map ( sequences quot -- sequence ) + 0 :> i! + sequences [ length ] [ * ] map-reduce sequences + [| result | + sequences [ quot call i result set-nth i 1+ i! ] product-each + result + ] new-like ; inline -: product-map ( sequences quot -- sequence ) - [ ] dip map ; inline -: product-each ( sequences quot -- ) - [ ] dip each ; inline From f007c281e3b2c0645a095b1f9febb31668eea9e9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:08:15 -0500 Subject: [PATCH 73/82] docs for sequences.product --- extra/sequences/product/product-docs.factor | 60 +++++++++++++++++++++ 1 file changed, 60 insertions(+) create mode 100644 extra/sequences/product/product-docs.factor diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor new file mode 100644 index 0000000000..6033767f47 --- /dev/null +++ b/extra/sequences/product/product-docs.factor @@ -0,0 +1,60 @@ +USING: help.markup help.syntax multiline quotations sequences sequences.product ; +IN: sequences + +HELP: product-sequence +{ $class-description "A class of virtual sequences that present the cartesian product of their underlying set of sequences. Product sequences are constructed with the " { $link } " word." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +HELP: +{ $values { "sequences" sequence } { "product-sequence" product-sequence } } +{ $description "Constructs a " { $link product-sequence } " over " { $snippet "sequences" } "." } +{ $examples +{ $example <" USING: arrays prettyprint sequences.product ; +{ { 1 2 3 } { "a" "b" "c" } } >array . +"> <" { + { 1 "a" } + { 2 "a" } + { 3 "a" } + { 1 "b" } + { 2 "b" } + { 3 "b" } + { 1 "c" } + { 2 "c" } + { 3 "c" } +}"> } } ; + +{ product-sequence } related-words + +HELP: product-map +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- value )" } } { "sequence" sequence } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } " and collects the results from " { $snippet "quot" } " into an output sequence." } +{ $notes { $snippet "[ ... ] product-map" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] map" } "." } ; + +HELP: product-each +{ $values { "sequences" sequence } { "quot" { $quotation "( sequence -- )" } } } +{ $description "Calls " { $snippet "quot" } " for every element of the cartesian product of " { $snippet "sequences" } "." } +{ $notes { $snippet "[ ... ] product-each" } " is equivalent to, but more efficient than, " { $snippet " [ ... ] each" } "." } ; + +{ product-map product-each } related-words + +ARTICLE: "sequences.product" "Product sequences" +"The " { $vocab-link "sequences.product" } " vocabulary provides a virtual sequence and combinators for manipulating the cartesian product of a set of sequences." +{ $subsection product-sequence } +{ $subsection } +{ $subsection product-map } +{ $subsection product-each } ; + +ABOUT: "sequences.product" From a2056d932c3c02fd6ecc5673a3f75ee067648990 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 13:09:30 -0500 Subject: [PATCH 74/82] gold plating for sequences.product --- extra/sequences/product/authors.txt | 1 + extra/sequences/product/product-docs.factor | 1 + extra/sequences/product/product-tests.factor | 1 + extra/sequences/product/product.factor | 1 + extra/sequences/product/summary.txt | 1 + 5 files changed, 5 insertions(+) create mode 100644 extra/sequences/product/authors.txt create mode 100644 extra/sequences/product/summary.txt diff --git a/extra/sequences/product/authors.txt b/extra/sequences/product/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/sequences/product/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/sequences/product/product-docs.factor b/extra/sequences/product/product-docs.factor index 6033767f47..b7dcaa626e 100644 --- a/extra/sequences/product/product-docs.factor +++ b/extra/sequences/product/product-docs.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: help.markup help.syntax multiline quotations sequences sequences.product ; IN: sequences diff --git a/extra/sequences/product/product-tests.factor b/extra/sequences/product/product-tests.factor index 087d7a6175..5e0997dc2e 100644 --- a/extra/sequences/product/product-tests.factor +++ b/extra/sequences/product/product-tests.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: arrays kernel make sequences sequences.product tools.test ; IN: sequences.product.tests diff --git a/extra/sequences/product/product.factor b/extra/sequences/product/product.factor index 0c5bb88f32..665d43f0cd 100644 --- a/extra/sequences/product/product.factor +++ b/extra/sequences/product/product.factor @@ -1,3 +1,4 @@ +! (c)2009 Joe Groff bsd license USING: accessors arrays kernel locals math sequences ; IN: sequences.product diff --git a/extra/sequences/product/summary.txt b/extra/sequences/product/summary.txt new file mode 100644 index 0000000000..c234c84a94 --- /dev/null +++ b/extra/sequences/product/summary.txt @@ -0,0 +1 @@ +Cartesian products of sequences From 291ac48a1766e942a20099d023ba3e84deee5609 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 13:31:10 -0500 Subject: [PATCH 75/82] tuple-arrays: completely rewritten to use functors, 10x faster on benchmark --- basis/inverse/inverse.factor | 2 +- basis/tuple-arrays/authors.txt | 2 +- basis/tuple-arrays/summary.txt | 1 - basis/tuple-arrays/tags.txt | 1 - basis/tuple-arrays/tuple-arrays-docs.factor | 13 ---- basis/tuple-arrays/tuple-arrays-tests.factor | 16 ++-- basis/tuple-arrays/tuple-arrays.factor | 76 ++++++++++++++----- extra/benchmark/tuple-arrays/authors.txt | 1 + .../tuple-arrays/tuple-arrays.factor | 20 +++++ 9 files changed, 88 insertions(+), 44 deletions(-) delete mode 100644 basis/tuple-arrays/summary.txt delete mode 100644 basis/tuple-arrays/tags.txt delete mode 100644 basis/tuple-arrays/tuple-arrays-docs.factor create mode 100644 extra/benchmark/tuple-arrays/authors.txt create mode 100644 extra/benchmark/tuple-arrays/tuple-arrays.factor diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index a988063293..0b86b02e92 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -12,7 +12,7 @@ IN: inverse ERROR: fail ; M: fail summary drop "Matching failed" ; -: assure ( ? -- ) [ fail ] unless ; +: assure ( ? -- ) [ fail ] unless ; inline : =/fail ( obj1 obj2 -- ) = assure ; diff --git a/basis/tuple-arrays/authors.txt b/basis/tuple-arrays/authors.txt index f990dd0ed2..d4f5d6b3ae 100644 --- a/basis/tuple-arrays/authors.txt +++ b/basis/tuple-arrays/authors.txt @@ -1 +1 @@ -Daniel Ehrenberg +Slava Pestov \ No newline at end of file diff --git a/basis/tuple-arrays/summary.txt b/basis/tuple-arrays/summary.txt deleted file mode 100644 index ac05ae9bcc..0000000000 --- a/basis/tuple-arrays/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Packed homogeneous tuple arrays diff --git a/basis/tuple-arrays/tags.txt b/basis/tuple-arrays/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/basis/tuple-arrays/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/basis/tuple-arrays/tuple-arrays-docs.factor b/basis/tuple-arrays/tuple-arrays-docs.factor deleted file mode 100644 index 18f5547e7f..0000000000 --- a/basis/tuple-arrays/tuple-arrays-docs.factor +++ /dev/null @@ -1,13 +0,0 @@ -USING: help.syntax help.markup splitting kernel sequences ; -IN: tuple-arrays - -HELP: tuple-array -{ $description "The class of packed homogeneous tuple arrays. They are created with " { $link } ". All elements are of the same tuple class. Mutations done to an element are not copied back to the packed array unless it is explicitly written back. To convert a sequence to a tuple array, use the word " { $link >tuple-array } "." } ; - -HELP: -{ $values { "class" "a tuple class" } { "length" "a non-negative integer" } { "tuple-array" tuple-array } } -{ $description "Creates an instance of the " { $link } " class with the given length and containing the given tuple class." } ; - -HELP: >tuple-array -{ $values { "seq" sequence } { "tuple-array" tuple-array } } -{ $description "Converts a sequence into a homogeneous unboxed tuple array of the type indicated by the first element." } ; diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 7aa49b880f..4606ecdada 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -5,17 +5,21 @@ IN: tuple-arrays.tests SYMBOL: mat TUPLE: foo bar ; C: foo -[ 2 ] [ 2 foo dup mat set length ] unit-test +TUPLE-ARRAY: foo + +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 2 } ] [ T{ foo f 2 } 0 mat get [ set-nth ] keep first ] unit-test -[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >tuple-array dup mat set tuple-array? ] unit-test +[ t ] [ { T{ foo f 1 } T{ foo f 2 } } >foo-array dup mat set foo-array? ] unit-test [ T{ foo f 3 } t ] -[ mat get [ bar>> 2 + ] map [ first ] keep tuple-array? ] unit-test +[ mat get [ bar>> 2 + ] map [ first ] keep foo-array? ] unit-test -[ 2 ] [ 2 foo dup mat set length ] unit-test +[ 2 ] [ 2 dup mat set length ] unit-test [ T{ foo } ] [ mat get first ] unit-test [ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test TUPLE: baz { bing integer } bong ; -[ 0 ] [ 1 baz first bing>> ] unit-test -[ f ] [ 1 baz first bong>> ] unit-test +TUPLE-ARRAY: baz + +[ 0 ] [ 1 first bing>> ] unit-test +[ f ] [ 1 first bong>> ] unit-test diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index af62c0b0d7..466262f3e0 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,34 +1,68 @@ -! Copyright (C) 2007 Daniel Ehrenberg. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: splitting grouping classes.tuple classes math kernel -sequences arrays accessors ; +USING: accessors arrays combinators.smart fry functors grouping +kernel macros sequences sequences.private stack-checker +parser ; +FROM: inverse => undo ; IN: tuple-arrays -TUPLE: tuple-array { seq read-only } { class read-only } ; + ( length class -- tuple-array ) - [ - new tuple>array 1 tail - [ concat ] [ length ] bi - ] [ ] bi tuple-array boa ; +MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; -M: tuple-array nth - [ seq>> nth ] [ class>> ] bi prefix >tuple ; +: smart-tuple>array ( tuple class -- array ) + '[ [ _ boa ] undo ] output>array ; inline -M: tuple-array set-nth ( elt n seq -- ) - [ tuple>array 1 tail ] 2dip seq>> set-nth ; +: smart-array>tuple ( array class -- tuple ) + '[ _ boa ] input> ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline -: >tuple-array ( seq -- tuple-array ) +: tuple-prototype ( class -- array ) + [ new ] [ smart-tuple>array ] bi ; inline + +PRIVATE> + +FUNCTOR: define-tuple-array ( CLASS -- ) + +CLASS IS ${CLASS} + +CLASS-array DEFINES-CLASS ${CLASS}-array +CLASS-array? IS ${CLASS-array}? + + DEFINES <${CLASS}-array> +>CLASS-array DEFINES >${CLASS}-array + +WHERE + +TUPLE: CLASS-array { seq sliced-groups read-only } ; + +: ( length -- tuple-array ) + CLASS tuple-prototype concat + CLASS tuple-arity + CLASS-array boa ; + +M: CLASS-array nth-unsafe + seq>> nth-unsafe CLASS smart-array>tuple ; + +M: CLASS-array set-nth-unsafe + [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ; + +M: CLASS-array new-sequence + drop ; + +: >CLASS-array ( seq -- tuple-array ) dup empty? [ - 0 over first class clone-like + 0 clone-like ] unless ; -M: tuple-array like - drop dup tuple-array? [ >tuple-array ] unless ; +M: CLASS-array like + drop dup CLASS-array? [ >CLASS-array ] unless ; -M: tuple-array length seq>> length ; +M: CLASS-array length seq>> length ; -INSTANCE: tuple-array sequence +INSTANCE: CLASS-array sequence + +;FUNCTOR + +SYNTAX: TUPLE-ARRAY: scan-word define-tuple-array ; diff --git a/extra/benchmark/tuple-arrays/authors.txt b/extra/benchmark/tuple-arrays/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/benchmark/tuple-arrays/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/benchmark/tuple-arrays/tuple-arrays.factor b/extra/benchmark/tuple-arrays/tuple-arrays.factor new file mode 100644 index 0000000000..483311d4f4 --- /dev/null +++ b/extra/benchmark/tuple-arrays/tuple-arrays.factor @@ -0,0 +1,20 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions tuple-arrays accessors fry sequences +prettyprint ; +IN: benchmark.tuple-arrays + +TUPLE: point { x float } { y float } { z float } ; + +TUPLE-ARRAY: point + +: tuple-array-benchmark ( -- ) + 100 [ + drop 5000 [ + [ 1+ ] change-x + [ 1- ] change-y + [ 1+ 2 / ] change-z + ] map [ z>> ] sigma + ] sigma . ; + +MAIN: tuple-array-benchmark \ No newline at end of file From 06012cf2917e632f3b14c1a80c221b59e1f383b4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 26 Apr 2009 14:58:31 -0500 Subject: [PATCH 76/82] order-insensitive pair methods --- extra/pair-methods/authors.txt | 1 + extra/pair-methods/pair-methods-tests.factor | 43 +++++++++++++++ extra/pair-methods/pair-methods.factor | 57 ++++++++++++++++++++ extra/pair-methods/summary.txt | 1 + 4 files changed, 102 insertions(+) create mode 100644 extra/pair-methods/authors.txt create mode 100644 extra/pair-methods/pair-methods-tests.factor create mode 100644 extra/pair-methods/pair-methods.factor create mode 100644 extra/pair-methods/summary.txt diff --git a/extra/pair-methods/authors.txt b/extra/pair-methods/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/pair-methods/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/pair-methods/pair-methods-tests.factor b/extra/pair-methods/pair-methods-tests.factor new file mode 100644 index 0000000000..f88ca966aa --- /dev/null +++ b/extra/pair-methods/pair-methods-tests.factor @@ -0,0 +1,43 @@ +! (c)2009 Joe Groff bsd license +USING: accessors pair-methods classes kernel sequences tools.test ; +IN: pair-methods.tests + +TUPLE: thang ; + +TUPLE: foom < thang ; +TUPLE: barm < foom ; + +TUPLE: zim < thang ; +TUPLE: zang < zim ; + +: class-names ( a b prefix -- string ) + [ [ class name>> ] bi@ "-" glue ] dip prepend ; + +PAIR-GENERIC: blibble ( a b -- c ) + +PAIR-M: thang thang blibble + "vanilla " class-names ; + +PAIR-M: foom thang blibble + "chocolate " class-names ; + +PAIR-M: barm thang blibble + "strawberry " class-names ; + +PAIR-M: barm zim blibble + "coconut " class-names ; + +[ "vanilla zang-zim" ] [ zim new zang new blibble ] unit-test + +! args automatically swap to match most specific method +[ "chocolate foom-zim" ] [ foom new zim new blibble ] unit-test +[ "chocolate foom-zim" ] [ zim new foom new blibble ] unit-test + +[ "strawberry barm-barm" ] [ barm new barm new blibble ] unit-test +[ "strawberry barm-foom" ] [ barm new foom new blibble ] unit-test +[ "strawberry barm-foom" ] [ foom new barm new blibble ] unit-test + +[ "coconut barm-zang" ] [ zang new barm new blibble ] unit-test +[ "coconut barm-zim" ] [ barm new zim new blibble ] unit-test + +[ 1 2 blibble ] [ no-pair-method? ] must-fail-with diff --git a/extra/pair-methods/pair-methods.factor b/extra/pair-methods/pair-methods.factor new file mode 100644 index 0000000000..d44d5bce78 --- /dev/null +++ b/extra/pair-methods/pair-methods.factor @@ -0,0 +1,57 @@ +! (c)2009 Joe Groff bsd license +USING: arrays assocs classes classes.tuple.private combinators +effects.parser generic.parser kernel math math.order parser +quotations sequences sorting words ; +IN: pair-methods + +ERROR: no-pair-method a b generic ; + +: ?swap ( a b ? -- a/b b/a ) + [ swap ] when ; + +: method-sort-key ( pair -- key ) + first2 [ tuple-layout third ] bi@ + ; + +: pair-match-condition ( pair -- quot ) + first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence + [ 2dup ] [ bi* and ] surround ; + +: pair-method-cond ( pair quot -- array ) + [ pair-match-condition ] [ ] bi* 2array ; + +: sorted-pair-methods ( word -- alist ) + "pair-generic-methods" word-prop >alist + [ [ first method-sort-key ] bi@ >=< ] sort ; + +: pair-generic-definition ( word -- def ) + [ sorted-pair-methods [ first2 pair-method-cond ] map ] + [ [ no-pair-method ] curry suffix ] bi 1quotation + [ 2dup [ class ] bi@ <=> +gt+ eq? ?swap ] [ cond ] surround ; + +: make-pair-generic ( word -- ) + dup pair-generic-definition define ; + +: define-pair-generic ( word effect -- ) + [ swap set-stack-effect ] + [ drop H{ } clone "pair-generic-methods" set-word-prop ] + [ drop make-pair-generic ] 2tri ; + +: (PAIR-GENERIC:) ( -- ) + CREATE-GENERIC complete-effect define-pair-generic ; + +SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ; + +: define-pair-method ( a b pair-generic definition -- ) + [ 2array ] 2dip swap + [ "pair-generic-methods" word-prop [ swap ] dip set-at ] + [ make-pair-generic ] bi ; + +: ?prefix-swap ( quot ? -- quot' ) + [ \ swap prefix ] when ; + +: (PAIR-M:) ( -- ) + scan-word scan-word 2dup <=> +gt+ eq? [ + ?swap scan-word parse-definition + ] keep ?prefix-swap define-pair-method ; + +SYNTAX: PAIR-M: (PAIR-M:) ; diff --git a/extra/pair-methods/summary.txt b/extra/pair-methods/summary.txt new file mode 100644 index 0000000000..823bc712f6 --- /dev/null +++ b/extra/pair-methods/summary.txt @@ -0,0 +1 @@ +Order-insensitive double dispatch generics From dac5203e81b6f40ac3660e1e4fdecec4a29a8678 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 16:04:44 -0500 Subject: [PATCH 77/82] compiler.tree.builder: Fix scoping of a variable by hints vocab --- basis/compiler/tree/builder/builder.factor | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/basis/compiler/tree/builder/builder.factor b/basis/compiler/tree/builder/builder.factor index 7f760650e7..37cc1f05da 100644 --- a/basis/compiler/tree/builder/builder.factor +++ b/basis/compiler/tree/builder/builder.factor @@ -54,15 +54,16 @@ PRIVATE> #! This slows down compiler.tree.propagation.inlining since then every #! inlined usage of a method has an inline-dependency on the mixin, and #! not the more specific type at the call site. - specialize-method? off - [ - #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d - { - { [ dup not ] [ ] } - { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } - [ in-d #call out-d>> #copy suffix ] - } cond - ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ; + f specialize-method? [ + [ + #call in-d>> word/quot build-tree-with unclip-last in-d>> :> in-d + { + { [ dup not ] [ ] } + { [ dup ends-with-terminate? ] [ #call out-d>> [ f swap #push ] map append ] } + [ in-d #call out-d>> #copy suffix ] + } cond + ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover + ] with-variable ; : contains-breakpoints? ( word -- ? ) def>> [ word? ] filter [ "break?" word-prop ] any? ; From 087c962f75d432cdd533991f403364e4782f83d5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 16:05:09 -0500 Subject: [PATCH 78/82] VM: simplify GC a bit, add GC_DEBUG compile-time flag --- vm/code_block.c | 3 ++- vm/data_gc.c | 4 ++-- vm/data_gc.h | 20 ++++++++++++++++++-- vm/data_heap.h | 1 - 4 files changed, 22 insertions(+), 6 deletions(-) diff --git a/vm/code_block.c b/vm/code_block.c index 8dda8bc16e..1ce440c9ab 100644 --- a/vm/code_block.c +++ b/vm/code_block.c @@ -224,7 +224,8 @@ void mark_object_code_block(CELL scan) { case WORD_TYPE: word = (F_WORD *)scan; - mark_code_block(word->code); + if(word->code) + mark_code_block(word->code); if(word->profiling) mark_code_block(word->profiling); break; diff --git a/vm/data_gc.c b/vm/data_gc.c index 3ab2055d82..a1a86e7789 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -330,7 +330,7 @@ CELL copy_next_from_tenured(CELL scan) void copy_reachable_objects(CELL scan, CELL *end) { - if(HAVE_NURSERY_P && collecting_gen == NURSERY) + if(collecting_gen == NURSERY) { while(scan < *end) scan = copy_next_from_nursery(scan); @@ -405,7 +405,7 @@ void end_gc(CELL gc_elapsed) if(collecting_gen != NURSERY) reset_generations(NURSERY,collecting_gen - 1); } - else if(HAVE_NURSERY_P && collecting_gen == NURSERY) + else if(collecting_gen == NURSERY) { nursery.here = nursery.start; } diff --git a/vm/data_gc.h b/vm/data_gc.h index 52d8b603ad..afa45c5522 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -58,7 +58,7 @@ INLINE bool should_copy(CELL untagged) return true; else if(HAVE_AGING_P && collecting_gen == AGING) return !in_zone(&data_heap->generations[TENURED],untagged); - else if(HAVE_NURSERY_P && collecting_gen == NURSERY) + else if(collecting_gen == NURSERY) return in_zone(&nursery,untagged); else { @@ -78,15 +78,31 @@ allocation (which does not call GC because of possible roots in volatile registers) does not run out of memory */ #define ALLOT_BUFFER_ZONE 1024 +/* If this is defined, we GC every 100 allocations. This catches missing local roots */ +#ifdef GC_DEBUG +static int count; +#endif + /* * It is up to the caller to fill in the object's fields in a meaningful * fashion! */ INLINE void *allot_object(CELL type, CELL a) { + +#ifdef GC_DEBUG + + if(!gc_off) + { + if(count++ % 1000 == 0) + gc(); + + } +#endif + CELL *object; - if(HAVE_NURSERY_P && nursery.size - ALLOT_BUFFER_ZONE > a) + if(nursery.size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ if(nursery.here + ALLOT_BUFFER_ZONE + a > nursery.end) diff --git a/vm/data_heap.h b/vm/data_heap.h index a7f44e73f8..5836967295 100644 --- a/vm/data_heap.h +++ b/vm/data_heap.h @@ -37,7 +37,6 @@ F_DATA_HEAP *data_heap; /* the 0th generation is where new objects are allocated. */ #define NURSERY 0 -#define HAVE_NURSERY_P (data_heap->gen_count>1) /* where objects hang around */ #define AGING (data_heap->gen_count-2) #define HAVE_AGING_P (data_heap->gen_count>2) From 6b5b839e727212c05df51ceefcb2f60854bf9a7c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 16:05:23 -0500 Subject: [PATCH 79/82] Makefile: add SITE_CFLAGS even if DEBUG=1 --- Makefile | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index db99120a77..c19d83e58e 100644 --- a/Makefile +++ b/Makefile @@ -15,9 +15,11 @@ FFI_TEST_CFLAGS = -fPIC ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 endif +CFLAGS += $(SITE_CFLAGS) + ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ifdef CONFIG From 7094b78821bf4817af674284d2a40f070b46e894 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 21:22:06 -0500 Subject: [PATCH 80/82] Add firstn-unsafe, input> ] keep '[ _ firstn @ ] ; +MACRO: input> ] keep + '[ _ firstn-unsafe @ ] ; + MACRO: reduce-outputs ( quot operation -- newquot ) [ dup infer out>> 1 [-] ] dip n*quot compose ; diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index edee44acc6..139b7a528a 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -26,11 +26,14 @@ MACRO: narray ( n -- ) MACRO: nsum ( n -- ) 1- [ + ] n*quot ; +MACRO: firstn-unsafe ( n -- ) + [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ - [ [ '[ [ _ ] dip nth-unsafe ] ] map ] - [ 1- '[ [ _ ] dip bounds-check 2drop ] ] - bi prefix '[ _ cleave ] + [ 1- swap bounds-check 2drop ] + [ firstn-unsafe ] + bi-curry '[ _ _ bi ] ] if ; MACRO: npick ( n -- ) From 58cba832a0ab29580bb29a2a86d3557a02be81a9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 21:22:20 -0500 Subject: [PATCH 81/82] functors: add support for call-next-method --- basis/functors/functors.factor | 27 ++++++++++++++++++++------- 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 309154fb49..6afa020128 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -18,6 +18,8 @@ IN: functors : define-declared* ( word def effect -- ) pick set-word define-declared ; +TUPLE: fake-call-next-method ; + TUPLE: fake-quotation seq ; GENERIC: >fake-quotations ( quot -- fake ) @@ -29,17 +31,25 @@ M: array >fake-quotations [ >fake-quotations ] { } map-as ; M: object >fake-quotations ; -GENERIC: fake-quotations> ( fake -- quot ) +GENERIC: (fake-quotations>) ( fake -- ) -M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] [ ] map-as ; +: fake-quotations> ( fake -- quot ) + [ (fake-quotations>) ] [ ] make ; -M: array fake-quotations> [ fake-quotations> ] map ; +M: fake-quotation (fake-quotations>) + [ seq>> [ (fake-quotations>) ] each ] [ ] make , ; -M: object fake-quotations> ; +M: array (fake-quotations>) + [ [ (fake-quotations>) ] each ] { } make , ; + +M: fake-call-next-method (fake-quotations>) + drop method-body get literalize , \ (call-next-method) , ; + +M: object (fake-quotations>) , ; : parse-definition* ( accum -- accum ) - parse-definition >fake-quotations parsed \ fake-quotations> parsed ; + parse-definition >fake-quotations parsed + [ fake-quotations> first ] over push-all ; : parse-declared* ( accum -- accum ) complete-effect @@ -64,7 +74,7 @@ SYNTAX: `TUPLE: SYNTAX: `M: scan-param parsed scan-param parsed - \ create-method-in parsed + [ create-method-in dup method-body set ] over push-all parse-definition* \ define* parsed ; @@ -92,6 +102,8 @@ SYNTAX: `INSTANCE: SYNTAX: `inline [ word make-inline ] over push-all ; +SYNTAX: `call-next-method T{ fake-call-next-method } parsed ; + : (INTERPOLATE) ( accum quot -- accum ) [ scan interpolate-locals ] dip '[ _ with-string-writer @ ] parsed ; @@ -117,6 +129,7 @@ DEFER: ;FUNCTOR delimiter { "INSTANCE:" POSTPONE: `INSTANCE: } { "SYNTAX:" POSTPONE: `SYNTAX: } { "inline" POSTPONE: `inline } + { "call-next-method" POSTPONE: `call-next-method } } ; : push-functor-words ( -- ) From 84f672e74b3b6cd556e842df0455a444fa5602b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 26 Apr 2009 21:24:55 -0500 Subject: [PATCH 82/82] tuple-arrays: further performance improvements --- basis/tuple-arrays/tuple-arrays-tests.factor | 7 +++ basis/tuple-arrays/tuple-arrays.factor | 55 +++++++++++--------- 2 files changed, 37 insertions(+), 25 deletions(-) diff --git a/basis/tuple-arrays/tuple-arrays-tests.factor b/basis/tuple-arrays/tuple-arrays-tests.factor index 4606ecdada..2eeae20aa1 100644 --- a/basis/tuple-arrays/tuple-arrays-tests.factor +++ b/basis/tuple-arrays/tuple-arrays-tests.factor @@ -23,3 +23,10 @@ TUPLE-ARRAY: baz [ 0 ] [ 1 first bing>> ] unit-test [ f ] [ 1 first bong>> ] unit-test + +TUPLE: broken x ; +: broken ( -- ) ; + +TUPLE-ARRAY: broken + +[ 100 ] [ 100 length ] unit-test \ No newline at end of file diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 466262f3e0..35d771416c 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -1,26 +1,36 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators.smart fry functors grouping -kernel macros sequences sequences.private stack-checker -parser ; +USING: accessors arrays combinators.smart fry functors kernel +kernel.private macros sequences combinators sequences.private +stack-checker parser math classes.tuple.private ; FROM: inverse => undo ; IN: tuple-arrays ] ; + MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ; +: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline + : smart-tuple>array ( tuple class -- array ) '[ [ _ boa ] undo ] output>array ; inline -: smart-array>tuple ( array class -- tuple ) - '[ _ boa ] inputarray ] bi ; inline +: tuple-slice ( n seq -- slice ) + [ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline + +: read-tuple ( slice class -- tuple ) + '[ _ boa-unsafe ] input [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] + bi '[ _ dip @ ] ; + PRIVATE> FUNCTOR: define-tuple-array ( CLASS -- ) @@ -35,31 +45,26 @@ CLASS-array? IS ${CLASS-array}? WHERE -TUPLE: CLASS-array { seq sliced-groups read-only } ; +TUPLE: CLASS-array +{ seq array read-only } +{ n array-capacity read-only } +{ length array-capacity read-only } ; : ( length -- tuple-array ) - CLASS tuple-prototype concat - CLASS tuple-arity - CLASS-array boa ; + [ \ CLASS [ tuple-prototype concat ] [ tuple-arity ] bi ] keep + \ CLASS-array boa ; inline -M: CLASS-array nth-unsafe - seq>> nth-unsafe CLASS smart-array>tuple ; +M: CLASS-array length length>> ; -M: CLASS-array set-nth-unsafe - [ CLASS smart-tuple>array ] 2dip seq>> set-nth-unsafe ; +M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; -M: CLASS-array new-sequence - drop ; +M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; -: >CLASS-array ( seq -- tuple-array ) - dup empty? [ - 0 clone-like - ] unless ; +M: CLASS-array new-sequence drop ; -M: CLASS-array like - drop dup CLASS-array? [ >CLASS-array ] unless ; +: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; -M: CLASS-array length seq>> length ; +M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; INSTANCE: CLASS-array sequence