From f272d54e49add8fcbc07d01e1bf60f77f4511a44 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 18 Jan 2008 15:45:08 +1300 Subject: [PATCH 001/317] Allow dashes in non-terminal names --- extra/peg/ebnf/ebnf.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 5343bb513b..520bf82c32 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -99,7 +99,7 @@ M: ebnf (generate-parser) ( ast -- id ) DEFER: 'rhs' : 'non-terminal' ( -- parser ) - CHAR: a CHAR: z range repeat1 [ >string ] action ; + CHAR: a CHAR: z range "-" token [ first ] action 2array choice repeat1 [ >string ] action ; : 'terminal' ( -- parser ) "'" token hide [ CHAR: ' = not ] satisfy repeat1 "'" token hide 3array seq [ first >string ] action ; From 9a897f91fff46ea32bedc48d3cfb5dc486184f94 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 28 Jan 2008 19:09:49 -0600 Subject: [PATCH 002/317] Fixing compiler bug with redefining deferred words --- core/compiler/test/redefine.factor | 2 ++ core/generator/generator.factor | 1 - 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 266b331ffc..aa53068e36 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -238,3 +238,5 @@ DEFER: flushable-test-2 [ \ bx forget ] with-compilation-unit [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test + +[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] unit-test diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0e499cf90f..4d985ff164 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,7 +20,6 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From 374f8acae219eee04b376869644f64d58ca0a654 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 11:40:50 -0600 Subject: [PATCH 003/317] fix hardware-info for windows --- extra/hardware-info/backend/backend.factor | 1 - extra/hardware-info/windows/backend/backend.factor | 6 ++++++ extra/hardware-info/windows/nt/nt.factor | 2 +- extra/hardware-info/windows/windows.factor | 4 +--- 4 files changed, 8 insertions(+), 5 deletions(-) create mode 100644 extra/hardware-info/windows/backend/backend.factor diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index d79678de0c..17794c196d 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -11,4 +11,3 @@ HOOK: available-page-file os ( -- n ) HOOK: total-virtual-mem os ( -- n ) HOOK: available-virtual-mem os ( -- n ) HOOK: available-virtual-extended-mem os ( -- n ) - diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor new file mode 100644 index 0000000000..516603c441 --- /dev/null +++ b/extra/hardware-info/windows/backend/backend.factor @@ -0,0 +1,6 @@ +IN: hardware-info.windows.backend + +TUPLE: wince ; +TUPLE: winnt ; +UNION: windows wince winnt ; + diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index f412754cdf..8a58e5c168 100644 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,4 +1,4 @@ -USING: alien alien.c-types hardware-info hardware-info.windows +USING: alien alien.c-types hardware-info.windows.backend kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index a49e4f254a..caf859c35e 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,11 +1,9 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 +hardware-info.windows.backend words combinators vocabs.loader hardware-info.backend ; IN: hardware-info.windows -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; USE: system : system-info ( -- SYSTEM_INFO ) From 8cb274e9f91a32f9ffcda44c6b351bbb08a5e958 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 11:41:12 -0600 Subject: [PATCH 004/317] fix editors for windows --- extra/editors/gvim/windows/windows.factor | 2 +- extra/editors/notepadpp/notepadpp.factor | 4 ++-- extra/editors/scite/scite.factor | 13 +++++++------ extra/editors/ultraedit/ultraedit.factor | 2 +- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/extra/editors/gvim/windows/windows.factor b/extra/editors/gvim/windows/windows.factor index 5a3ea6b67a..5b51738eea 100644 --- a/extra/editors/gvim/windows/windows.factor +++ b/extra/editors/gvim/windows/windows.factor @@ -1,4 +1,4 @@ -USING: editors.gvim io.files io.windows kernel namespaces +USING: editors.gvim.backend io.files io.windows kernel namespaces sequences windows.shell32 ; IN: editors.gvim.windows diff --git a/extra/editors/notepadpp/notepadpp.factor b/extra/editors/notepadpp/notepadpp.factor index f9fa95f175..72ac6c72d7 100755 --- a/extra/editors/notepadpp/notepadpp.factor +++ b/extra/editors/notepadpp/notepadpp.factor @@ -1,5 +1,5 @@ USING: editors io.files io.launcher kernel math.parser -namespaces windows.shell32 ; +namespaces sequences windows.shell32 ; IN: editors.notepadpp : notepadpp-path @@ -11,6 +11,6 @@ IN: editors.notepadpp [ notepadpp-path , "-n" swap number>string append , , - ] "" make run-detached drop ; + ] { } make run-detached drop ; [ notepadpp ] edit-hook set-global diff --git a/extra/editors/scite/scite.factor b/extra/editors/scite/scite.factor index bc9a98a051..ac9a032abc 100755 --- a/extra/editors/scite/scite.factor +++ b/extra/editors/scite/scite.factor @@ -8,18 +8,19 @@ ! variable to point to your executable, ! if not on the path. ! -USING: io.launcher kernel namespaces math math.parser -editors ; +USING: io.files io.launcher kernel namespaces math +math.parser editors sequences windows.shell32 ; IN: editors.scite -SYMBOL: scite-path - -"scite" scite-path set-global +: scite-path ( -- path ) + \ scite-path get-global [ + program-files "wscite\\SciTE.exe" path+ + ] unless* ; : scite-command ( file line -- cmd ) swap [ - scite-path get , + scite-path , , "-goto:" swap number>string append , ] { } make ; diff --git a/extra/editors/ultraedit/ultraedit.factor b/extra/editors/ultraedit/ultraedit.factor index 7da4b807ce..f9d27174b3 100755 --- a/extra/editors/ultraedit/ultraedit.factor +++ b/extra/editors/ultraedit/ultraedit.factor @@ -10,7 +10,7 @@ IN: editors.ultraedit : ultraedit ( file line -- ) [ - ultraedit-path , [ % "/" % # "/1" % ] "" make , + ultraedit-path , [ swap % "/" % # "/1" % ] "" make , ] { } make run-detached drop ; From 5f3c77bb9bd5dfb5e0a477e27454f71d28438bc3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 11:41:50 -0600 Subject: [PATCH 005/317] fix typo --- extra/help/tutorial/tutorial.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index a4d5e36b06..b3308e83c2 100644 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -23,7 +23,7 @@ $nl $nl "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" { $code "IN: palindrome" } -"You are now ready to go onto the nex section." ; +"You are now ready to go on to the next section." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" From 44d058c676e768f179f89cfeb66661541202c301 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 12:13:08 -0600 Subject: [PATCH 006/317] fix windows launcher code --- extra/io/windows/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 7b793ef74d..8f1d1c6756 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -51,7 +51,7 @@ TUPLE: CreateProcess-args [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; : join-arguments ( args -- cmd-line ) - [ "\"" swap escape-argument "\"" 3append ] map " " join ; + " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ From 58668874adc3ad6fa5df32620b13bdecfbfef9b1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:12:04 -0600 Subject: [PATCH 007/317] Unit test for recompiling deferred words --- core/compiler/test/redefine.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index aa53068e36..c1561f38d4 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -239,4 +239,14 @@ DEFER: flushable-test-2 [ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test -[ "one" "two" ] [ "DEFER: redefine-test1 : redefine-test2 redefine-test1 \"two\" ; : redefine-test1 \"one\" ; redefine-test2" eval ] unit-test +DEFER: defer-redefine-test-2 + +[ ] [ "IN: temporary DEFER: defer-redefine-test-1" eval ] unit-test + +[ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test + +[ defer-redefine-test-2 ] unit-test-fails + +[ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test + +[ 1 ] [ defer-redefine-test-2 ] unit-test From edf1f2724728b9088b9a746814c7dc9f912e7cd0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:14 -0600 Subject: [PATCH 008/317] Changes to Unicode --- extra/const/const.factor | 8 ++++ extra/unicode/breaks/breaks.factor | 14 +++---- extra/unicode/data/data.factor | 49 +++++++++++------------- extra/unicode/normalize/normalize.factor | 6 +-- extra/unicode/syntax/syntax.factor | 4 +- 5 files changed, 42 insertions(+), 39 deletions(-) diff --git a/extra/const/const.factor b/extra/const/const.factor index 59d65edaae..8efef7e372 100644 --- a/extra/const/const.factor +++ b/extra/const/const.factor @@ -14,3 +14,11 @@ IN: const : ENUM: ";" parse-tokens [ create-in ] map define-enum ; parsing + +: define-value ( word -- ) + { f } clone [ first ] curry define ; + +: VALUE: CREATE define-value ; parsing + +: set-value ( value word -- ) + word-def first set-first ; diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index 9c9242edc3..70a9c781a2 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,7 +1,7 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces combinators.lib assocs.lib math.ranges unicode.normalize -unicode.syntax unicode.data compiler.units alien.syntax ; +unicode.syntax unicode.data compiler.units alien.syntax const ; IN: unicode.breaks C-ENUM: Any L V T Extend Control CR LF graphemes ; @@ -32,7 +32,7 @@ CATEGORY: grapheme-control Zl Zp Cc Cf ; : other-extend-lines ( -- lines ) "extra/unicode/PropList.txt" resource-path file-lines ; -DEFER: other-extend +VALUE: other-extend CATEGORY: (extend) Me Mn ; : extend? ( ch -- ? ) @@ -77,7 +77,7 @@ SYMBOL: table T T connect graphemes Extend connect-after ; -DEFER: grapheme-table +VALUE: grapheme-table : grapheme-break? ( class1 class2 -- ? ) grapheme-table nth nth not ; @@ -113,10 +113,10 @@ DEFER: grapheme-table [ grapheme-class dup rot grapheme-break? ] find-last-index nip -1 or 1+ ; -<< - other-extend-lines process-other-extend \ other-extend define-value +[ + other-extend-lines process-other-extend \ other-extend set-value init-grapheme-table table [ make-grapheme-table finish-table ] with-variable - \ grapheme-table define-value ->> + \ grapheme-table set-value +] with-compilation-unit diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index e112471c28..c579d1fdfd 100644 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,15 +1,12 @@ USING: assocs math kernel sequences io.files hashtables quotations splitting arrays math.parser combinators.lib hash2 -byte-arrays words namespaces words compiler.units ; +byte-arrays words namespaces words compiler.units const ; IN: unicode.data ! Convenience functions : 1+* ( n/f _ -- n+1 ) drop [ 1+ ] [ 0 ] if* ; -: define-value ( value word -- ) - swap 1quotation define ; - : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; @@ -107,16 +104,16 @@ C: code-point 4 head [ multihex ] map first4 swap first set ; -DEFER: simple-lower -DEFER: simple-upper -DEFER: simple-title -DEFER: canonical-map -DEFER: combine-map -DEFER: class-map -DEFER: compat-map -DEFER: category-map -DEFER: name-map -DEFER: special-casing +VALUE: simple-lower +VALUE: simple-upper +VALUE: simple-title +VALUE: canonical-map +VALUE: combine-map +VALUE: class-map +VALUE: compat-map +VALUE: category-map +VALUE: name-map +VALUE: special-casing : canonical-entry ( char -- seq ) canonical-map at ; : combine-chars ( a b -- char/f ) combine-map hash2 ; @@ -132,16 +129,14 @@ DEFER: special-casing [ length 5 = ] subset [ [ set-code-point ] each ] H{ } make-assoc ; -[ - load-data - dup process-names \ name-map define-value - 13 over process-data \ simple-lower define-value - 12 over process-data tuck \ simple-upper define-value - 14 over process-data swapd union \ simple-title define-value - dup process-combining \ class-map define-value - dup process-canonical \ canonical-map define-value - \ combine-map define-value - dup process-compat \ compat-map define-value - process-category \ category-map define-value - load-special-casing \ special-casing define-value -] with-compilation-unit +load-data +dup process-names \ name-map set-value +13 over process-data \ simple-lower set-value +12 over process-data tuck \ simple-upper set-value +14 over process-data swapd union \ simple-title set-value +dup process-combining \ class-map set-value +dup process-canonical \ canonical-map set-value + \ combine-map set-value +dup process-compat \ compat-map set-value +process-category \ category-map set-value +load-special-casing \ special-casing set-value diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index 86a922793f..b018d115f8 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -2,7 +2,7 @@ USING: sequences namespaces unicode.data kernel combinators.lib math arrays ; IN: unicode.normalize -! Utility word +! Utility word--probably unnecessary : make* ( seq quot exemplar -- newseq ) ! quot has access to original seq on stack ! this just makes the new-resizable the same length as seq @@ -89,7 +89,7 @@ IN: unicode.normalize swap [ [ dup hangul? [ hangul>jamo % drop ] [ dup rot call [ % ] [ , ] ?if ] if - ] with each ] "" make* + ] with each ] "" make dup reorder ] if ; inline @@ -167,7 +167,7 @@ SYMBOL: char 0 ind set SBUF" " clone after set pass-combining (compose) - ] "" make* ; + ] "" make ; : nfc ( string -- nfc ) nfd compose ; diff --git a/extra/unicode/syntax/syntax.factor b/extra/unicode/syntax/syntax.factor index 5119663872..6c75a77c76 100644 --- a/extra/unicode/syntax/syntax.factor +++ b/extra/unicode/syntax/syntax.factor @@ -1,5 +1,5 @@ USING: unicode.data kernel math sequences parser bit-arrays namespaces -sequences.private arrays quotations classes.predicate ; +sequences.private arrays quotations classes.predicate assocs ; IN: unicode.syntax ! Character classes (categories) @@ -48,5 +48,5 @@ IN: unicode.syntax categories swap seq-minus define-category ; parsing : UNICHAR: - ! This should be part of CHAR: + ! This should be part of CHAR:. Also, name-map at ==> name>char scan name>char [ parsed ] [ "Invalid character" throw ] if* ; parsing From a263784f94e19781ab8cd021a46a10777374bf8f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:33:33 -0600 Subject: [PATCH 009/317] Fixing opengl's use --- extra/opengl/opengl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 656c514cd1..ea3577c037 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu -combinators arrays sequences splitting words ; +combinators arrays sequences splitting words byte-arrays ; IN: opengl : coordinates [ first2 ] 2apply ; From f2dbf50c6c892d0296ced94cff0419c9fc6d97cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:53:54 -0600 Subject: [PATCH 010/317] Back out change --- core/generator/generator.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4d985ff164..0e499cf90f 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -20,6 +20,7 @@ SYMBOL: compiled { { [ dup compiled get key? ] [ drop ] } { [ dup primitive? ] [ drop ] } + { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; From e37ccf190eb2fe52c440a5b684d9832c17274872 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 29 Jan 2008 13:58:37 -0600 Subject: [PATCH 011/317] Add failing unit test --- core/classes/classes-tests.factor | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 5addd273c8..854e6add5a 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -207,3 +207,14 @@ DEFER: mixin-forget-test-g [ { } mixin-forget-test-g ] unit-test-fails [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test + +! Method flattening interfered with mixin update +MIXIN: flat-mx-1 +TUPLE: flat-mx-1-1 ; INSTANCE: flat-mx-1-1 flat-mx-1 +TUPLE: flat-mx-1-2 ; INSTANCE: flat-mx-1-2 flat-mx-1 +TUPLE: flat-mx-1-3 ; INSTANCE: flat-mx-1-3 flat-mx-1 +TUPLE: flat-mx-1-4 ; INSTANCE: flat-mx-1-4 flat-mx-1 +MIXIN: flat-mx-2 INSTANCE: flat-mx-2 flat-mx-1 +TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 + +[ t ] [ T{ flat-mx-2-1 } flat-mx-1? ] unit-test From e2f81c50c6a8a720c0afcc2221e65570b799d566 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 29 Jan 2008 20:01:57 -0600 Subject: [PATCH 012/317] make misc/factor.sh install gcc, make, and answer yes to apt-get --- misc/factor.sh | 370 +++++++++++++++++++++++++------------------------ 1 file changed, 186 insertions(+), 184 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index 8dca786846..39a15f93dc 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -13,289 +13,291 @@ WORD= NO_UI= ensure_program_installed() { - echo -n "Checking for $1..." - result=`type -p $1` - if ! [[ -n $result ]] ; then - echo "not found!" - echo "Install $1 and try again." - exit 1 - fi - echo "found!" + echo -n "Checking for $1..." + result=`type -p $1` + if ! [[ -n $result ]] ; then + echo "not found!" + echo "Install $1 and try again." + exit 1 + fi + echo "found!" } check_ret() { - RET=$? - if [[ $RET -ne 0 ]] ; then - echo $1 failed - exit 2 - fi + RET=$? + if [[ $RET -ne 0 ]] ; then + echo $1 failed + exit 2 + fi } check_gcc_version() { - echo -n "Checking gcc version..." - GCC_VERSION=`gcc --version` - check_ret gcc - if [[ $GCC_VERSION == *3.3.* ]] ; then - echo "bad!" - echo "You have a known buggy version of gcc (3.3)" - echo "Install gcc 3.4 or higher and try again." - exit 3 - fi - echo "ok." + echo -n "Checking gcc version..." + GCC_VERSION=`gcc --version` + check_ret gcc + if [[ $GCC_VERSION == *3.3.* ]] ; then + echo "bad!" + echo "You have a known buggy version of gcc (3.3)" + echo "Install gcc 3.4 or higher and try again." + exit 3 + fi + echo "ok." } check_installed_programs() { - ensure_program_installed chmod - ensure_program_installed uname - ensure_program_installed git - ensure_program_installed wget - ensure_program_installed gcc - ensure_program_installed make - check_gcc_version + ensure_program_installed sudo + ensure_program_installed chmod + ensure_program_installed uname + ensure_program_installed git + ensure_program_installed wget + ensure_program_installed gcc + ensure_program_installed make + check_gcc_version } check_library_exists() { - GCC_TEST=factor-library-test.c - GCC_OUT=factor-library-test.out - echo -n "Checking for library $1..." - echo "int main(){return 0;}" > $GCC_TEST - gcc $GCC_TEST -o $GCC_OUT -l $1 - if [[ $? -ne 0 ]] ; then - echo "not found!" - echo "Warning: library $1 not found." - echo "***Factor will compile NO_UI=1" - NO_UI=1 - fi - rm -f $GCC_TEST - check_ret rm - rm -f $GCC_OUT - check_ret rm - echo "found." + GCC_TEST=factor-library-test.c + GCC_OUT=factor-library-test.out + echo -n "Checking for library $1..." + echo "int main(){return 0;}" > $GCC_TEST + gcc $GCC_TEST -o $GCC_OUT -l $1 + if [[ $? -ne 0 ]] ; then + echo "not found!" + echo "Warning: library $1 not found." + echo "***Factor will compile NO_UI=1" + NO_UI=1 + fi + rm -f $GCC_TEST + check_ret rm + rm -f $GCC_OUT + check_ret rm + echo "found." } check_X11_libraries() { - check_library_exists freetype - check_library_exists GLU - check_library_exists GL - check_library_exists X11 + check_library_exists freetype + check_library_exists GLU + check_library_exists GL + check_library_exists X11 } check_libraries() { - case $OS in - linux) check_X11_libraries;; - esac + case $OS in + linux) check_X11_libraries;; + esac } check_factor_exists() { - if [[ -d "factor" ]] ; then - echo "A directory called 'factor' already exists." - echo "Rename or delete it and try again." - exit 4 - fi + if [[ -d "factor" ]] ; then + echo "A directory called 'factor' already exists." + echo "Rename or delete it and try again." + exit 4 + fi } find_os() { - echo "Finding OS..." - uname_s=`uname -s` - check_ret uname - case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; - *darwin*) OS=macosx;; - *Darwin*) OS=macosx;; - *linux*) OS=linux;; - *Linux*) OS=linux;; - esac + echo "Finding OS..." + uname_s=`uname -s` + check_ret uname + case $uname_s in + CYGWIN_NT-5.2-WOW64) OS=windows-nt;; + *CYGWIN_NT*) OS=windows-nt;; + *CYGWIN*) OS=windows-nt;; + *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; + *linux*) OS=linux;; + *Linux*) OS=linux;; + esac } find_architecture() { - echo "Finding ARCH..." - uname_m=`uname -m` - check_ret uname - case $uname_m in - i386) ARCH=x86;; - i686) ARCH=x86;; - *86) ARCH=x86;; - *86_64) ARCH=x86;; - "Power Macintosh") ARCH=ppc;; - esac + echo "Finding ARCH..." + uname_m=`uname -m` + check_ret uname + case $uname_m in + i386) ARCH=x86;; + i686) ARCH=x86;; + *86) ARCH=x86;; + *86_64) ARCH=x86;; + "Power Macintosh") ARCH=ppc;; + esac } write_test_program() { - echo "#include " > $C_WORD.c - echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c + echo "#include " > $C_WORD.c + echo "int main(){printf(\"%d\", 8*sizeof(void*)); return 0; }" >> $C_WORD.c } find_word_size() { - echo "Finding WORD..." - C_WORD=factor-word-size - write_test_program - gcc -o $C_WORD $C_WORD.c - WORD=$(./$C_WORD) - check_ret $C_WORD - rm -f $C_WORD* + echo "Finding WORD..." + C_WORD=factor-word-size + write_test_program + gcc -o $C_WORD $C_WORD.c + WORD=$(./$C_WORD) + check_ret $C_WORD + rm -f $C_WORD* } set_factor_binary() { - case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; - macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; - *) FACTOR_BINARY=factor;; - esac + case $OS in + windows-nt) FACTOR_BINARY=factor-nt;; + macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; + *) FACTOR_BINARY=factor;; + esac } echo_build_info() { - echo OS=$OS - echo ARCH=$ARCH - echo WORD=$WORD - echo FACTOR_BINARY=$FACTOR_BINARY - echo MAKE_TARGET=$MAKE_TARGET - echo BOOT_IMAGE=$BOOT_IMAGE - echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo OS=$OS + echo ARCH=$ARCH + echo WORD=$WORD + echo FACTOR_BINARY=$FACTOR_BINARY + echo MAKE_TARGET=$MAKE_TARGET + echo BOOT_IMAGE=$BOOT_IMAGE + echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET } set_build_info() { - if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then - echo "OS: $OS" - echo "ARCH: $ARCH" - echo "WORD: $WORD" - echo "OS, ARCH, or WORD is empty. Please report this" - exit 5 - fi + if ! [[ -n $OS && -n $ARCH && -n $WORD ]] ; then + echo "OS: $OS" + echo "ARCH: $ARCH" + echo "WORD: $WORD" + echo "OS, ARCH, or WORD is empty. Please report this" + exit 5 + fi - MAKE_TARGET=$OS-$ARCH-$WORD - MAKE_IMAGE_TARGET=$ARCH.$WORD - BOOT_IMAGE=boot.$ARCH.$WORD.image - if [[ $OS == macosx && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.macosx-ppc.image - fi - if [[ $OS == linux && $ARCH == ppc ]] ; then - MAKE_IMAGE_TARGET=$OS-$ARCH - MAKE_TARGET=$OS-$ARCH - BOOT_IMAGE=boot.linux-ppc.image - fi + MAKE_TARGET=$OS-$ARCH-$WORD + MAKE_IMAGE_TARGET=$ARCH.$WORD + BOOT_IMAGE=boot.$ARCH.$WORD.image + if [[ $OS == macosx && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.macosx-ppc.image + fi + if [[ $OS == linux && $ARCH == ppc ]] ; then + MAKE_IMAGE_TARGET=$OS-$ARCH + MAKE_TARGET=$OS-$ARCH + BOOT_IMAGE=boot.linux-ppc.image + fi } find_build_info() { - find_os - find_architecture - find_word_size - set_factor_binary - set_build_info - echo_build_info + find_os + find_architecture + find_word_size + set_factor_binary + set_build_info + echo_build_info } git_clone() { - echo "Downloading the git repository from factorcode.org..." - git clone git://factorcode.org/git/factor.git - check_ret git + echo "Downloading the git repository from factorcode.org..." + git clone git://factorcode.org/git/factor.git + check_ret git } git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git - check_ret git + echo "Updating the git repository from factorcode.org..." + git pull git://factorcode.org/git/factor.git + check_ret git } cd_factor() { - cd factor - check_ret cd + cd factor + check_ret cd } make_clean() { - make clean - check_ret make + make clean + check_ret make } make_factor() { - make NO_UI=$NO_UI $MAKE_TARGET -j5 - check_ret make + make NO_UI=$NO_UI $MAKE_TARGET -j5 + check_ret make } delete_boot_images() { - echo "Deleting old images..." - rm $BOOT_IMAGE > /dev/null 2>&1 - rm $BOOT_IMAGE.* > /dev/null 2>&1 + echo "Deleting old images..." + rm $BOOT_IMAGE > /dev/null 2>&1 + rm $BOOT_IMAGE.* > /dev/null 2>&1 } get_boot_image() { - wget http://factorcode.org/images/latest/$BOOT_IMAGE - check_ret wget + wget http://factorcode.org/images/latest/$BOOT_IMAGE + check_ret wget } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then - wget http://factorcode.org/dlls/freetype6.dll - check_ret wget - wget http://factorcode.org/dlls/zlib1.dll - check_ret wget - chmod 777 *.dll - check_ret chmod - fi + if [[ $OS == windows-nt ]] ; then + wget http://factorcode.org/dlls/freetype6.dll + check_ret wget + wget http://factorcode.org/dlls/zlib1.dll + check_ret wget + chmod 777 *.dll + check_ret chmod + fi } get_config_info() { - check_installed_programs - find_build_info - check_libraries + check_installed_programs + find_build_info + check_libraries } bootstrap() { - ./$FACTOR_BINARY -i=$BOOT_IMAGE + ./$FACTOR_BINARY -i=$BOOT_IMAGE } install() { - check_factor_exists - get_config_info - git_clone - cd_factor - make_factor - get_boot_image - maybe_download_dlls - bootstrap + check_factor_exists + get_config_info + git_clone + cd_factor + make_factor + get_boot_image + maybe_download_dlls + bootstrap } update() { - get_config_info - git_pull_factorcode - make_clean - make_factor + get_config_info + git_pull_factorcode + make_clean + make_factor } update_bootstrap() { - delete_boot_images - get_boot_image - bootstrap + delete_boot_images + get_boot_image + bootstrap } refresh_image() { - ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + check_ret factor } make_boot_image() { - ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" - check_ret factor + ./$FACTOR_BINARY -script -e="\"$MAKE_IMAGE_TARGET\" USE: bootstrap.image make-image save 0 USE: system exit" + check_ret factor } install_libraries() { - sudo apt-get install libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap + yes | sudo apt-get install sudo libc6-dev libfreetype6-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make + check_ret sudo } usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" + echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" } case "$1" in - install) install ;; - install-x11) install_libraries; install ;; - self-update) update; make_boot_image; bootstrap;; - quick-update) update; refresh_image ;; - update) update; update_bootstrap ;; - bootstrap) get_config_info; bootstrap ;; - *) usage ;; + install) install ;; + install-x11) install_libraries; install ;; + self-update) update; make_boot_image; bootstrap;; + quick-update) update; refresh_image ;; + update) update; update_bootstrap ;; + bootstrap) get_config_info; bootstrap ;; + *) usage ;; esac From 6394eb70bf82005eff70258aa91f133eea7ef10c Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 30 Jan 2008 00:50:18 -0500 Subject: [PATCH 013/317] Solution to Project Euler problem 37 --- extra/project-euler/037/037.factor | 52 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +- 2 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/037/037.factor diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor new file mode 100644 index 0000000000..f2d5d17c4d --- /dev/null +++ b/extra/project-euler/037/037.factor @@ -0,0 +1,52 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser math.primes sequences ; +IN: project-euler.037 + +! http://projecteuler.net/index.php?section=problems&id=37 + +! DESCRIPTION +! ----------- + +! The number 3797 has an interesting property. Being prime itself, it is +! possible to continuously remove digits from left to right, and remain prime +! at each stage: 3797, 797, 97, and 7. Similarly we can work from right to +! left: 3797, 379, 37, and 3. + +! Find the sum of the only eleven primes that are both truncatable from left to +! right and right to left. + +! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes. + + +! SOLUTION +! -------- + + [ + dup prime? [ r-trunc? ] [ drop f ] if + ] [ + drop t + ] if ; + +: reverse-digits ( n -- m ) + number>string reverse 10 string>integer ; + +: l-trunc? ( n -- ? ) + reverse-digits 10 /i reverse-digits dup 0 > [ + dup prime? [ l-trunc? ] [ drop f ] if + ] [ + drop t + ] if ; + +PRIVATE> + +: euler037 ( -- answer ) + 23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ; + +! [ euler037 ] 100 ave-time +! 768 ms run / 9 ms GC ave time - 100 trials + +MAIN: euler037 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index feef9dbfa8..fbb62961a9 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -11,8 +11,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.067 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.037 project-euler.067 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Wed, 30 Jan 2008 01:02:42 +0100 Subject: [PATCH 014/317] Add NetBSD support --- Makefile | 8 ++++++++ core/system/system-docs.factor | 1 + core/system/system.factor | 4 ++-- vm/Config.netbsd | 4 ++++ vm/Config.netbsd.x86.32 | 2 ++ vm/Config.netbsd.x86.64 | 2 ++ vm/os-netbsd.c | 6 ++++++ vm/os-netbsd.h | 9 +++++++++ vm/platform.h | 3 +++ 9 files changed, 37 insertions(+), 2 deletions(-) create mode 100644 vm/Config.netbsd create mode 100644 vm/Config.netbsd.x86.32 create mode 100644 vm/Config.netbsd.x86.64 create mode 100644 vm/os-netbsd.c create mode 100644 vm/os-netbsd.h diff --git a/Makefile b/Makefile index e02b6a672b..aad7fe90eb 100755 --- a/Makefile +++ b/Makefile @@ -56,6 +56,8 @@ default: @echo "linux-arm" @echo "openbsd-x86-32" @echo "openbsd-x86-64" + @echo "netbsd-x86-32" + @echo "netbsd-x86-64" @echo "macosx-x86-32" @echo "macosx-x86-64" @echo "macosx-ppc" @@ -83,6 +85,12 @@ freebsd-x86-32: freebsd-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.freebsd.x86.64 +netbsd-x86-32: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.32 + +netbsd-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.netbsd.x86.64 + macosx-freetype: ln -sf libfreetype.6.dylib \ Factor.app/Contents/Frameworks/libfreetype.dylib diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index d91a84ec99..d80cfa9ceb 100644 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -49,6 +49,7 @@ HELP: os "linux" "macosx" "openbsd" + "netbsd" "solaris" "windows" } diff --git a/core/system/system.factor b/core/system/system.factor index 845ba8265d..4983260a36 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -39,11 +39,11 @@ splitting assocs ; : unix? ( -- ? ) os { - "freebsd" "openbsd" "linux" "macosx" "solaris" + "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris" } member? ; : bsd? ( -- ? ) - os { "freebsd" "openbsd" "macosx" } member? ; + os { "freebsd" "openbsd" "netbsd" "macosx" } member? ; : linux? ( -- ? ) os "linux" = ; diff --git a/vm/Config.netbsd b/vm/Config.netbsd new file mode 100644 index 0000000000..9f334e18b4 --- /dev/null +++ b/vm/Config.netbsd @@ -0,0 +1,4 @@ +include vm/Config.unix +PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o +CFLAGS += -export-dynamic +LIBS = -L/usr/local/lib/ -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib -lm $(X11_UI_LIBS) diff --git a/vm/Config.netbsd.x86.32 b/vm/Config.netbsd.x86.32 new file mode 100644 index 0000000000..849bd65732 --- /dev/null +++ b/vm/Config.netbsd.x86.32 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.32 diff --git a/vm/Config.netbsd.x86.64 b/vm/Config.netbsd.x86.64 new file mode 100644 index 0000000000..24f86d0118 --- /dev/null +++ b/vm/Config.netbsd.x86.64 @@ -0,0 +1,2 @@ +include vm/Config.netbsd +include vm/Config.x86.64 diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c new file mode 100644 index 0000000000..b9238b7877 --- /dev/null +++ b/vm/os-netbsd.c @@ -0,0 +1,6 @@ +#include "master.h" + +const char *vm_executable_path(void) +{ + return NULL; +} diff --git a/vm/os-netbsd.h b/vm/os-netbsd.h new file mode 100644 index 0000000000..e282828577 --- /dev/null +++ b/vm/os-netbsd.h @@ -0,0 +1,9 @@ +#include + +#define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) +#define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) + +#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) +#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) + +extern char **environ; diff --git a/vm/platform.h b/vm/platform.h index 40324cc330..b0641176bc 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -58,6 +58,9 @@ #else #error "Unsupported OpenBSD flavor" #endif + #elif defined(__NetBSD__) + #define FACTOR_OS_STRING "netbsd" + #include "os-netbsd.h" #elif defined(linux) #define FACTOR_OS_STRING "linux" #include "os-linux.h" From 118583024e7c56eb48bbd6342984ec9c2a99d575 Mon Sep 17 00:00:00 2001 From: Daniel Neri Date: Wed, 30 Jan 2008 12:10:42 +0100 Subject: [PATCH 015/317] Tweak LIBS and LIBPATH for NetBSD --- vm/Config.netbsd | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/vm/Config.netbsd b/vm/Config.netbsd index 9f334e18b4..5fb5966b1e 100644 --- a/vm/Config.netbsd +++ b/vm/Config.netbsd @@ -1,4 +1,5 @@ include vm/Config.unix PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o CFLAGS += -export-dynamic -LIBS = -L/usr/local/lib/ -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib -lm $(X11_UI_LIBS) +LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib +LIBS = -lm $(X11_UI_LIBS) From adc6f4de738a45766c1692484f532aa3461a287e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 30 Jan 2008 12:49:20 -0600 Subject: [PATCH 016/317] fix load error --- extra/io/sockets/headers/headers.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/io/sockets/headers/headers.factor b/extra/io/sockets/headers/headers.factor index c697b60973..2547fee5ae 100755 --- a/extra/io/sockets/headers/headers.factor +++ b/extra/io/sockets/headers/headers.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax byte-arrays io -io.sockets.impl kernel structs math prettyprint ; +io.sockets.impl kernel structs math math.parser +prettyprint sequences ; IN: io.sockets.headers C-STRUCT: etherneth From 3b793b84740c374e85e2072ebaf05ee3dc7928e6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 14:23:21 -0600 Subject: [PATCH 017/317] (hashtable) is gone now --- core/compiler/test/intrinsics.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 954e45cb66..075961047f 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -334,10 +334,6 @@ cell 8 = [ [ \ + ] [ \ + [ ] compile-call ] unit-test -[ H{ } ] [ - 100 [ (hashtable) ] compile-call [ reset-hash ] keep -] unit-test - [ B{ 0 0 0 0 0 } ] [ [ 5 ] compile-call ] unit-test From d8d87fe83481c34bc5b017faa68c0aba4840c7d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 30 Jan 2008 14:23:48 -0600 Subject: [PATCH 018/317] Fix littledan bug #1 --- core/generator/generator.factor | 2 +- core/inference/backend/backend.factor | 6 +++++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 0e499cf90f..de80872b73 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -19,8 +19,8 @@ SYMBOL: compiled : queue-compile ( word -- ) { { [ dup compiled get key? ] [ drop ] } + { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ dup deferred? ] [ drop ] } { [ t ] [ dup compile-queue get set-at ] } } cond ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index cf2d021430..121c555d29 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -402,10 +402,14 @@ TUPLE: recursive-declare-error word ; dup node-param #return node, dataflow-graph get 1array over set-node-children ; +: inlined-block? "inlined-block" word-prop ; + +: gensym dup t "inlined-block" set-word-prop ; + : inline-block ( word -- node-block data ) [ copy-inference nest-node - dup word-def swap gensym + dup word-def swap [ infer-quot-recursive ] 2keep #label unnest-node ] H{ } make-assoc ; From 99172b6f79132e840719adae02489162228f02c7 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Jan 2008 15:03:02 -0600 Subject: [PATCH 019/317] Changes in XML prettyprinter --- extra/xml/entities/entities.factor | 26 +++++++++++++++++- extra/xml/writer/writer.factor | 42 +++++++----------------------- 2 files changed, 35 insertions(+), 33 deletions(-) diff --git a/extra/xml/entities/entities.factor b/extra/xml/entities/entities.factor index a52f5be3dc..b90613ec79 100644 --- a/extra/xml/entities/entities.factor +++ b/extra/xml/entities/entities.factor @@ -1,8 +1,32 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel ; +USING: namespaces kernel assocs sequences ; IN: xml.entities +: entities-out + H{ + { CHAR: < "<" } + { CHAR: > ">" } + { CHAR: & "&" } + } ; + +: quoted-entities-out + H{ + { CHAR: & "&" } + { CHAR: ' "'" } + { CHAR: " """ } + } ; + +: escape-string-by ( str table -- escaped ) + #! Convert <, >, &, ' and " to HTML entities. + [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; + +: escape-string ( str -- newstr ) + entities-out escape-string-by ; + +: escape-quoted-string ( str -- newstr ) + quoted-entities-out escape-string-by ; + : entities H{ { "lt" CHAR: < } diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 7bd1cc3046..f943f24ccd 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs ; +io io.streams.string xml.data assocs wrap xml.entities ; IN: xml.writer SYMBOL: xml-pprint? @@ -13,10 +13,11 @@ SYMBOL: indenter : sensitive? ( tag -- ? ) sensitive-tags get swap [ names-match? ] curry contains? ; +: indent-string ( -- string ) + indentation get indenter get concat ; + : ?indent ( -- ) - xml-pprint? get [ - nl indentation get indenter get [ write ] each - ] when ; + xml-pprint? get [ nl indent-string write ] when ; : indent ( -- ) xml-pprint? get [ 1 indentation +@ ] when ; @@ -35,30 +36,6 @@ SYMBOL: indenter [ dup empty? swap string? and not ] subset ] when ; -: entities-out - H{ - { CHAR: < "<" } - { CHAR: > ">" } - { CHAR: & "&" } - } ; - -: quoted-entities-out - H{ - { CHAR: & "&" } - { CHAR: ' "'" } - { CHAR: " """ } - } ; - -: escape-string-by ( str table -- escaped ) - #! Convert <, >, &, ' and " to HTML entities. - [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ; - -: escape-string ( str -- newstr ) - entities-out escape-string-by ; - -: escape-quoted-string ( str -- newstr ) - quoted-entities-out escape-string-by ; - : print-name ( name -- ) dup name-space f like [ write CHAR: : write1 ] when* @@ -76,10 +53,11 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string write ; + escape-string xml-pprint? over empty? not and + [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) - CHAR: < write1 + ?indent CHAR: < write1 dup print-name tag-attrs print-attrs ; M: contained-tag write-item @@ -87,7 +65,7 @@ M: contained-tag write-item : write-children ( tag -- ) indent tag-children ?filter-children - [ ?indent write-item ] each unindent ; + [ write-item ] each unindent ; : write-end-tag ( tag -- ) ?indent " write1 ; @@ -112,7 +90,7 @@ M: instruction write-item "\n" write ; + "\"?>" write ; : write-chunk ( seq -- ) [ write-item ] each ; From 9d5b944ec1dbbd035ef6ce34060cfa5938a739ff Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 30 Jan 2008 23:16:20 -0600 Subject: [PATCH 020/317] io.launcher: update docs --- extra/io/launcher/launcher-docs.factor | 15 ++++++++++----- extra/io/launcher/launcher.factor | 10 +++++----- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 28063bae0d..072cfcf959 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -93,7 +93,7 @@ HELP: run-process* { $notes "User code should call " { $link run-process } " instead." } ; HELP: >descriptor -{ $values { "obj" object } { "desc" "a launch descriptor" } } +{ $values { "desc" "a launch descriptor" } { "desc" "a launch descriptor" } } { $description "Creates a launch descriptor from an object, which must be one of the following:" { $list { "a string -- this is wrapped in a launch descriptor with a single " { $link +command+ } " key" } @@ -103,12 +103,12 @@ HELP: >descriptor } ; HELP: run-process -{ $values { "obj" object } { "process" process } } +{ $values { "desc" "a launch descriptor" } { "process" process } } { $description "Launches a process. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } { $notes "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; HELP: run-detached -{ $values { "obj" object } { "process" process } } +{ $values { "desc" "a launch descriptor" } { "process" process } } { $contract "Launches a process without waiting for it to complete. The object can either be a string, a sequence of strings or a launch descriptor. See " { $link >descriptor } " for details." } { $notes "This word is functionally identical to passing a launch descriptor to " { $link run-process } " having the " { $link +detached+ } " key set." @@ -127,12 +127,17 @@ HELP: process-stream { $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ; HELP: -{ $values { "obj" object } { "stream" "a bidirectional stream" } } +{ $values + { "desc" "a launch descriptor" } + { "stream" "a bidirectional stream" } } { $description "Launches a process and redirects its input and output via a pair of pipes which may be read and written as a stream." } { $notes "Closing the stream will block until the process exits." } ; HELP: with-process-stream -{ $values { "obj" object } { "quot" quotation } { "process" process } } +{ $values + { "desc" "a launch descriptor" } + { "quot" quotation } + { "process" process } } { $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; HELP: wait-for-process diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7cf9d51ed0..9fb24fb51a 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -63,7 +63,7 @@ SYMBOL: append-environment { replace-environment [ ] } } case ; -GENERIC: >descriptor ( obj -- desc ) +GENERIC: >descriptor ( desc -- desc ) M: string >descriptor +command+ associate ; M: sequence >descriptor +arguments+ associate ; @@ -76,24 +76,24 @@ HOOK: run-process* io-backend ( desc -- handle ) dup [ processes get at push stop ] curry callcc0 ] when process-status ; -: run-process ( obj -- process ) +: run-process ( desc -- process ) >descriptor dup run-process* +detached+ rot at [ dup wait-for-process drop ] unless ; -: run-detached ( obj -- process ) +: run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; -: ( obj -- stream ) +: ( desc -- stream ) >descriptor process-stream* { set-delegate set-process-stream-process } process-stream construct ; -: with-process-stream ( obj quot -- process ) +: with-process-stream ( desc quot -- process ) swap [ swap with-stream ] keep process-stream-process ; inline From ce260a07aba18370485f2176823015d2e53dc107 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 00:25:06 -0600 Subject: [PATCH 021/317] Add builder vocab --- extra/builder/builder.factor | 113 +++++++++++++++++++++++++++++++++++ 1 file changed, 113 insertions(+) create mode 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor new file mode 100644 index 0000000000..a2b5dffb4d --- /dev/null +++ b/extra/builder/builder.factor @@ -0,0 +1,113 @@ + +USING: kernel io io.files io.launcher + system namespaces sequences splitting math.parser + unix prettyprint tools.time calendar bake vars ; + +IN: builder + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: datestamp ( -- string ) + now `{ ,[ dup timestamp-year ] + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } + [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builder-recipients + +: quote ( str -- str ) "'" swap "'" 3append ; + +: email-file ( subject file -- ) + `{ + "cat" , + "| mutt -s" ,[ quote ] + "-x" %[ builder-recipients get ] + } + " " join system drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ; + +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build ( -- ) + +datestamp >stamp + +"/builds/factor" cd +"git pull git://factorcode.org/git/factor.git" system +0 = +[ ] +[ + "builder: git pull" "/dev/null" email-file + "builder: git pull" throw +] +if + +"/builds/" stamp> append make-directory +"/builds/" stamp> append cd +"git clone /builds/factor" system drop + +"factor" cd + +{ "/usr/bin/git" "show" } +[ readln ] with-stream +" " split second +"../git-id" [ print ] with-stream + +"make clean" system drop + +"make " target " > ../compile-log" 3append system +0 = +[ ] +[ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw +] if + +"wget http://factorcode.org/images/latest/" boot-image append system +0 = +[ ] +[ + "builder: image download" "/dev/null" email-file + "builder: image download" throw +] if + +[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ] +benchmark nip +"../boot-time" [ . ] with-stream +0 = +[ ] +[ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw +] if + +[ + "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" + system +] benchmark nip +"../load-everything-time" [ . ] with-stream +0 = +[ ] +[ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw +] if + +; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +MAIN: build \ No newline at end of file From cea24feaa9f01eb86bc198af671d924cfd89a2c3 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 00:47:11 -0600 Subject: [PATCH 022/317] Fixing failing XML unit tests --- extra/xml/test/templating.factor | 7 +++---- extra/xml/test/test.factor | 4 ++-- extra/xml/writer/writer.factor | 6 ++++-- 3 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/xml/test/templating.factor b/extra/xml/test/templating.factor index 0ee4ae51b0..2dd69ca99b 100644 --- a/extra/xml/test/templating.factor +++ b/extra/xml/test/templating.factor @@ -1,4 +1,3 @@ -IN: templating USING: kernel xml sequences assocs tools.test io arrays namespaces xml.data xml.utilities xml.writer generic sequences.deep ; @@ -9,10 +8,10 @@ SYMBOL: ref-table GENERIC: (r-ref) ( xml -- ) M: tag (r-ref) - sub-tag over at [ + sub-tag over at* [ ref-table get at swap set-tag-children - ] [ drop ] if* ; + ] [ 2drop ] if ; M: object (r-ref) drop ; : template ( xml -- ) @@ -40,4 +39,4 @@ M: object (r-ref) drop ; sample-doc string>xml dup template xml>string ] with-scope ; -[ "\nfoo
blah

" ] [ test-refs ] unit-test +[ "foo

" ] [ test-refs ] unit-test diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index 80a508787e..ec59d3564e 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -26,7 +26,7 @@ SYMBOL: xml-file ] unit-test [ V{ "fa&g" } ] [ xml-file get "x" get-id tag-children ] unit-test [ "that" ] [ xml-file get "this" swap at ] unit-test -[ "\n" ] +[ "" ] [ "" string>xml xml>string ] unit-test [ "abcd" ] [ "

abcd
" string>xml @@ -44,7 +44,7 @@ SYMBOL: xml-file at swap "z" >r tuck r> swap set-at T{ name f "blah" "z" f } swap at ] unit-test [ "foo" ] [ "" string>xml children>string ] unit-test -[ "\nbar baz" ] +[ "bar baz" ] [ "bar" string>xml [ " baz" append ] map xml>string ] unit-test [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index f943f24ccd..95f38f3da9 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -14,7 +14,9 @@ SYMBOL: indenter sensitive-tags get swap [ names-match? ] curry contains? ; : indent-string ( -- string ) - indentation get indenter get concat ; + xml-pprint? get + [ indentation get indenter get concat ] + [ "" ] if ; : ?indent ( -- ) xml-pprint? get [ nl indent-string write ] when ; @@ -53,7 +55,7 @@ SYMBOL: indenter GENERIC: write-item ( object -- ) M: string write-item - escape-string xml-pprint? over empty? not and + escape-string dup empty? not xml-pprint? get and [ nl 80 indent-string indented-break ] when write ; : write-tag ( tag -- ) From 0c078d04555ea1dc1a928dcc0f3b39c72bb0f4a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:48:41 -0600 Subject: [PATCH 023/317] Friendlier bootstrap errors --- core/bootstrap/stage2.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 0163422f47..8fc3435ffa 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -87,5 +87,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - error. :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute ] recover From 60290fbf526b31a5667622ec5480c35b1b0f4ec8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:49:18 -0600 Subject: [PATCH 024/317] Fix littledan bug #2 --- core/classes/classes.factor | 14 +++++++++++--- core/classes/union/union.factor | 2 ++ core/generic/generic.factor | 4 ++-- 3 files changed, 15 insertions(+), 5 deletions(-) mode change 100644 => 100755 core/classes/union/union.factor diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 65dc5f5ff7..a6a1db7045 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -255,7 +255,14 @@ PRIVATE> >r dup word-props r> union over set-word-props t "class" set-word-prop ; -GENERIC: update-methods ( class -- ) +GENERIC: update-predicate ( class -- ) + +M: class update-predicate drop ; + +: update-predicates ( assoc -- ) + [ drop update-predicate ] assoc-each ; + +GENERIC: update-methods ( assoc -- ) : define-class ( word members superclass metaclass -- ) #! If it was already a class, update methods after. @@ -264,8 +271,9 @@ GENERIC: update-methods ( class -- ) over class-usages [ uncache-classes dupd (define-class) - ] keep cache-classes - r> [ update-methods ] [ drop ] if ; + ] keep cache-classes r> + [ class-usages dup update-predicates update-methods ] + [ drop ] if ; GENERIC: class ( object -- class ) inline diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor old mode 100644 new mode 100755 index e95c08b507..0adbdc080d --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -20,6 +20,8 @@ PREDICATE: class union-class over members union-predicate-quot define-predicate ; +M: union-class update-predicate define-union-predicate ; + : define-union-class ( class members -- ) dupd f union-class define-class define-union-predicate ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 5ee6b9c87c..bde5fd31af 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -107,5 +107,5 @@ M: class forget* ( class -- ) dup uncache-class forget-word ; -M: class update-methods ( class -- ) - class-usages implementors* [ make-generic ] each ; +M: assoc update-methods ( assoc -- ) + implementors* [ make-generic ] each ; From 926e09a46a6886bd2376d9fa3cdfa1cc18ebd685 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:52:06 -0600 Subject: [PATCH 025/317] New dispose word and with-dispose combinator, docs for io.monitor, working on O(1) stream timeouts --- core/continuations/continuations-docs.factor | 9 +++ core/continuations/continuations.factor | 5 ++ core/dlists/dlists-docs.factor | 34 ++++++----- core/dlists/dlists-tests.factor | 16 ++--- core/dlists/dlists.factor | 32 +++++++--- core/inference/inference-tests.factor | 3 +- core/io/files/files-tests.factor | 4 +- core/io/io-docs.factor | 12 +--- core/io/io.factor | 7 +-- core/io/streams/c/c.factor | 8 +-- core/io/streams/duplex/duplex-docs.factor | 4 +- core/io/streams/duplex/duplex-tests.factor | 10 ++-- core/io/streams/duplex/duplex.factor | 6 +- core/io/streams/nested/nested.factor | 8 +-- core/io/streams/string/string.factor | 6 +- extra/cabal/cabal.factor | 2 +- extra/cryptlib/streams/streams.factor | 8 +-- extra/delegate/protocols/protocols.factor | 2 +- extra/help/handbook/handbook.factor | 13 +++-- extra/help/tutorial/tutorial.factor | 6 +- extra/html/html.factor | 4 +- extra/http/client/client.factor | 4 +- extra/io/mmap/mmap-docs.factor | 14 ++--- extra/io/mmap/mmap.factor | 10 ++-- extra/io/monitor/monitor-docs.factor | 61 ++++++++++++++++++++ extra/io/monitor/monitor.factor | 4 +- extra/io/nonblocking/nonblocking-docs.factor | 4 +- extra/io/nonblocking/nonblocking.factor | 55 ++++++++++++++---- extra/io/server/server.factor | 8 +-- extra/io/sockets/sockets-docs.factor | 10 ++-- extra/io/streams/null/null.factor | 2 +- extra/io/unix/mmap/mmap.factor | 2 +- extra/io/unix/sockets/sockets.factor | 3 +- extra/io/unix/unix-tests.factor | 6 +- extra/io/windows/mmap/mmap.factor | 2 +- extra/io/windows/nt/backend/backend.factor | 20 ++----- extra/io/windows/nt/monitor/monitor.factor | 2 - extra/io/windows/windows.factor | 7 ++- extra/irc/irc.factor | 2 +- extra/tar/tar.factor | 4 +- extra/tools/deploy/backend/backend.factor | 9 +-- extra/ui/gadgets/panes/panes.factor | 12 ++-- 42 files changed, 274 insertions(+), 166 deletions(-) mode change 100644 => 100755 core/continuations/continuations-docs.factor mode change 100644 => 100755 core/dlists/dlists-docs.factor mode change 100644 => 100755 core/io/files/files-tests.factor mode change 100644 => 100755 core/io/streams/duplex/duplex-docs.factor mode change 100644 => 100755 core/io/streams/duplex/duplex-tests.factor mode change 100644 => 100755 core/io/streams/duplex/duplex.factor mode change 100644 => 100755 core/io/streams/nested/nested.factor mode change 100644 => 100755 core/io/streams/string/string.factor mode change 100644 => 100755 extra/cabal/cabal.factor mode change 100644 => 100755 extra/cryptlib/streams/streams.factor mode change 100644 => 100755 extra/delegate/protocols/protocols.factor mode change 100644 => 100755 extra/help/tutorial/tutorial.factor mode change 100644 => 100755 extra/http/client/client.factor mode change 100644 => 100755 extra/io/mmap/mmap-docs.factor create mode 100755 extra/io/monitor/monitor-docs.factor mode change 100644 => 100755 extra/io/nonblocking/nonblocking-docs.factor mode change 100644 => 100755 extra/io/sockets/sockets-docs.factor mode change 100644 => 100755 extra/io/streams/null/null.factor mode change 100644 => 100755 extra/io/unix/mmap/mmap.factor mode change 100644 => 100755 extra/io/unix/sockets/sockets.factor mode change 100644 => 100755 extra/io/unix/unix-tests.factor mode change 100644 => 100755 extra/irc/irc.factor mode change 100644 => 100755 extra/tar/tar.factor diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor old mode 100644 new mode 100755 index 2918f3340b..51e461c715 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -68,6 +68,15 @@ $nl ABOUT: "continuations" +HELP: dispose +{ $values { "object" "a disposable object" } } +{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; + +HELP: with-disposal +{ $values { "object" "a disposable object" } { "quot" "a quotation with stack effect " { $snippet "( object -- )" } } } +{ $description "Calls the quotation, disposing the object with " { $link dispose } " after the quotation returns or if it throws an error." } ; + HELP: catchstack* { $values { "catchstack" "a vector of continuations" } } { $description "Outputs the current catchstack." } ; diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 278264c17d..6e4ce16bea 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -135,6 +135,11 @@ PRIVATE> [ [ , f ] compose [ , drop t ] recover ] curry all? ] { } make peek swap [ rethrow ] when ; inline +GENERIC: dispose ( object -- ) + +: with-disposal ( object quot -- ) + over [ dispose ] curry [ ] cleanup ; inline + TUPLE: condition restarts continuation ; : ( error restarts cc -- condition ) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor old mode 100644 new mode 100755 index 5a808a9a5d..2aeaadad3e --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations ; IN: dlists ARTICLE: "dlists" "Doubly-linked lists" @@ -13,23 +13,31 @@ $nl { $subsection dlist? } "Constructing a dlist:" { $subsection } -"Double-ended queue protocol:" -{ $subsection dlist-empty? } +"Working with the front of the list:" { $subsection push-front } +{ $subsection push-front* } +{ $subsection peek-front } { $subsection pop-front } { $subsection pop-front* } +"Working with the back of the list:" { $subsection push-back } +{ $subsection push-back* } +{ $subsection peek-back } { $subsection pop-back } { $subsection pop-back* } "Finding out the length:" +{ $subsection dlist-empty? } { $subsection dlist-length } "Iterating over elements:" { $subsection dlist-each } { $subsection dlist-find } { $subsection dlist-contains? } -"Deleting a node matching a predicate:" -{ $subsection delete-node* } +"Deleting a node:" { $subsection delete-node } +{ $subsection dlist-delete } +"Deleting a node matching a predicate:" +{ $subsection delete-node-if* } +{ $subsection delete-node-if } "Consuming all nodes:" { $subsection dlist-slurp } ; @@ -77,7 +85,7 @@ HELP: pop-back* { $see-also push-front push-back pop-front pop-front* pop-back } ; HELP: dlist-find -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } { $notes "Returns a boolean to allow dlists to store " { $link f } "." $nl @@ -85,20 +93,20 @@ HELP: dlist-find } ; HELP: dlist-contains? -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "?" "a boolean" } } { $description "Just like " { $link dlist-find } " except it doesn't return the object." } { $notes "This operation is O(n)." } ; -HELP: delete-node* -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +HELP: delete-node-if* +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } { $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } { $notes "This operation is O(n)." } ; -HELP: delete-node -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } -{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } +HELP: delete-node-if +{ $values { "quot" quotation } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $description "Like " { $link delete-node-if* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } { $notes "This operation is O(n)." } ; HELP: dlist-each -{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } } +{ $values { "quot" quotation } { "dlist" { $link dlist } } } { $description "Iterate a " { $link dlist } ", calling quot on each element." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor index ebae68472b..203c975bb2 100755 --- a/core/dlists/dlists-tests.factor +++ b/core/dlists/dlists-tests.factor @@ -49,14 +49,14 @@ IN: temporary [ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test [ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test -[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test -[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test -[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node-if ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node-if drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node-if drop dlist-length ] unit-test [ 0 ] [ dlist-length ] unit-test [ 1 ] [ 1 over push-front dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 84d68b28aa..ddec312182 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -63,12 +63,22 @@ C: dlist-node >r dlist-front r> (dlist-each-node) ; inline PRIVATE> -: push-front ( obj dlist -- ) - [ dlist-front f swap dup set-next-prev ] keep +: push-front* ( obj dlist -- dlist-node ) + [ dlist-front f swap dup dup set-next-prev ] keep [ set-dlist-front ] keep [ set-back-to-front ] keep inc-length ; +: push-front ( obj dlist -- ) + push-front* drop ; + +: push-back* ( obj dlist -- dlist-node ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] 2keep + [ set-front-to-back ] keep + inc-length ; + : push-back ( obj dlist -- ) [ dlist-back f ] keep [ dlist-back set-next-when ] 2keep @@ -76,6 +86,9 @@ PRIVATE> [ set-front-to-back ] keep inc-length ; +: peek-front ( dlist -- obj ) + dlist-front dlist-node-obj ; + : pop-front ( dlist -- obj ) dup dlist-front [ dup dlist-node-next @@ -87,6 +100,9 @@ PRIVATE> : pop-front* ( dlist -- ) pop-front drop ; +: peek-back ( dlist -- obj ) + dlist-back dlist-node-obj ; + : pop-back ( dlist -- obj ) dup dlist-back [ dup dlist-node-prev @@ -108,25 +124,25 @@ PRIVATE> dup dlist-node-prev over dlist-node-next set-prev-when dup dlist-node-next swap dlist-node-prev set-next-when ; -: (delete-node) ( dlist dlist-node -- ) +: delete-node ( dlist dlist-node -- ) { { [ over dlist-front over eq? ] [ drop pop-front* ] } { [ over dlist-back over eq? ] [ drop pop-back* ] } { [ t ] [ unlink-node dec-length ] } } cond ; -: delete-node* ( quot dlist -- obj/f ? ) +: delete-node-if* ( quot dlist -- obj/f ? ) tuck dlist-find-node [ - [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* + [ delete-node ] keep [ dlist-node-obj t ] [ f f ] if* ] [ 2drop f f ] if ; inline -: delete-node ( quot dlist -- obj/f ) - delete-node* drop ; inline +: delete-node-if ( quot dlist -- obj/f ) + delete-node-if* drop ; inline : dlist-delete ( obj dlist -- obj/f ) - >r [ eq? ] curry r> delete-node ; + >r [ eq? ] curry r> delete-node-if ; : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index f5ad256ec5..3e3858d45d 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -421,6 +421,8 @@ DEFER: bar { 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect { 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +\ dispose must-infer + ! Test stream protocol \ set-timeout must-infer \ stream-read must-infer @@ -430,7 +432,6 @@ DEFER: bar \ stream-write must-infer \ stream-write1 must-infer \ stream-nl must-infer -\ stream-close must-infer \ stream-format must-infer \ stream-write-table must-infer \ stream-flush must-infer diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor old mode 100644 new mode 100755 index 3559a3487b..5d4bb70912 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: tools.test io.files io threads kernel ; +USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test [ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test @@ -41,7 +41,7 @@ USING: tools.test io.files io threads kernel ; [ ] [ "test-blah" resource-path make-directory ] unit-test [ ] [ - "test-blah/fooz" resource-path stream-close + "test-blah/fooz" resource-path dispose ] unit-test [ t ] [ diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index cf867d7945..5333b3c8c5 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -1,12 +1,12 @@ USING: help.markup help.syntax quotations hashtables kernel -classes strings ; +classes strings continuations ; IN: io ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl -"A word required to be implemented for all streams:" -{ $subsection stream-close } +"All streams must implement the " { $link dispose } " word in addition to the stream protocol." +$nl "Three words are required for input streams:" { $subsection stream-read1 } { $subsection stream-read } @@ -73,12 +73,6 @@ ARTICLE: "streams" "Streams" ABOUT: "streams" -HELP: stream-close -{ $values { "stream" "a stream" } } -{ $contract "Closes the stream. This releases any external resources associated with the stream, such as file handles and network connections. No further operations can be performed on the stream after this call." } -{ $notes "You must close streams after you are finished working with them. A convenient way to automate this is by using the " { $link with-stream } " word." } -$io-error ; - HELP: set-timeout { $values { "n" "an integer" } { "stream" "a stream" } } { $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } diff --git a/core/io/io.factor b/core/io/io.factor index edd0fa938f..e0c890c0e3 100755 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -4,7 +4,6 @@ USING: hashtables generic kernel math namespaces sequences strings continuations assocs io.styles sbufs ; IN: io -GENERIC: stream-close ( stream -- ) GENERIC: set-timeout ( n stream -- ) GENERIC: stream-readln ( stream -- str ) GENERIC: stream-read1 ( stream -- ch/f ) @@ -29,7 +28,7 @@ GENERIC: stream-write-table ( table-cells style stream -- ) [ over stream-write (stream-copy) ] [ 2drop ] if* ; : stream-copy ( in out -- ) - [ 2dup (stream-copy) ] [ stream-close stream-close ] [ ] + [ 2dup (stream-copy) ] [ dispose dispose ] [ ] cleanup ; ! Default stream @@ -54,9 +53,7 @@ SYMBOL: stderr stdio swap with-variable ; inline : with-stream ( stream quot -- ) - swap [ - [ stdio get stream-close ] [ ] cleanup - ] with-stream* ; inline + [ with-stream* ] curry with-disposal ; inline : tabular-output ( style quot -- ) swap >r { } make r> stdio get stream-write-table ; inline diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index d816e08443..b02c3367d4 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel kernel.private namespaces io strings sequences math generic threads.private classes io.backend io.streams.lines io.streams.plain io.streams.duplex -io.files ; +io.files continuations ; IN: io.streams.c TUPLE: c-writer handle ; @@ -19,7 +19,7 @@ M: c-writer stream-write M: c-writer stream-flush c-writer-handle fflush ; -M: c-writer stream-close +M: c-writer dispose c-writer-handle fclose ; TUPLE: c-reader handle ; @@ -46,7 +46,7 @@ M: c-reader stream-read-until [ swap read-until-loop ] "" make swap over empty? over not and [ 2drop f f ] when ; -M: c-reader stream-close +M: c-reader dispose c-reader-handle fclose ; : ( in out -- stream ) diff --git a/core/io/streams/duplex/duplex-docs.factor b/core/io/streams/duplex/duplex-docs.factor old mode 100644 new mode 100755 index 6293836348..fa82c54163 --- a/core/io/streams/duplex/duplex-docs.factor +++ b/core/io/streams/duplex/duplex-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax io ; +USING: help.markup help.syntax io continuations ; IN: io.streams.duplex ARTICLE: "io.streams.duplex" "Duplex streams" @@ -19,4 +19,4 @@ HELP: HELP: check-closed { $values { "stream" "a duplex stream" } } { $description "Throws a " { $link check-closed } " error if the stream has already been closed." } -{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link stream-close } "." } ; +{ $error-description "This error is thrown when performing an I/O operation on a " { $link duplex-stream } " which has been closed with " { $link dispose } "." } ; diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor old mode 100644 new mode 100755 index a4a6433a29..962a46413f --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -6,7 +6,7 @@ TUPLE: closing-stream closed? ; : closing-stream construct-empty ; -M: closing-stream stream-close +M: closing-stream dispose dup closing-stream-closed? [ "Closing twice!" throw ] [ @@ -17,24 +17,24 @@ TUPLE: unclosable-stream ; : unclosable-stream construct-empty ; -M: unclosable-stream stream-close +M: unclosable-stream dispose "Can't close me!" throw ; [ ] [ - dup stream-close stream-close + dup dispose dispose ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup stream-close ] catch 2drop + [ dup dispose ] catch 2drop ] keep closing-stream-closed? ] unit-test diff --git a/core/io/streams/duplex/duplex.factor b/core/io/streams/duplex/duplex.factor old mode 100644 new mode 100755 index a46dad71a0..86660b2752 --- a/core/io/streams/duplex/duplex.factor +++ b/core/io/streams/duplex/duplex.factor @@ -65,14 +65,14 @@ M: duplex-stream make-cell-stream M: duplex-stream stream-write-table duplex-stream-out+ stream-write-table ; -M: duplex-stream stream-close +M: duplex-stream dispose #! The output stream is closed first, in case both streams #! are attached to the same file descriptor, the output #! buffer needs to be flushed before we close the fd. dup duplex-stream-closed? [ t over set-duplex-stream-closed? - [ dup duplex-stream-out stream-close ] - [ dup duplex-stream-in stream-close ] [ ] cleanup + [ dup duplex-stream-out dispose ] + [ dup duplex-stream-in dispose ] [ ] cleanup ] unless drop ; M: duplex-stream set-timeout diff --git a/core/io/streams/nested/nested.factor b/core/io/streams/nested/nested.factor old mode 100644 new mode 100755 index 83a86a9ced..e32c90a2fc --- a/core/io/streams/nested/nested.factor +++ b/core/io/streams/nested/nested.factor @@ -1,14 +1,14 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.nested USING: arrays generic assocs kernel namespaces strings -quotations io ; +quotations io continuations ; TUPLE: ignore-close-stream ; : ignore-close-stream construct-delegate ; -M: ignore-close-stream stream-close drop ; +M: ignore-close-stream dispose drop ; TUPLE: style-stream style ; @@ -44,4 +44,4 @@ TUPLE: block-stream ; : block-stream construct-delegate ; -M: block-stream stream-close drop ; +M: block-stream dispose drop ; diff --git a/core/io/streams/string/string.factor b/core/io/streams/string/string.factor old mode 100644 new mode 100755 index 9aaece6e31..3d5a55739b --- a/core/io/streams/string/string.factor +++ b/core/io/streams/string/string.factor @@ -2,11 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.string USING: io kernel math namespaces sequences sbufs strings -generic splitting io.streams.plain io.streams.lines ; +generic splitting io.streams.plain io.streams.lines +continuations ; + +M: sbuf dispose drop ; M: sbuf stream-write1 push ; M: sbuf stream-write push-all ; -M: sbuf stream-close drop ; M: sbuf stream-flush drop ; : ( -- stream ) diff --git a/extra/cabal/cabal.factor b/extra/cabal/cabal.factor old mode 100644 new mode 100755 index cc51bcf308..0ad8465498 --- a/extra/cabal/cabal.factor +++ b/extra/cabal/cabal.factor @@ -41,7 +41,7 @@ VARS: input user ; : ((send-input)) ( other -- ) [ input> print flush ] with-stream* ; : (send-input) ( other -- ) -[ ((send-input)) ] catch [ print dup stream-close users> delete ] when ; +[ ((send-input)) ] catch [ print dup dispose users> delete ] when ; : send-input ( other -- ) dup duplex-stream-closed? [ users> delete ] [ (send-input) ] if ; diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor old mode 100644 new mode 100755 index 77a34e84d1..64b5ee9992 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -84,7 +84,7 @@ M: crypt-stream stream-write1 ( ch stream -- ) : check-close ( err -- ) dup CRYPT_ERROR_PARAM1 = [ drop ] [ check-result ] if ; -M: crypt-stream stream-close ( stream -- ) +M: crypt-stream dispose ( stream -- ) crypt-stream-handle cryptDestroySession check-close ; : create-session ( format -- session ) @@ -115,7 +115,7 @@ M: crypt-stream stream-close ( stream -- ) dup stream-readln print - stream-close + dispose end ; @@ -130,7 +130,7 @@ M: crypt-stream stream-close ( stream -- ) "Thanks!" over stream-print dup stream-flush - stream-close + dispose end ; @@ -152,6 +152,6 @@ M: crypt-stream stream-close ( stream -- ) (rpl) - stream-close + dispose end ; \ No newline at end of file diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor old mode 100644 new mode 100755 index 07f4ce119a..1121883b7c --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -15,7 +15,7 @@ PROTOCOL: assoc-protocol ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol - stream-close stream-read1 stream-read stream-read-until + stream-read1 stream-read stream-read-until stream-flush stream-write1 stream-write stream-format stream-nl make-span-stream make-block-stream stream-readln make-cell-stream stream-write-table set-timeout ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 3b959ba801..234e7891d7 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,22 +137,25 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap ; +USING: io.sockets io.launcher io.mmap io.monitor ; ARTICLE: "io" "Input and output" { $subsection "streams" } -"Stream implementations:" +"External streams:" { $subsection "file-streams" } +{ $subsection "network-streams" } +"Wrapper streams:" { $subsection "io.streams.duplex" } { $subsection "io.streams.lines" } { $subsection "io.streams.plain" } { $subsection "io.streams.string" } -"Advanced features:" +"Stream utilities:" { $subsection "stream-binary" } { $subsection "styles" } -{ $subsection "network-streams" } +"Advanced features:" { $subsection "io.launcher" } -{ $subsection "io.mmap" } ; +{ $subsection "io.mmap" } +{ $subsection "io.monitor" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor old mode 100644 new mode 100755 index b3308e83c2..f20ca27a5f --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -23,7 +23,7 @@ $nl $nl "Now, we tell Factor that all definitions in this source file should go into the " { $snippet "palindrome" } " vocabulary using the " { $link POSTPONE: IN: } " word:" { $code "IN: palindrome" } -"You are now ready to go on to the next section." ; +"You are now ready to go on to the next section: " { $link "first-program-logic" } "." ; ARTICLE: "first-program-logic" "Writing some logic in your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -56,7 +56,7 @@ $nl { $code "\\ = see" } "It's in the " { $vocab-link "kernel" } " vocabulary, which we've already added to the search path." -"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors." ; +"Now press " { $command workspace "workflow" refresh-all } " again, and the source file should reload without any errors. You can now go on and learn about " { $link "first-program-test" } "." ; ARTICLE: "first-program-test" "Testing your first program" "Your " { $snippet "palindrome.factor" } " file should look like the following after the previous section:" @@ -92,7 +92,7 @@ $nl } "Now, you can run unit tests:" { $code "\"palindrome\" test" } -"It should report that all tests have passed." ; +"It should report that all tests have passed. Now you can read about " { $link "first-program-extend" } "." ; ARTICLE: "first-program-extend" "Extending your first program" "Our palindrome program works well, however we'd like to extend it to ignore spaces and non-alphabetical characters in the input." diff --git a/extra/html/html.factor b/extra/html/html.factor index f9d5bde5e6..b5d4e63930 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -105,7 +105,7 @@ TUPLE: html-sub-stream style stream ; TUPLE: html-span-stream ; -M: html-span-stream stream-close +M: html-span-stream dispose end-sub-stream not-a-div format-html-span ; : border-css, ( border -- ) @@ -138,7 +138,7 @@ M: html-span-stream stream-close TUPLE: html-block-stream ; -M: html-block-stream stream-close ( quot style stream -- ) +M: html-block-stream dispose ( quot style stream -- ) end-sub-stream a-div format-html-div ; : border-spacing-css, diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor old mode 100644 new mode 100755 index 7c385c0bb3..d03ce37c14 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -44,14 +44,14 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - stream-close "Location" swap at nip http-get-stream + dispose "Location" swap at nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep - ] [ >r stream-close r> rethrow ] recover do-redirect ; + ] [ ] [ dispose ] cleanup do-redirect ; : http-get ( url -- code headers string ) #! Opens a stream for reading from an HTTP URL. diff --git a/extra/io/mmap/mmap-docs.factor b/extra/io/mmap/mmap-docs.factor old mode 100644 new mode 100755 index 22e403ed31..cb51088e58 --- a/extra/io/mmap/mmap-docs.factor +++ b/extra/io/mmap/mmap-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax alien math ; +USING: help.markup help.syntax alien math continuations ; IN: io.mmap HELP: mapped-file @@ -15,21 +15,17 @@ HELP: { $notes "You must call " { $link close-mapped-file } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." } { $errors "Throws an error if a memory mapping could not be established." } ; -HELP: (close-mapped-file) -{ $values { "mmap" mapped-file } } -{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link close-mapped-file } " instead." } -{ $errors "Throws an error if a memory mapping could not be established." } ; - HELP: close-mapped-file { $values { "mmap" mapped-file } } -{ $description "Releases system resources associated with the mapped file." } +{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." } { $errors "Throws an error if a memory mapping could not be established." } ; ARTICLE: "io.mmap" "Memory-mapped files" "The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files." { $subsection } -{ $subsection close-mapped-file } -"A combinator which wraps the above two words:" +"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which wraps the above:" { $subsection with-mapped-file } "Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:" { $subsection mapped-file-address } diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index 26378a06aa..af020e5a26 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -23,14 +23,12 @@ INSTANCE: mapped-file sequence HOOK: io-backend ( path length -- mmap ) -HOOK: (close-mapped-file) io-backend ( mmap -- ) +HOOK: close-mapped-file io-backend ( mmap -- ) -: close-mapped-file ( mmap -- ) +M: mapped-file dispose ( mmap -- ) check-closed t over set-mapped-file-closed? - (close-mapped-file) ; + close-mapped-file ; : with-mapped-file ( path length quot -- ) - >r r> - [ keep ] curry - [ close-mapped-file ] [ ] cleanup ; inline + >r r> with-disposal ; inline diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor new file mode 100755 index 0000000000..56fd203bde --- /dev/null +++ b/extra/io/monitor/monitor-docs.factor @@ -0,0 +1,61 @@ +IN: io.monitor +USING: help.markup help.syntax continuations ; + +HELP: +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } } +{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." +$nl +"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; + +HELP: next-change +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } } +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ; + +HELP: with-monitor +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; + +HELP: +change-file+ +{ $description "Indicates that the contents of the file have changed." } ; + +HELP: +change-name+ +{ $description "Indicates that the file name has changed." } ; + +HELP: +change-size+ +{ $description "Indicates that the file size has changed." } ; + +HELP: +change-attributes+ +{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ; + +HELP: +change-modified+ +{ $description "Indicates that the last modification time of the file has changed." } ; + +ARTICLE: "io.monitor.descriptors" "File system change descriptors" +"Change descriptors output by " { $link next-change } ":" +{ $subsection +change-file+ } +{ $subsection +change-name+ } +{ $subsection +change-size+ } +{ $subsection +change-attributes+ } +{ $subsection +change-modified+ } ; + +ARTICLE: "io.monitor" "File system change monitors" +"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." +$nl +"Creating a file system change monitor and listening for changes:" +{ $subsection } +{ $subsection next-change } +{ $subsection "io.monitor.descriptors" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." +$nl +"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection with-monitor } +"An example which watches the Factor directory for changes:" +{ $code + "USE: io.monitor" + ": watch-loop ( monitor -- )" + " dup next-change . . nl nl flush watch-loop ;" + "" + "\"\" resource-path f [ watch-loop ] with-monitor" +} ; + +ABOUT: "io.monitor" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 23b336c929..044fa9572b 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -5,8 +5,6 @@ IN: io.monitor HOOK: io-backend ( path recursive? -- monitor ) -HOOK: close-monitor io-backend ( monitor -- ) - HOOK: next-change io-backend ( monitor -- path changes ) SYMBOL: +change-file+ @@ -16,4 +14,4 @@ SYMBOL: +change-attributes+ SYMBOL: +change-modified+ : with-monitor ( path recursive? quot -- ) - >r r> over [ close-monitor ] curry [ ] cleanup ; + >r r> with-disposal ; inline diff --git a/extra/io/nonblocking/nonblocking-docs.factor b/extra/io/nonblocking/nonblocking-docs.factor old mode 100644 new mode 100755 index d6d619229f..af73a47030 --- a/extra/io/nonblocking/nonblocking-docs.factor +++ b/extra/io/nonblocking/nonblocking-docs.factor @@ -1,5 +1,5 @@ USING: io io.buffers io.backend help.markup help.syntax kernel -strings sbufs words ; +strings sbufs words continuations ; IN: io.nonblocking ARTICLE: "io.nonblocking" "Non-blocking I/O implementation" @@ -23,7 +23,7 @@ $nl "Per-port native I/O protocol:" { $subsection init-handle } { $subsection (wait-to-read) } -"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link stream-close } " generic words." +"Additionally, the I/O backend must provide an implementation of the " { $link stream-flush } " and " { $link dispose } " generic words." $nl "Dummy ports which should be used to implement networking:" { $subsection server-port } diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 8a7e732281..9d08e87fa3 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -1,16 +1,20 @@ -! Copyright (C) 2005, 2007 Slava Pestov, Doug Coleman +! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman ! See http://factorcode.org/license.txt for BSD license. IN: io.nonblocking -USING: math kernel io sequences io.buffers generic sbufs -system io.streams.lines io.streams.plain io.streams.duplex -continuations debugger classes byte-arrays namespaces -splitting ; +USING: math kernel io sequences io.buffers generic sbufs system +io.streams.lines io.streams.plain io.streams.duplex io.backend +continuations debugger classes byte-arrays namespaces splitting +dlists ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global ! Common delegate of native stream readers and writers -TUPLE: port handle error timeout cutoff type eof? ; +TUPLE: port +handle +error +timeout-entry timeout cutoff +type eof? ; SYMBOL: closed @@ -41,19 +45,46 @@ GENERIC: close-handle ( handle -- ) : handle>duplex-stream ( in-handle out-handle -- stream ) - [ >r r> ] [ ] [ stream-close ] + [ >r r> ] [ ] [ dispose ] cleanup ; -: touch-port ( port -- ) - dup port-timeout dup zero? - [ 2drop ] [ millis + swap set-port-cutoff ] if ; - : timeout? ( port -- ? ) port-cutoff dup zero? not swap millis < and ; : pending-error ( port -- ) dup port-error f rot set-port-error [ throw ] when* ; +SYMBOL: timeout-queue + + timeout-queue set-global + +: unqueue-timeout ( port -- ) + port-timeout-entry [ + timeout-queue get-global swap delete-node + ] when* ; + +: queue-timeout ( port -- ) + dup timeout-queue get-global push-front* + swap set-port-timeout-entry ; + +HOOK: expire-port io-backend ( port -- ) + +M: object expire-port drop ; + +: expire-timeouts ( -- ) + timeout-queue get-global dup dlist-empty? [ drop ] [ + dup peek-back timeout? + [ pop-back expire-port expire-timeouts ] [ drop ] if + ] if ; + +: touch-port ( port -- ) + dup port-timeout dup zero? [ + 2drop + ] [ + millis + over set-port-cutoff + dup unqueue-timeout queue-timeout + ] if ; + M: port set-timeout [ set-port-timeout ] keep touch-port ; @@ -157,7 +188,7 @@ GENERIC: port-flush ( port -- ) M: output-port stream-flush ( port -- ) dup port-flush pending-error ; -M: port stream-close +M: port dispose dup port-type closed eq? [ dup port-type >r closed over set-port-type r> output-port eq? [ dup port-flush ] when diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 0141289c38..6e7cd5a940 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -29,8 +29,7 @@ SYMBOL: log-stream : with-log-file ( file quot -- ) >r r> - [ [ with-log-stream ] 2keep ] - [ drop stream-close ] [ ] cleanup ; inline + [ with-log-stream ] with-disposal ; inline : with-log-stdio ( quot -- ) stdio get swap with-log-stream ; @@ -52,7 +51,7 @@ SYMBOL: log-stream [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) - [ accept-loop ] [ drop stream-close ] [ ] cleanup ; inline + [ accept-loop ] compose with-disposal ; inline : spawn-server ( addrspec quot -- ) "Waiting for connections on " pick unparse append @@ -87,8 +86,7 @@ SYMBOL: log-stream : spawn-datagrams ( quot addrspec -- ) "Waiting for datagrams on " over unparse append log-message - [ datagram-loop ] [ stream-close ] [ ] cleanup ; - inline + [ datagram-loop ] with-disposal ; inline : with-datagrams ( seq service quot -- ) [ diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor old mode 100644 new mode 100755 index a5c623b6b7..9136c3ca22 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io io.backend threads -strings byte-arrays ; +strings byte-arrays continuations ; IN: io.sockets ARTICLE: "network-addressing" "Address specifiers" @@ -19,7 +19,7 @@ ARTICLE: "network-connection" "Connection-oriented networking" { $subsection accept } "The stream returned by " { $link accept } " holds the address specifier of the remote client:" { $subsection client-stream-addr } -"Server sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Server sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -36,7 +36,7 @@ ARTICLE: "network-packet" "Packet-oriented networking" "Packets can be sent and received with a pair of words:" { $subsection send } { $subsection receive } -"Packet-oriented sockets are closed by calling " { $link stream-close } ", but they do not respond to the rest of the stream protocol." +"Packet-oriented sockets are closed by calling " { $link dispose } "." $nl "Address specifiers have the following interpretation with connection-oriented networking words:" { $list @@ -104,7 +104,7 @@ HELP: { $description "Begins listening for network connections to a local address. Server objects responds to two words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link accept } " - blocks until there is a connection" } } } @@ -128,7 +128,7 @@ HELP: { $values { "addrspec" "an address specifier" } { "datagram" "a handle" } } { $description "Creates a datagram socket bound to a local address. Datagram socket objects responds to three words:" { $list - { { $link stream-close } " - stops listening on the port and frees all associated resources" } + { { $link dispose } " - stops listening on the port and frees all associated resources" } { { $link receive } " - waits for a packet" } { { $link send } " - sends a packet" } } diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor old mode 100644 new mode 100755 index 12a36091ce..28d1b29be8 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -5,7 +5,7 @@ USING: kernel io ; TUPLE: null-stream ; -M: null-stream stream-close drop ; +M: null-stream dispose drop ; M: null-stream set-timeout 2drop ; M: null-stream stream-readln drop f ; M: null-stream stream-read1 drop f ; diff --git a/extra/io/unix/mmap/mmap.factor b/extra/io/unix/mmap/mmap.factor old mode 100644 new mode 100755 index 5a72a5426a..71c55f2303 --- a/extra/io/unix/mmap/mmap.factor +++ b/extra/io/unix/mmap/mmap.factor @@ -15,7 +15,7 @@ M: unix-io ( path length -- obj ) dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor r> mmap-open f mapped-file construct-boa ; -M: unix-io (close-mapped-file) ( mmap -- ) +M: unix-io close-mapped-file ( mmap -- ) [ mapped-file-address ] keep [ mapped-file-length munmap ] keep mapped-file-handle close diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor old mode 100644 new mode 100755 index 35366b1d41..748dbc40a7 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -15,8 +15,7 @@ libc combinators ; #! don't set up error handlers until after #! returns (and if they did before, they wouldn't have #! anything to close!) - dup port-error dup - [ swap stream-close throw ] [ 2drop ] if ; + dup port-error dup [ swap dispose throw ] [ 2drop ] if ; : socket-fd ( domain type -- socket ) 0 socket dup io-error dup init-handle ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor old mode 100644 new mode 100755 index e328e7bf5d..ce2f052450 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -63,7 +63,7 @@ yield "d" get send - "d" get stream-close + "d" get dispose "Done" print @@ -104,7 +104,7 @@ client-addr >r >string r> ] unit-test -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! Test error behavior @@ -120,7 +120,7 @@ client-addr B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send ] unit-test-fails -[ ] [ "d" get stream-close ] unit-test +[ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close diff --git a/extra/io/windows/mmap/mmap.factor b/extra/io/windows/mmap/mmap.factor index 27587e8340..d1cafa4c0f 100755 --- a/extra/io/windows/mmap/mmap.factor +++ b/extra/io/windows/mmap/mmap.factor @@ -81,7 +81,7 @@ M: windows-io ( path length -- mmap ) f \ mapped-file construct-boa ] with-destructors ; -M: windows-io (close-mapped-file) ( mapped-file -- ) +M: windows-io close-mapped-file ( mapped-file -- ) [ dup mapped-file-handle [ close-always ] each mapped-file-address UnmapViewOfFile win32-error=0/f diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 3b10ddd935..940b1b7fee 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -1,8 +1,8 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking -io.windows libc kernel math namespaces sequences threads -tuples.lib windows windows.errors windows.kernel32 strings -splitting io.files qualified ; +io.windows libc kernel math namespaces sequences +threads tuples.lib windows windows.errors windows.kernel32 +strings splitting io.files qualified ; QUALIFIED: windows.winsock IN: io.windows.nt.backend @@ -122,19 +122,11 @@ M: windows-nt-io add-completion ( handle -- ) : drain-overlapped ( timeout -- ) handle-overlapped [ 0 drain-overlapped ] unless ; -: maybe-expire ( io-callbck -- ) - io-callback-port - dup timeout? [ - port-handle win32-file-handle CancelIo drop - ] [ - drop - ] if ; - -: cancel-timeout ( -- ) - io-hash get-global [ nip maybe-expire ] assoc-each ; +M: windows-nt-io expire-port + port-handle win32-file-handle CancelIo drop ; M: windows-nt-io io-multiplex ( ms -- ) - cancel-timeout drain-overlapped ; + expire-timeouts drain-overlapped ; M: windows-nt-io init-io ( -- ) master-completion-port set-global diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index bd3debecad..f296e859f0 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -34,8 +34,6 @@ M: windows-nt-io ( path recursive? -- monitor ) : check-closed ( monitor -- ) port-type closed eq? [ "Monitor closed" throw ] when ; -M: windows-nt-io close-monitor ( monitor -- ) stream-close ; - : begin-reading-changes ( monitor -- overlapped ) dup port-handle win32-file-handle over buffer-ptr diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 03cb3be9ae..419864b624 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -1,10 +1,11 @@ -! Copyright (C) 2004, 2007 Mackenzie Straight, Doug Coleman. +! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types arrays destructors io io.backend io.buffers io.files io.nonblocking io.sockets io.binary io.sockets.impl windows.errors strings io.streams.duplex kernel math namespaces sequences windows windows.kernel32 -windows.shell32 windows.types windows.winsock splitting ; +windows.shell32 windows.types windows.winsock splitting +continuations ; IN: io.windows TUPLE: windows-nt-io ; @@ -174,7 +175,7 @@ USE: namespaces : listen-on-socket ( socket -- ) listen-backlog listen winsock-return-check ; -M: win32-socket stream-close ( stream -- ) +M: win32-socket dispose ( stream -- ) win32-file-handle closesocket drop ; M: windows-io addrinfo-error ( n -- ) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor old mode 100644 new mode 100755 index 6f54768cab..74d8951d10 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -185,7 +185,7 @@ SYMBOL: line dup irc-client-profile profile-server over irc-client-profile profile-port connect* dup irc-client-profile profile-nickname login - [ irc-loop ] [ irc-stream> stream-close ] [ ] cleanup ; + [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ; : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor old mode 100644 new mode 100755 index 4a737f06c2..ee312c1111 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -95,7 +95,7 @@ TUPLE: unimplemented-typeflag header ; ! Normal file : typeflag-0 tar-header-name tar-path+ - [ read-data-blocks ] keep stream-close ; + [ read-data-blocks ] keep dispose ; ! Hard link : typeflag-1 ( header -- ) @@ -221,7 +221,7 @@ TUPLE: unimplemented-typeflag header ; [ throw ] } case ! dup tar-header-size zero? [ - ! out-stream get [ stream-close ] when + ! out-stream get [ dispose ] when ! out-stream off ! drop ! ] [ diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 83e0ea5ec3..f2bd03475f 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -9,15 +9,16 @@ quotations io.launcher words.private tools.deploy.config bootstrap.image ; IN: tools.deploy.backend -: (copy-lines) ( stream -- stream ) - dup stream-readln [ print flush (copy-lines) ] when* ; +: (copy-lines) ( stream -- ) + dup stream-readln dup + [ print flush (copy-lines) ] [ 2drop ] if ; : copy-lines ( stream -- ) - [ (copy-lines) ] [ stream-close ] [ ] cleanup ; + [ (copy-lines) ] with-disposal ; : run-with-output ( descriptor -- ) - dup duplex-stream-out stream-close + dup duplex-stream-out dispose copy-lines ; : boot-image-name ( -- string ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index 016d02e527..dde312b34d 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -8,7 +8,7 @@ hashtables io kernel namespaces sequences io.styles strings quotations math opengl combinators math.vectors io.streams.duplex sorting splitting io.streams.nested assocs ui.gadgets.presentations ui.gadgets.slots ui.gadgets.grids -ui.gadgets.grid-lines tuples models ; +ui.gadgets.grid-lines tuples models continuations ; IN: ui.gadgets.panes TUPLE: pane output current prototype scrolls? @@ -161,7 +161,7 @@ M: pane-stream stream-write M: pane-stream stream-format [ rot string-lines pane-format ] do-pane-stream ; -M: pane-stream stream-close drop ; +M: pane-stream dispose drop ; M: pane-stream stream-flush drop ; @@ -249,7 +249,7 @@ TUPLE: nested-pane-stream style parent ; TUPLE: pane-block-stream ; -M: pane-block-stream stream-close +M: pane-block-stream dispose unnest-pane-stream write-gadget ; M: pane-stream make-block-stream @@ -272,7 +272,7 @@ M: pane-stream make-block-stream TUPLE: pane-cell-stream ; -M: pane-cell-stream stream-close ?nl ; +M: pane-cell-stream dispose ?nl ; M: pane-stream make-cell-stream pane-cell-stream construct-delegate ; @@ -284,9 +284,9 @@ M: pane-stream stream-write-table r> print-gadget ; ! Stream utilities -M: pack stream-close drop ; +M: pack dispose drop ; -M: paragraph stream-close drop ; +M: paragraph dispose drop ; : gadget-write ( string gadget -- ) over empty? [ From b60a4f4ade1abf8756edb817122434f612fcddce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 00:52:24 -0600 Subject: [PATCH 026/317] Clean up listener --- core/listener/listener.factor | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 8f26ddf9b2..02cd727930 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -18,11 +18,10 @@ GENERIC: stream-read-quot ( stream -- quot/f ) [ parse-lines in get ] with-compilation-unit in set ; : read-quot-step ( lines -- quot/f ) - [ parse-lines-interactive ] catch { - { [ dup delegate unexpected-eof? ] [ 2drop f ] } - { [ dup not ] [ drop ] } - { [ t ] [ rethrow ] } - } cond ; + [ parse-lines-interactive ] [ + dup delegate unexpected-eof? + [ 2drop f ] [ rethrow ] if + ] recover ; : read-quot-loop ( stream accum -- quot/f ) over stream-readln dup [ From 14481db63f1ef04af43972009aa78cff1d7c85e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:15:28 -0600 Subject: [PATCH 027/317] Smarter download word, old download word renamed to download-to for Ed --- extra/http/client/client-tests.factor | 5 +++++ extra/http/client/client.factor | 18 ++++++++++++++++-- 2 files changed, 21 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/http/client/client-tests.factor diff --git a/extra/http/client/client-tests.factor b/extra/http/client/client-tests.factor old mode 100644 new mode 100755 index 5c570993e6..d2fb719acd --- a/extra/http/client/client-tests.factor +++ b/extra/http/client/client-tests.factor @@ -7,3 +7,8 @@ USING: http.client tools.test ; [ 404 ] [ "404 File not found" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200" parse-response ] unit-test [ 200 ] [ "HTTP/1.0 200 Success" parse-response ] unit-test + +[ "foo.txt" ] [ "http://www.paulgraham.com/foo.txt" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt?xxx" download-name ] unit-test +[ "foo.txt" ] [ "http://www.arcsucks.com/foo.txt/" download-name ] unit-test +[ "www.arcsucks.com" ] [ "http://www.arcsucks.com////" download-name ] unit-test diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index d03ce37c14..dde2c7d205 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -59,9 +59,23 @@ DEFER: http-get-stream http-get-stream [ stdio get contents ] with-stream ] with-scope ; -: download ( url file -- ) +: download-name ( url -- name ) + file-name "?" split1 drop "/" ?tail drop ; + +: default-timeout 60 1000 * over set-timeout ; + +: success? ( code -- ? ) 200 = ; + +: download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get 2nip r> [ write ] with-stream ; + >r http-get-stream nip default-timeout swap success? [ + r> stream-copy + ] [ + r> drop dispose "HTTP download failed" throw + ] if ; + +: download ( url -- ) + dup download-name download-to ; : post-request ( content-type content host resource -- ) #! Note: It is up to the caller to url encode the content if From 0a5f90d5daebfbf97e6d199d4a4210f72b6ed9a1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:15:41 -0600 Subject: [PATCH 028/317] Clarify docs --- core/io/io-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 5333b3c8c5..208e2a2ba7 100755 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -75,8 +75,8 @@ ABOUT: "streams" HELP: set-timeout { $values { "n" "an integer" } { "stream" "a stream" } } -{ $contract "Sets a timeout, in milliseconds, for closing the stream if there is no activity. Not all streams support timeouts." } -$io-error ; +{ $contract "Sets a timeout, in milliseconds, for input and output operations on the stream. If a read or a write is initiated and no activity is seen before the timeout expires, an error will be thrown to the caller of the operation being performed." } +{ $notes "Whether or not the stream is closed when the error is thrown is implementation-specific, and user code should take care to close the stream on all error conditions in any case." } ; HELP: stream-readln { $values { "stream" "an input stream" } { "str" string } } From d08919199c748eb20e0013b72dd68a2d6ed8a631 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:16:02 -0600 Subject: [PATCH 029/317] Update bunny --- extra/bunny/bunny.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/bunny/bunny.factor diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor old mode 100644 new mode 100755 index 3042b87ad6..550eb50e0a --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -53,7 +53,7 @@ IN: bunny model-path resource-path dup exists? [ "Downloading bunny from " write model-url dup print flush - over download + over download-to ] unless ; : draw-triangle ( ns vs triple -- ) From 5478f225247a2c0c429d01a985c625dd4ca48432 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 01:16:10 -0600 Subject: [PATCH 030/317] Don't blow away timeouts on reload --- extra/io/nonblocking/nonblocking.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 9d08e87fa3..ca50d7063a 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -4,7 +4,7 @@ IN: io.nonblocking USING: math kernel io sequences io.buffers generic sbufs system io.streams.lines io.streams.plain io.streams.duplex io.backend continuations debugger classes byte-arrays namespaces splitting -dlists ; +dlists assocs ; SYMBOL: default-buffer-size 64 1024 * default-buffer-size set-global @@ -56,7 +56,7 @@ GENERIC: close-handle ( handle -- ) SYMBOL: timeout-queue - timeout-queue set-global +timeout-queue global [ [ ] unless* ] change-at : unqueue-timeout ( port -- ) port-timeout-entry [ From fd4254ca094f0e8d6134e02f87c661899a98145e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 31 Jan 2008 11:34:03 -0600 Subject: [PATCH 031/317] update client to work with more redirects --- extra/http/client/client.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7c385c0bb3..85a8b516ca 100644 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -44,7 +44,7 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - stream-close "Location" swap at nip http-get-stream + stream-close "location" swap header-single nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) From 91213541169fff492932649140dadd68ae796f00 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 11:51:38 -0600 Subject: [PATCH 032/317] Adding word wrap vocab --- extra/wrap/wrap.factor | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) create mode 100644 extra/wrap/wrap.factor diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor new file mode 100644 index 0000000000..4392ac81a6 --- /dev/null +++ b/extra/wrap/wrap.factor @@ -0,0 +1,30 @@ +USING: sequences kernel namespaces splitting math ; +IN: wrap + +! Very stupid word wrapping/line breaking +! This will be replaced by a Unicode-aware method, +! which works with variable-width fonts + +SYMBOL: width + +: line-chunks ( string -- words-lines ) + "\n" split [ " \t" split [ empty? not ] subset ] map ; + +: (split-chunk) ( words -- ) + -1 over [ length + 1+ dup width get > ] find drop nip + [ cut-slice swap , (split-chunk) ] [ , ] if* ; + +: split-chunk ( words -- lines ) + [ (split-chunk) ] { } make ; + +: broken-lines ( string width -- lines ) + width [ + line-chunks + [ split-chunk [ " " join ] map ] map concat + ] with-variable ; + +: line-break ( string width -- newstring ) + broken-lines "\n" join ; + +: indented-break ( string width indent -- newstring ) + [ length - broken-lines ] keep [ swap append ] curry map "\n" join ; From eab654bb8a98f7dfbeb4e8917ca8ea9f151dfd6b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 11:58:17 -0600 Subject: [PATCH 033/317] Changing names of words --- extra/boids/ui/ui.factor | 20 ++++++++++---------- extra/namespaces/lib/lib.factor | 2 +- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/extra/boids/ui/ui.factor b/extra/boids/ui/ui.factor index 6d04a4d623..b545f41060 100644 --- a/extra/boids/ui/ui.factor +++ b/extra/boids/ui/ui.factor @@ -145,20 +145,20 @@ VARS: population-label cohesion-label alignment-label separation-label ; slate> over @center grid-add H{ } clone - T{ key-down f f "1" } C[ drop randomize ] put-hash - T{ key-down f f "2" } C[ drop sub-10-boids ] put-hash - T{ key-down f f "3" } C[ drop add-10-boids ] put-hash + T{ key-down f f "1" } C[ drop randomize ] put-at + T{ key-down f f "2" } C[ drop sub-10-boids ] put-at + T{ key-down f f "3" } C[ drop add-10-boids ] put-at - T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-hash - T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-hash + T{ key-down f f "q" } C[ drop inc-cohesion-weight ] put-at + T{ key-down f f "a" } C[ drop dec-cohesion-weight ] put-at - T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-hash - T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-hash + T{ key-down f f "w" } C[ drop inc-alignment-weight ] put-at + T{ key-down f f "s" } C[ drop dec-alignment-weight ] put-at - T{ key-down f f "e" } C[ drop inc-separation-weight ] put-hash - T{ key-down f f "d" } C[ drop dec-separation-weight ] put-hash + T{ key-down f f "e" } C[ drop inc-separation-weight ] put-at + T{ key-down f f "d" } C[ drop dec-separation-weight ] put-at - T{ key-down f f "ESC" } C[ drop toggle-loop ] put-hash + T{ key-down f f "ESC" } C[ drop toggle-loop ] put-at tuck set-gadget-delegate "Boids" open-window ; : boids-window ( -- ) [ [ boids-window* ] with-scope ] with-ui ; diff --git a/extra/namespaces/lib/lib.factor b/extra/namespaces/lib/lib.factor index 6e66119cb0..528e770558 100644 --- a/extra/namespaces/lib/lib.factor +++ b/extra/namespaces/lib/lib.factor @@ -16,4 +16,4 @@ IN: namespaces.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: set* ( val var -- ) namestack* set-hash-stack ; +: set* ( val var -- ) namestack* set-assoc-stack ; From b98dc7ec0a738c19c5bc1533e35de5d6d725c3f1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 12:16:34 -0600 Subject: [PATCH 034/317] Fixing use of a qualified name --- extra/io/sniffer/bsd/bsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/sniffer/bsd/bsd.factor b/extra/io/sniffer/bsd/bsd.factor index ae87c05d38..66336425a1 100644 --- a/extra/io/sniffer/bsd/bsd.factor +++ b/extra/io/sniffer/bsd/bsd.factor @@ -7,7 +7,7 @@ sequences io.sniffer.backend ; QUALIFIED: unix IN: io.sniffer.bsd -M: unix-io destruct-handle ( obj -- ) close drop ; +M: unix-io destruct-handle ( obj -- ) unix:close drop ; C-UNION: ifreq_props "sockaddr-in" "short" "int" "caddr_t" ; C-STRUCT: ifreq { { "char" 16 } "name" } { "ifreq_props" "props" } ; From 40ca906f1c117af5ff9e96165c99169fd1f7aea0 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 12:18:31 -0600 Subject: [PATCH 035/317] fixing use in cryptlib.streams --- extra/cryptlib/streams/streams.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor index 64b5ee9992..750d2a426c 100755 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -3,7 +3,7 @@ USING: cryptlib cryptlib.libcl kernel alien sequences byte-arrays namespaces io.buffers math generic io strings io.streams.lines io.streams.plain io.streams.duplex combinators -alien.c-types ; +alien.c-types continuations ; IN: cryptlib.streams @@ -154,4 +154,4 @@ M: crypt-stream dispose ( stream -- ) dispose end - ; \ No newline at end of file + ; From 4e3426d8718d5070d0c14a2f587814ad79a9679e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 31 Jan 2008 12:21:49 -0600 Subject: [PATCH 036/317] Fixing various use clauses --- extra/html/elements/elements.factor | 2 +- extra/html/html.factor | 2 +- extra/io/streams/null/null.factor | 2 +- extra/tar/tar.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index ff3e7b1283..101bc423b5 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.writer compiler.units effects ; +sequences strings words xml.entities compiler.units effects ; IN: html.elements diff --git a/extra/html/html.factor b/extra/html/html.factor index b5d4e63930..0860ae6c48 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -3,7 +3,7 @@ USING: generic assocs help http io io.styles io.files io.streams.string kernel math math.parser namespaces quotations assocs sequences strings words html.elements -xml.writer sbufs ; +xml.entities sbufs continuations ; IN: html GENERIC: browser-link-href ( presented -- href ) diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index 28d1b29be8..f76b0cbce3 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io ; +USING: kernel io continuations ; TUPLE: null-stream ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index ee312c1111..3bce7df9d6 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,5 +1,5 @@ USING: combinators io io.files io.streams.duplex -io.streams.string kernel math math.parser +io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system ; USING: hexdump tools.interpreter ; IN: tar From 92ebcc36199eba0f51fe08445110a72d7812b5fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 12:27:37 -0600 Subject: [PATCH 037/317] New timeout implementation --- extra/io/nonblocking/nonblocking.factor | 11 +++++++--- extra/io/unix/backend/backend.factor | 14 +++++++----- extra/io/unix/sockets/sockets.factor | 9 ++++---- extra/io/windows/ce/sockets/sockets.factor | 25 +++++++++++----------- extra/io/windows/nt/files/files.factor | 11 +++------- extra/io/windows/nt/monitor/monitor.factor | 7 ++++-- extra/io/windows/nt/sockets/sockets.factor | 19 ++++++++-------- 7 files changed, 53 insertions(+), 43 deletions(-) diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index ca50d7063a..3588ea5d14 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -77,7 +77,7 @@ M: object expire-port drop ; [ pop-back expire-port expire-timeouts ] [ drop ] if ] if ; -: touch-port ( port -- ) +: begin-timeout ( port -- ) dup port-timeout dup zero? [ 2drop ] [ @@ -85,8 +85,13 @@ M: object expire-port drop ; dup unqueue-timeout queue-timeout ] if ; -M: port set-timeout - [ set-port-timeout ] keep touch-port ; +: end-timeout ( port -- ) + unqueue-timeout ; + +: with-port-timeout ( port quot -- ) + over begin-timeout keep end-timeout ; inline + +M: port set-timeout set-port-timeout ; GENERIC: (wait-to-read) ( port -- ) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 6da26b5b67..141b115ebe 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -57,7 +57,11 @@ GENERIC: wait-for-events ( ms mx -- ) M: mx register-io-task ( task mx -- ) 2dup check-io-task fd/container set-at ; -: add-io-task ( task -- ) mx get-global register-io-task ; +: add-io-task ( task -- ) + mx get-global register-io-task stop ; + +: with-port-continuation ( port quot -- port ) + [ callcc0 ] curry with-port-timeout ; inline M: mx unregister-io-task ( task mx -- ) fd/container delete-at drop ; @@ -98,7 +102,6 @@ M: integer close-handle ( fd -- ) io-task-callbacks [ schedule-thread ] each ; : handle-io-task ( mx task -- ) - dup io-task-port touch-port dup do-io-task [ pop-callbacks ] [ 2drop ] if ; : handle-timeout ( mx task -- ) @@ -133,7 +136,8 @@ M: read-task do-io-task [ [ reader-eof ] [ drop ] if ] keep ; M: input-port (wait-to-read) - [ add-io-task stop ] callcc0 pending-error ; + [ add-io-task ] with-port-continuation + pending-error ; ! Writers : write-step ( port -- ? ) @@ -151,11 +155,11 @@ M: write-task do-io-task : add-write-io-task ( port continuation -- ) over port-handle mx get-global mx-writes at* - [ io-task-callbacks push drop ] + [ io-task-callbacks push stop ] [ drop add-io-task ] if ; : (wait-to-write) ( port -- ) - [ add-write-io-task stop ] callcc0 drop ; + [ add-write-io-task ] with-port-continuation drop ; M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 748dbc40a7..59a9a8ac2e 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -40,7 +40,7 @@ M: connect-task do-io-task 0 < [ defer-error ] [ drop t ] if ; : wait-to-connect ( port -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io (client) ( addrspec -- stream ) dup make-sockaddr/size >r >r @@ -82,7 +82,7 @@ M: accept-task do-io-task over 0 >= [ do-accept t ] [ 2drop defer-error ] if ; : wait-to-accept ( server -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; USE: io.sockets @@ -147,7 +147,7 @@ M: receive-task do-io-task ] if ; : wait-receive ( stream -- ) - [ add-io-task stop ] callcc0 drop ; + [ add-io-task ] with-port-continuation drop ; M: unix-io receive ( datagram -- packet addrspec ) dup check-datagram-port @@ -178,7 +178,8 @@ M: send-task do-io-task swap 0 < [ io-task-port defer-error ] [ drop t ] if ; : wait-send ( packet sockaddr len stream -- ) - [ add-io-task stop ] callcc0 2drop 2drop ; + [ add-io-task ] with-port-continuation + 2drop 2drop ; M: unix-io send ( packet addrspec datagram -- ) 3dup check-datagram-send diff --git a/extra/io/windows/ce/sockets/sockets.factor b/extra/io/windows/ce/sockets/sockets.factor index 5f87088804..9114dceb75 100755 --- a/extra/io/windows/ce/sockets/sockets.factor +++ b/extra/io/windows/ce/sockets/sockets.factor @@ -42,19 +42,20 @@ M: windows-ce-io ( addrspec -- duplex-stream ) ] keep ; M: windows-ce-io accept ( server -- client ) - dup check-server-port [ - dup touch-port - dup port-handle win32-file-handle - swap server-port-addr sockaddr-type heap-size - dup [ - swap f 0 - windows.winsock:WSAAccept - dup windows.winsock:INVALID_SOCKET = - [ windows.winsock:winsock-error ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - dup handle>duplex-stream ; + dup check-server-port + [ + dup port-handle win32-file-handle + swap server-port-addr sockaddr-type heap-size + dup [ + swap f 0 + windows.winsock:WSAAccept + dup windows.winsock:INVALID_SOCKET = + [ windows.winsock:winsock-error ] when + ] keep + ] keep server-port-addr parse-sockaddr swap + dup handle>duplex-stream + ] with-port-timeout ; M: windows-ce-io ( addrspec -- datagram ) [ diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 06edd8b3ee..4a304e5ac9 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -24,7 +24,6 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) swap buffer-consume ; : (flush-output) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-write WriteFile dupd overlapped-error? [ @@ -37,7 +36,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped ) ] if ; : flush-output ( port -- ) - [ (flush-output) ] with-destructors ; + [ [ (flush-output) ] with-port-timeout ] with-destructors ; M: port port-flush dup buffer-empty? [ dup flush-output ] unless drop ; @@ -52,17 +51,13 @@ M: port port-flush ] if ; : ((wait-to-read)) ( port -- ) - dup touch-port dup make-FileArgs tuck setup-read ReadFile dupd overlapped-error? [ >r FileArgs-lpOverlapped r> [ save-callback ] 2keep finish-read - ] [ - 2drop - ] if ; + ] [ 2drop ] if ; M: input-port (wait-to-read) ( port -- ) - [ ((wait-to-read)) ] with-destructors ; - + [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index f296e859f0..a7c065b878 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -46,8 +46,11 @@ M: windows-nt-io ( path recursive? -- monitor ) : read-changes ( monitor -- bytes ) [ - dup begin-reading-changes swap [ save-callback ] 2keep - get-overlapped-result + [ + dup begin-reading-changes + swap [ save-callback ] 2keep + get-overlapped-result + ] with-port-timeout ] with-destructors ; : parse-action-flag ( action mask symbol -- action ) diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 6c7db33ee3..b9ce5aad4c 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -129,15 +129,16 @@ TUPLE: AcceptEx-args port M: windows-nt-io accept ( server -- client ) [ - dup check-server-port - dup touch-port - \ AcceptEx-args construct-empty - [ init-accept ] keep - [ (accept) ] keep - [ accept-continuation ] keep - AcceptEx-args-port pending-error - dup duplex-stream-in pending-error - dup duplex-stream-out pending-error + [ + dup check-server-port + \ AcceptEx-args construct-empty + [ init-accept ] keep + [ (accept) ] keep + [ accept-continuation ] keep + AcceptEx-args-port pending-error + dup duplex-stream-in pending-error + dup duplex-stream-out pending-error + ] with-port-timeout ] with-destructors ; M: windows-nt-io ( addrspec -- server ) From 6530057512f2b7306fb8dc38d1e84e8f4ea35f29 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 20:11:46 -0600 Subject: [PATCH 038/317] Starting work on record1 strings --- core/alien/alien.factor | 15 ++---- core/bit-arrays/bit-arrays.factor | 4 +- core/bootstrap/image/image.factor | 1 + core/bootstrap/primitives.factor | 58 +++++++++++++----------- core/byte-arrays/byte-arrays.factor | 6 +-- core/compiler/constants/constants.factor | 2 +- core/float-arrays/float-arrays.factor | 4 +- core/strings/strings.factor | 14 ++++-- vm/debug.c | 2 +- vm/layouts.h | 2 + vm/types.c | 9 ++-- 11 files changed, 61 insertions(+), 56 deletions(-) diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 1c8163e2fa..317dac803e 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel math namespaces sequences system -kernel.private tuples ; +kernel.private tuples bit-arrays byte-arrays float-arrays ; IN: alien ! Some predicate classes used by the compiler for optimization @@ -9,16 +9,11 @@ IN: alien PREDICATE: alien simple-alien underlying-alien not ; -! These mixins are not intended to be extended by user code. -! They are not unions, because if they were we'd have a circular -! dependency between alien and {byte,bit,float}-arrays. -MIXIN: simple-c-ptr -INSTANCE: simple-alien simple-c-ptr -INSTANCE: f simple-c-ptr +UNION: simple-c-ptr +simple-alien POSTPONE: f byte-array bit-array float-array ; -MIXIN: c-ptr -INSTANCE: alien c-ptr -INSTANCE: f c-ptr +UNION: c-ptr +alien POSTPONE: f byte-array bit-array float-array ; DEFER: pinned-c-ptr? diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 4c68d94aad..ee485d399e 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math alien kernel kernel.private sequences +USING: math alien.accessors kernel kernel.private sequences sequences.private ; IN: bit-arrays @@ -52,5 +52,3 @@ M: bit-array resize resize-bit-array ; INSTANCE: bit-array sequence -INSTANCE: bit-array simple-c-ptr -INSTANCE: bit-array c-ptr diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f7e0d483f6..c3bf18cffc 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -259,6 +259,7 @@ M: wrapper ' string type-number object tag-number [ dup length emit-fixnum f ' emit + f ' emit pack-string emit-chars ] emit-object ; diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 4c5246e0eb..defbac6720 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -40,6 +40,7 @@ call ! classes will go { "alien" + "alien.accessors" "arrays" "bit-arrays" "bit-vectors" @@ -190,6 +191,11 @@ num-types get f builtins set "length" { "length" "sequences" } f + } { + { "object" "kernel" } + "aux" + { "string-aux" "strings.private" } + { "set-string-aux" "strings.private" } } } define-builtin @@ -556,32 +562,32 @@ builtins get num-tags get tail f union-class define-class { "" "byte-arrays" } { "" "bit-arrays" } { "" "alien" } - { "alien-signed-cell" "alien" } - { "set-alien-signed-cell" "alien" } - { "alien-unsigned-cell" "alien" } - { "set-alien-unsigned-cell" "alien" } - { "alien-signed-8" "alien" } - { "set-alien-signed-8" "alien" } - { "alien-unsigned-8" "alien" } - { "set-alien-unsigned-8" "alien" } - { "alien-signed-4" "alien" } - { "set-alien-signed-4" "alien" } - { "alien-unsigned-4" "alien" } - { "set-alien-unsigned-4" "alien" } - { "alien-signed-2" "alien" } - { "set-alien-signed-2" "alien" } - { "alien-unsigned-2" "alien" } - { "set-alien-unsigned-2" "alien" } - { "alien-signed-1" "alien" } - { "set-alien-signed-1" "alien" } - { "alien-unsigned-1" "alien" } - { "set-alien-unsigned-1" "alien" } - { "alien-float" "alien" } - { "set-alien-float" "alien" } - { "alien-double" "alien" } - { "set-alien-double" "alien" } - { "alien-cell" "alien" } - { "set-alien-cell" "alien" } + { "alien-signed-cell" "alien.accessors" } + { "set-alien-signed-cell" "alien.accessors" } + { "alien-unsigned-cell" "alien.accessors" } + { "set-alien-unsigned-cell" "alien.accessors" } + { "alien-signed-8" "alien.accessors" } + { "set-alien-signed-8" "alien.accessors" } + { "alien-unsigned-8" "alien.accessors" } + { "set-alien-unsigned-8" "alien.accessors" } + { "alien-signed-4" "alien.accessors" } + { "set-alien-signed-4" "alien.accessors" } + { "alien-unsigned-4" "alien.accessors" } + { "set-alien-unsigned-4" "alien.accessors" } + { "alien-signed-2" "alien.accessors" } + { "set-alien-signed-2" "alien.accessors" } + { "alien-unsigned-2" "alien.accessors" } + { "set-alien-unsigned-2" "alien.accessors" } + { "alien-signed-1" "alien.accessors" } + { "set-alien-signed-1" "alien.accessors" } + { "alien-unsigned-1" "alien.accessors" } + { "set-alien-unsigned-1" "alien.accessors" } + { "alien-float" "alien.accessors" } + { "set-alien-float" "alien.accessors" } + { "alien-double" "alien.accessors" } + { "set-alien-double" "alien.accessors" } + { "alien-cell" "alien.accessors" } + { "set-alien-cell" "alien.accessors" } { "alien>char-string" "alien" } { "string>char-alien" "alien" } { "alien>u16-string" "alien" } diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 401b151ad0..548c293e7c 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien sequences sequences.private -math ; +USING: kernel kernel.private alien.accessors sequences +sequences.private math ; IN: byte-arrays M: byte-array clone (clone) ; @@ -19,5 +19,3 @@ M: byte-array resize resize-byte-array ; INSTANCE: byte-array sequence -INSTANCE: byte-array simple-c-ptr -INSTANCE: byte-array c-ptr diff --git a/core/compiler/constants/constants.factor b/core/compiler/constants/constants.factor index 66fc8d5789..277a64225a 100755 --- a/core/compiler/constants/constants.factor +++ b/core/compiler/constants/constants.factor @@ -10,7 +10,7 @@ IN: compiler.constants ! These constants must match vm/layouts.h : header-offset object tag-number neg ; : float-offset 8 float tag-number - ; -: string-offset 3 bootstrap-cells object tag-number - ; +: string-offset 4 bootstrap-cells object tag-number - ; : profile-count-offset 7 bootstrap-cells object tag-number - ; : byte-array-offset 2 bootstrap-cells object tag-number - ; : alien-offset 3 bootstrap-cells object tag-number - ; diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 445edd550a..33302572de 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien sequences +USING: kernel kernel.private alien.accessors sequences sequences.private math math.private ; IN: float-arrays @@ -33,8 +33,6 @@ M: float-array resize resize-float-array ; INSTANCE: float-array sequence -INSTANCE: float-array simple-c-ptr -INSTANCE: float-array c-ptr : 1float-array ( x -- array ) 1 swap ; flushable diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 10f38f8298..33efed11e8 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -1,14 +1,20 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private sequences kernel.private -math sequences.private slots.private ; +math sequences.private slots.private byte-arrays +alien.accessors ; IN: strings dup rot set-string-aux ] ?if + { byte-array } declare ; inline -: set-string-hashcode 2 set-slot ; inline +: string-hashcode 3 slot ; inline + +: set-string-hashcode 3 set-slot ; inline : reset-string-hashcode f swap set-string-hashcode ; inline diff --git a/vm/debug.c b/vm/debug.c index 2692bdf59c..5b4320b5e9 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -4,7 +4,7 @@ void print_chars(F_STRING* str) { CELL i; for(i = 0; i < string_capacity(str); i++) - putchar(cget(SREF(str,i))); + putchar(string_nth(str,i)); } void print_word(F_WORD* word, CELL nesting) diff --git a/vm/layouts.h b/vm/layouts.h index 07e22cfed0..2b8957ee66 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -106,6 +106,8 @@ typedef struct { /* tagged num of chars */ CELL length; /* tagged */ + CELL aux; + /* tagged */ CELL hashcode; } F_STRING; diff --git a/vm/types.c b/vm/types.c index 27a5b55e2b..d5e8d76abb 100755 --- a/vm/types.c +++ b/vm/types.c @@ -429,10 +429,11 @@ F_STRING* allot_string_internal(CELL capacity) /* strings are null-terminated in memory, even though they also have a length field. The null termination allows us to add the sizeof(F_STRING) to a Factor string to get a C-style - UCS-2 string for C library calls. */ - cput(SREF(string,capacity),(u16)'\0'); + char* string for C library calls. */ + set_string_nth(string,capacity,0); string->length = tag_fixnum(capacity); string->hashcode = F; + string->aux = F; return string; } @@ -446,7 +447,7 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) CELL i; for(i = start; i < capacity; i++) - cput(SREF(string,i),fill); + set_string_nth(string,i,fill); } } @@ -499,7 +500,7 @@ DEFINE_PRIMITIVE(resize_string) CELL i; \ for(i = 0; i < length; i++) \ { \ - cput(SREF(s,i),(utype)*string); \ + set_string_nth(s,i,(utype)*string); \ string++; \ } \ return s; \ From 7666949e13397dda79dda6ddb6d68d976119ca98 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 31 Jan 2008 20:22:19 -0800 Subject: [PATCH 039/317] byte-length generic word for determining alien buffer sizes of byte-arrays and float-arrays --- core/alien/alien-docs.factor | 4 ++++ core/alien/alien.factor | 2 ++ core/byte-arrays/byte-arrays.factor | 3 +++ core/float-arrays/float-arrays-docs.factor | 2 +- core/float-arrays/float-arrays.factor | 3 ++- 5 files changed, 12 insertions(+), 2 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 8fee0e8c3e..8ae89ed5b1 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -34,6 +34,10 @@ HELP: { $description "Creates an alien object, wrapping a raw memory address." } { $notes "Alien objects are invalidated between image saves and loads." } ; +HELP: byte-length +{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } +{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; + HELP: c-ptr { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 1c8163e2fa..4b899a15e4 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -28,6 +28,8 @@ PREDICATE: alien pinned-alien UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: byte-length ( seq -- n ) flushable + M: f expired? drop t ; : ( address -- alien ) diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f82569c270..d65f243d71 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -15,6 +15,9 @@ M: byte-array new drop ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; +M: byte-array byte-length + length ; + INSTANCE: byte-array sequence INSTANCE: byte-array simple-c-ptr INSTANCE: byte-array c-ptr diff --git a/core/float-arrays/float-arrays-docs.factor b/core/float-arrays/float-arrays-docs.factor index 70bbfe296f..cb36aade6b 100644 --- a/core/float-arrays/float-arrays-docs.factor +++ b/core/float-arrays/float-arrays-docs.factor @@ -32,7 +32,7 @@ HELP: ( n initial -- float-array ) HELP: >float-array { $values { "seq" "a sequence" } { "float-array" float-array } } -{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." } +{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." } { $errors "Throws an error if the sequence contains elements other than real numbers." } ; HELP: 1float-array diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index ba0b2bb61d..42a2db7cd8 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien sequences +USING: kernel kernel.private alien alien.c-types sequences sequences.private math math.private ; IN: float-arrays @@ -12,6 +12,7 @@ PRIVATE> M: float-array clone (clone) ; M: float-array length array-capacity ; +M: float-array byte-length array-capacity "float" heap-size * ; M: float-array nth-unsafe float-array@ alien-double ; From f3b9e889ff6a41ec68937ab294f1b94b12012270 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 31 Jan 2008 20:24:08 -0800 Subject: [PATCH 040/317] Start work on making bunny demos use vertex buffers to draw --- extra/bunny/bunny.factor | 13 ++++++- extra/cel-shading/cel-shading.factor | 54 ++++++++++++++++++++-------- extra/line-art/line-art.factor | 5 ++- extra/opengl/opengl-docs.factor | 6 ++-- extra/opengl/opengl.factor | 28 +++++++++++++-- 5 files changed, 83 insertions(+), 23 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 3042b87ad6..73a3efc742 100644 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu shuffle http.client vectors timers namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting -combinators tools.time system combinators.lib ; +combinators tools.time system combinators.lib combinators.cleave +float-arrays ; IN: bunny : numbers ( str -- seq ) @@ -45,6 +46,16 @@ IN: bunny parse-model [ normals ] 2keep 3array ] time ; +: make-vertex-buffers ( model -- array element-array ) + [ + [ first concat ] [ second concat ] bi + append >float-array + GL_ARRAY_BUFFER swap GL_STATIC_DRAW + ] [ + third concat >c-uint-array + GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW + ] bi ; + : model-path "bun_zipper.ply" ; : model-url "http://factorcode.org/bun_zipper.ply" ; diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor index 64d23275e9..992fd9655d 100644 --- a/extra/cel-shading/cel-shading.factor +++ b/extra/cel-shading/cel-shading.factor @@ -4,12 +4,14 @@ USING: arrays bunny combinators.lib io io.files kernel sequences ui ui.gadgets ui.render ; IN: cel-shading -TUPLE: cel-shading-gadget model program ; +TUPLE: cel-shading-gadget model program vertices elements ; : ( -- cel-shading-gadget ) 0.0 0.0 0.375 - maybe-download read-model - { set-delegate set-cel-shading-gadget-model } cel-shading-gadget construct ; + maybe-download read-model { + set-delegate + set-cel-shading-gadget-model + } cel-shading-gadget construct ; STRING: cel-shading-vertex-shader-source varying vec3 position, normal; @@ -53,34 +55,58 @@ main() ; -: cel-shading-program ( -- program ) +: make-cel-shading-program ( -- program ) cel-shading-vertex-shader-source cel-shading-fragment-shader-source ; M: cel-shading-gadget graft* ( gadget -- ) - [ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions + "2.0" { + "GL_ARB_shader_objects" + "GL_ARB_vertex_buffer_object" + } require-gl-version-or-extensions 0.0 0.0 0.0 1.0 glClearColor GL_CULL_FACE glEnable GL_DEPTH_TEST glEnable - cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ; + dup cel-shading-gadget-model make-vertex-buffers + make-cel-shading-program roll { + set-cel-shading-gadget-vertices + set-cel-shading-gadget-elements + set-cel-shading-gadget-program + } set-slots ; M: cel-shading-gadget ungraft* ( gadget -- ) - cel-shading-gadget-program [ delete-gl-program ] when* ; + { + [ cel-shading-gadget-program [ delete-gl-program ] when* ] + [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ] + [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ] + } call-with ; : cel-shading-draw-setup ( gadget -- gadget ) [ demo-gadget-set-matrices ] keep - [ cel-shading-gadget-program - { [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] - [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] - [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] - [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] } call-with - ] keep ; + [ cel-shading-gadget-program { + [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] + [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] + [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] + [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] + } call-with ] keep ; M: cel-shading-gadget draw-gadget* ( gadget -- ) dup cel-shading-gadget-program [ cel-shading-draw-setup 0.0 -0.12 0.0 glTranslatef - cel-shading-gadget-model first3 draw-bunny + dup { + cel-shading-gadget-vertices + cel-shading-gadget-elements + } get-slots [ + GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [ + GL_FLOAT 0 0 buffer-offset glNormalPointer + cel-shading-gadget-model dup + first length 3 * 4 * buffer-offset + 3 GL_FLOAT 0 roll glVertexPointer + third length 3 * + GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + ] all-enabled-client-state + ] with-array-element-buffers ] with-gl-program ; : cel-shading-window ( -- ) diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor index 9856921a51..d78ea8a4ee 100644 --- a/extra/line-art/line-art.factor +++ b/extra/line-art/line-art.factor @@ -187,7 +187,7 @@ main() ] if ; M: line-art-gadget graft* ( gadget -- ) - [ "2.0" { "GL_ARB_draw_buffers" + "2.0" { "GL_ARB_draw_buffers" "GL_ARB_shader_objects" "GL_ARB_multitexture" "GL_ARB_texture_float" } @@ -196,8 +196,7 @@ M: line-art-gadget graft* ( gadget -- ) GL_CULL_FACE glEnable GL_DEPTH_TEST glEnable (line-art-step1-program) over set-line-art-gadget-step1-program - (line-art-step2-program) swap set-line-art-gadget-step2-program - ] [ ] [ :c ] cleanup ; + (line-art-step2-program) swap set-line-art-gadget-step2-program ; M: line-art-gadget ungraft* ( gadget -- ) dup line-art-gadget-framebuffer [ diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index cc8221baa1..63875e91a8 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -65,7 +65,7 @@ HELP: gen-renderbuffer { $values { "id" integer } } { $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; -HELP: gen-buffer +HELP: gen-gl-buffer { $values { "id" integer } } { $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ; @@ -81,14 +81,14 @@ HELP: delete-renderbuffer { $values { "id" integer } } { $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; -HELP: delete-buffer +HELP: delete-gl-buffer { $values { "id" integer } } { $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ; { gen-texture delete-texture } related-words { gen-framebuffer delete-framebuffer } related-words { gen-renderbuffer delete-renderbuffer } related-words -{ gen-buffer delete-buffer } related-words +{ gen-gl-buffer delete-gl-buffer } related-words HELP: framebuffer-incomplete? { $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 2c1d4de75c..a6aecf1b77 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -30,6 +30,13 @@ IN: opengl : do-enabled ( what quot -- ) over glEnable dip glDisable ; inline +: do-enabled-client-state ( what quot -- ) + over glEnableClientState dip glDisableClientState ; inline + +: all-enabled ( seq quot -- ) + over [ glEnable ] each dip [ glDisable ] each ; inline +: all-enabled-client-state ( seq quot -- ) + over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline : do-matrix ( mode quot -- ) swap [ glMatrixMode glPushMatrix call ] keep @@ -103,7 +110,7 @@ IN: opengl [ glGenFramebuffersEXT ] (gen-gl-object) ; : gen-renderbuffer ( -- id ) [ glGenRenderbuffersEXT ] (gen-gl-object) ; -: gen-buffer ( -- id ) +: gen-gl-buffer ( -- id ) [ glGenBuffers ] (gen-gl-object) ; : (delete-gl-object) ( id quot -- ) @@ -114,9 +121,26 @@ IN: opengl [ glDeleteFramebuffersEXT ] (delete-gl-object) ; : delete-renderbuffer ( id -- ) [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; -: delete-buffer ( id -- ) +: delete-gl-buffer ( id -- ) [ glDeleteBuffers ] (delete-gl-object) ; +: with-gl-buffer ( binding id quot -- ) + -rot dupd glBindBuffer + [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline + +: with-array-element-buffers ( array-buffer element-buffer quot -- ) + -rot GL_ELEMENT_ARRAY_BUFFER swap [ + swap GL_ARRAY_BUFFER -rot with-gl-buffer + ] with-gl-buffer ; inline + +: ( target data hint -- id ) + pick gen-gl-buffer [ [ + >r dup byte-length swap r> glBufferData + ] with-gl-buffer ] keep ; + +: buffer-offset ( int -- alien ) + ; inline + : framebuffer-incomplete? ( -- status/f ) GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; From 9d339e467748b5012366ee5920b505be1bd29315 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 22:41:06 -0600 Subject: [PATCH 041/317] concurrency-docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index e1377f5265..f481647e1e 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -150,7 +150,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" -"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed.

A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" +"A future is a placeholder for the result of a computation that is being calculated in a process. When the process has completed the computation the future can be queried to find out the result. If the computation has not completed when the future is queried them the process will block until the result is completed. A future is created using " { $link future } ".\n\nThe quotation will be run in a spawned process, and a future object is immediately returned. This future object can be resolved using " { $link ?future } ".\n\nFutures are useful for starting calculations that take a long time to run but aren't needed until later in the process. When the process needs the value it can use '?future' to get the result or block until the result is available. For example:" { $code "[ 30 fib ] future\n...do stuff...\n?future" } ; ARTICLE: { "concurrency" "promises" } "Promises" From ee533db516ad79b85706f587847f561a7ae14662 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 22:43:26 -0600 Subject: [PATCH 042/317] concurrency-docs fix 2 --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f481647e1e..7e76ff242a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -127,7 +127,7 @@ ARTICLE: { "concurrency" "processes" } "Processes" { $code ": odd? ( n -- ? ) 2 mod 1 = ;\n1 self send 2 self send 3 self send\n\nreceive .\n => 1\n\n[ odd? ] receive-if .\n => 3\n\nreceive .\n => 2" } ; ARTICLE: { "concurrency" "self" } "Self" -"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current processes 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" +"A process can get access to its own process object using " { $link self } " so it can pass it to other processes. This allows the other processes to send messages back. A simple example of using this gets the current process' 'self' and spawns a process which sends a message to it. We then receive the message from the original process:" { $code "self [ \"Hello!\" swap send ] spawn 2drop receive .\n => \"Hello!\"" } ; ARTICLE: { "concurrency" "servers" } "Servers" From 2ef76798b07e595ac05d281c6592575c0570068d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:00:08 -0600 Subject: [PATCH 043/317] record1 strings --- core/alien/alien-docs.factor | 3 +- core/alien/alien-tests.factor | 6 +- core/alien/c-types/c-types.factor | 2 +- core/ascii/ascii-docs.factor | 51 ++++++++++++ core/ascii/ascii.factor | 27 +++++++ core/ascii/authors.txt | 1 + core/ascii/summary.txt | 1 + core/ascii/tags.txt | 1 + core/bootstrap/image/image.factor | 11 +-- core/bootstrap/primitives.factor | 4 +- core/bootstrap/stage2.factor | 2 +- core/compiler/test/intrinsics.factor | 26 +++--- core/compiler/test/redefine.factor | 2 +- core/compiler/test/templates.factor | 4 +- core/cpu/ppc/intrinsics/intrinsics.factor | 24 ------ core/cpu/x86/intrinsics/intrinsics.factor | 37 ++------- core/cpu/x86/sse2/sse2.factor | 10 +-- core/growable/growable-docs.factor | 4 +- core/inference/known-words/known-words.factor | 29 +++---- core/math/parser/parser.factor | 34 ++++++-- core/optimizer/math/math.factor | 10 +-- core/parser/parser.factor | 3 +- core/prettyprint/backend/backend.factor | 2 +- core/sbufs/sbufs.factor | 2 +- core/sbufs/tags.txt | 1 + core/strings/strings-docs.factor | 79 ++++--------------- core/strings/strings-tests.factor | 26 +++++- core/strings/strings.factor | 39 +-------- core/strings/tags.txt | 1 + core/syntax/tags.txt | 0 extra/io/buffers/buffers.factor | 4 +- extra/io/mmap/mmap.factor | 4 +- extra/io/windows/nt/sockets/sockets.factor | 9 ++- extra/ui/freetype/freetype.factor | 4 +- 34 files changed, 227 insertions(+), 236 deletions(-) mode change 100644 => 100755 core/alien/alien-tests.factor create mode 100755 core/ascii/ascii-docs.factor create mode 100755 core/ascii/ascii.factor create mode 100755 core/ascii/authors.txt create mode 100755 core/ascii/summary.txt create mode 100755 core/ascii/tags.txt mode change 100644 => 100755 core/cpu/x86/sse2/sse2.factor mode change 100644 => 100755 core/growable/growable-docs.factor mode change 100644 => 100755 core/math/parser/parser.factor mode change 100644 => 100755 core/parser/parser.factor mode change 100644 => 100755 core/strings/strings-tests.factor create mode 100755 core/syntax/tags.txt diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 8fee0e8c3e..19ee52b039 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -1,6 +1,7 @@ USING: byte-arrays arrays help.syntax help.markup alien.syntax compiler definitions math libc -debugger parser io io.backend system bit-arrays float-arrays ; +debugger parser io io.backend system bit-arrays float-arrays +alien.accessors ; IN: alien HELP: alien diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor old mode 100644 new mode 100755 index aedad25906..d5133753c1 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,7 +1,7 @@ IN: temporary -USING: alien byte-arrays -arrays kernel kernel.private namespaces tools.test sequences -libc math system prettyprint ; +USING: alien alien.accessors byte-arrays arrays kernel +kernel.private namespaces tools.test sequences libc math system +prettyprint ; [ t ] [ -1 alien-address 0 > ] unit-test diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 1ecfa37ee6..88df823e5b 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -3,7 +3,7 @@ USING: byte-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture -alien quotations system compiler.units ; +alien alien.accessors quotations system compiler.units ; IN: alien.c-types TUPLE: c-type diff --git a/core/ascii/ascii-docs.factor b/core/ascii/ascii-docs.factor new file mode 100755 index 0000000000..1f7a56bed9 --- /dev/null +++ b/core/ascii/ascii-docs.factor @@ -0,0 +1,51 @@ +USING: help.markup help.syntax ; +IN: ascii + +HELP: blank? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII whitespace character." } ; + +HELP: letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a lowercase alphabet ASCII character." } ; + +HELP: LETTER? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a uppercase alphabet ASCII character." } ; + +HELP: digit? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII decimal digit character." } ; + +HELP: Letter? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; + +HELP: alpha? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an alphanumeric ASCII character." } ; + +HELP: printable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for a printable ASCII character." } ; + +HELP: control? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for an ASCII control character." } ; + +HELP: quotable? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; + +ARTICLE: "ascii" "ASCII character classes" +"Traditional ASCII character classes:" +{ $subsection blank? } +{ $subsection letter? } +{ $subsection LETTER? } +{ $subsection digit? } +{ $subsection printable? } +{ $subsection control? } +{ $subsection quotable? } +"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode" } ")." ; + +ABOUT: "ascii" diff --git a/core/ascii/ascii.factor b/core/ascii/ascii.factor new file mode 100755 index 0000000000..eeb6b2d480 --- /dev/null +++ b/core/ascii/ascii.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2005, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: sequences math kernel ; +IN: ascii + +: blank? ( ch -- ? ) " \t\n\r" member? ; inline + +: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline + +: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline + +: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline + +: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline + +: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline + +: quotable? ( ch -- ? ) + dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline + +: Letter? ( ch -- ? ) + dup letter? [ drop t ] [ LETTER? ] if ; inline + +: alpha? ( ch -- ? ) + dup Letter? [ drop t ] [ digit? ] if ; inline + + diff --git a/core/ascii/authors.txt b/core/ascii/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/core/ascii/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/core/ascii/summary.txt b/core/ascii/summary.txt new file mode 100755 index 0000000000..ae2ea69b8b --- /dev/null +++ b/core/ascii/summary.txt @@ -0,0 +1 @@ +ASCII character classes diff --git a/core/ascii/tags.txt b/core/ascii/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/core/ascii/tags.txt @@ -0,0 +1 @@ +text diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index c3bf18cffc..e9ee569fd6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -17,8 +17,6 @@ IN: bootstrap.image : image-magic HEX: 0f0e0d0c ; inline : image-version 4 ; inline -: char bootstrap-cell 2/ ; inline - : data-base 1024 ; inline : userenv-size 40 ; inline @@ -244,16 +242,13 @@ M: wrapper ' [ emit ] emit-object ; ! Strings -: 16be> 0 [ swap 16 shift bitor ] reduce ; -: 16le> 16be> ; - : emit-chars ( seq -- ) - char - big-endian get [ [ 16be> ] map ] [ [ 16le> ] map ] if + bootstrap-cell + big-endian get [ [ be> ] map ] [ [ le> ] map ] if emit-seq ; : pack-string ( string -- newstr ) - dup length 1+ char align 0 pad-right ; + dup length 1+ bootstrap-cell align 0 pad-right ; : emit-string ( string -- ptr ) string type-number object tag-number [ diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index defbac6720..fef93e163f 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -596,8 +596,8 @@ builtins get num-tags get tail f union-class define-class { "alien-address" "alien" } { "slot" "slots.private" } { "set-slot" "slots.private" } - { "char-slot" "strings.private" } - { "set-char-slot" "strings.private" } + { "string-nth" "strings.private" } + { "set-string-nth" "strings.private" } { "resize-array" "arrays" } { "resize-string" "strings" } { "" "arrays" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 8fc3435ffa..5a5a8d1c67 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -12,7 +12,7 @@ IN: bootstrap.stage2 ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ >lower ".exe" ?tail drop ] when + vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" set-global "math tools help compiler ui ui.tools io" "include" set-global diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 075961047f..1d0ad141c2 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -1,10 +1,10 @@ IN: temporary -USING: arrays compiler kernel kernel.private math -math.constants math.private sequences strings tools.test words -continuations sequences.private hashtables.private byte-arrays -strings.private system random layouts vectors.private -sbufs.private strings.private slots.private alien alien.c-types -alien.syntax namespaces libc combinators.private ; +USING: arrays compiler kernel kernel.private math math.constants +math.private sequences strings tools.test words continuations +sequences.private hashtables.private byte-arrays strings.private +system random layouts vectors.private sbufs.private +strings.private slots.private alien alien.accessors +alien.c-types alien.syntax namespaces libc combinators.private ; ! Make sure that intrinsic ops compile to correct code. [ ] [ 1 [ drop ] compile-call ] unit-test @@ -36,13 +36,13 @@ alien.syntax namespaces libc combinators.private ; ! Write barrier hits on the wrong value were causing segfaults [ -3 ] [ -3 1 2 [ 2array [ 3 set-slot ] keep ] compile-call second ] unit-test -[ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test -[ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test -[ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test - -[ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -[ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test -[ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ CHAR: b ] [ 1 "abc" [ char-slot ] compile-call ] unit-test +! [ CHAR: b ] [ 1 [ "abc" char-slot ] compile-call ] unit-test +! [ CHAR: b ] [ [ 1 "abc" char-slot ] compile-call ] unit-test +! +! [ "axc" ] [ CHAR: x 1 "abc" [ [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ "axc" ] [ CHAR: x 1 [ "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test +! [ "axc" ] [ CHAR: x [ 1 "abc" [ set-char-slot ] keep { string } declare dup rehash-string ] compile-call ] unit-test [ ] [ [ 0 getenv ] compile-call drop ] unit-test [ ] [ 1 getenv [ 1 setenv ] compile-call ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index c1561f38d4..01dd27f8be 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -249,4 +249,4 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test -[ 1 ] [ defer-redefine-test-2 ] unit-test +[ 2 1 ] [ defer-redefine-test-2 ] unit-test diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates.factor index 78f57efb43..08e1c98729 100755 --- a/core/compiler/test/templates.factor +++ b/core/compiler/test/templates.factor @@ -2,8 +2,8 @@ USING: arrays compiler kernel kernel.private math hashtables.private math.private namespaces sequences sequences.private tools.test namespaces.private slots.private -combinators.private byte-arrays alien layouts words definitions -compiler.units ; +combinators.private byte-arrays alien alien.accessors layouts +words definitions compiler.units ; IN: temporary ! Oops! diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index c73cd149a4..693bcdb5e4 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -93,30 +93,6 @@ IN: cpu.ppc.intrinsics } } define-intrinsics -: (%char-slot) - "offset" operand "n" operand 2 SRAWI - "offset" operand dup "obj" operand ADD ; - -\ char-slot [ - (%char-slot) - "out" operand "offset" operand string-offset LHZ - "out" operand dup %tag-fixnum -] H{ - { +input+ { { f "n" } { f "obj" } } } - { +scratch+ { { f "out" } { f "offset" } } } - { +output+ { "out" } } -} define-intrinsic - -\ set-char-slot [ - (%char-slot) - "val" operand dup %untag-fixnum - "val" operand "offset" operand string-offset STH -] H{ - { +input+ { { f "val" } { f "n" } { f "obj" } } } - { +scratch+ { { f "offset" } } } - { +clobber+ { "val" } } -} define-intrinsic - : fixnum-register-op ( op -- pair ) [ "out" operand "y" operand "x" operand ] swap add H{ { +input+ { { f "x" } { f "y" } } } diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index 1fc649e128..99a89eab05 100755 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -1,12 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.allot -cpu.x86.architecture cpu.architecture kernel kernel.private math -math.private namespaces quotations sequences +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.allot cpu.x86.architecture cpu.architecture kernel +kernel.private math math.private namespaces quotations sequences words generic byte-arrays hashtables hashtables.private generator generator.registers generator.fixup sequences.private sbufs sbufs.private vectors vectors.private layouts system -tuples.private strings.private slots.private compiler.constants ; +tuples.private strings.private slots.private compiler.constants +; IN: cpu.x86.intrinsics ! Type checks @@ -153,34 +154,6 @@ IN: cpu.x86.intrinsics : small-reg-16 BX ; inline : small-reg-32 EBX ; inline -\ char-slot [ - small-reg PUSH - "n" operand 2 SHR - small-reg dup XOR - "obj" operand "n" operand ADD - small-reg-16 "obj" operand string-offset [+] MOV - small-reg %tag-fixnum - "obj" operand small-reg MOV - small-reg POP -] H{ - { +input+ { { f "n" } { f "obj" } } } - { +output+ { "obj" } } - { +clobber+ { "obj" "n" } } -} define-intrinsic - -\ set-char-slot [ - small-reg PUSH - "val" operand %untag-fixnum - "slot" operand 2 SHR - "obj" operand "slot" operand ADD - small-reg "val" operand MOV - "obj" operand string-offset [+] small-reg-16 MOV - small-reg POP -] H{ - { +input+ { { f "val" } { f "slot" } { f "obj" } } } - { +clobber+ { "val" "slot" "obj" } } -} define-intrinsic - ! Fixnums : fixnum-op ( op hash -- pair ) >r [ "x" operand "y" operand ] swap add r> 2array ; diff --git a/core/cpu/x86/sse2/sse2.factor b/core/cpu/x86/sse2/sse2.factor old mode 100644 new mode 100755 index cb8c87ed8d..98e42fa7fe --- a/core/cpu/x86/sse2/sse2.factor +++ b/core/cpu/x86/sse2/sse2.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays cpu.x86.assembler cpu.x86.architecture -cpu.x86.intrinsics generic kernel kernel.private math -math.private memory namespaces sequences words generator -generator.registers cpu.architecture math.floats.private layouts -quotations ; +USING: alien alien.accessors arrays cpu.x86.assembler +cpu.x86.architecture cpu.x86.intrinsics generic kernel +kernel.private math math.private memory namespaces sequences +words generator generator.registers cpu.architecture +math.floats.private layouts quotations ; IN: cpu.x86.sse2 : define-float-op ( word op -- ) diff --git a/core/growable/growable-docs.factor b/core/growable/growable-docs.factor old mode 100644 new mode 100755 index 0311397a43..02f6292001 --- a/core/growable/growable-docs.factor +++ b/core/growable/growable-docs.factor @@ -21,7 +21,7 @@ HELP: set-fill { $values { "n" "a new fill pointer" } { "seq" "a resizable sequence" } } { $contract "Sets the fill pointer (number of occupied elements in the underlying storage) of a resizable sequence." } { $side-effects "seq" } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; +{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Changing the fill pointer to a negative value, or a value higher than the underlying sequence length can lead to memory corruption. User code should use " { $link set-length } " instead." } ; HELP: underlying { $values { "seq" "a resizable sequence" } { "underlying" "the underlying sequence" } } @@ -30,7 +30,7 @@ HELP: underlying HELP: set-underlying { $values { "underlying" "a sequence" } { "seq" "a resizable sequence" } } { $contract "Modifies the underlying storage of a resizable sequence." } -{ $warning "This word is in the " { $vocab-link "sequences.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; +{ $warning "This word is in the " { $vocab-link "growable.private" } " vocabulary because it is not safe. Setting an underlying sequence shorter than the fill pointer can lead to memory corruption." } ; HELP: capacity { $values { "seq" "a vector or string buffer" } { "n" "the capacity of the sequence" } } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 9a826d8e9b..6be3899acd 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -1,15 +1,16 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays bit-arrays byte-arrays classes -combinators.private continuations.private effects float-arrays -generic hashtables hashtables.private inference.state -inference.backend inference.dataflow io io.backend io.files -io.files.private io.streams.c kernel kernel.private math -math.private memory namespaces namespaces.private parser -prettyprint quotations quotations.private sbufs sbufs.private -sequences sequences.private slots.private strings -strings.private system threads.private tuples tuples.private -vectors vectors.private words words.private assocs inspector ; +USING: alien alien.accessors arrays bit-arrays byte-arrays +classes combinators.private continuations.private effects +float-arrays generic hashtables hashtables.private +inference.state inference.backend inference.dataflow io +io.backend io.files io.files.private io.streams.c kernel +kernel.private math math.private memory namespaces +namespaces.private parser prettyprint quotations +quotations.private sbufs sbufs.private sequences +sequences.private slots.private strings strings.private system +threads.private tuples tuples.private vectors vectors.private +words words.private assocs inspector ; IN: inference.known-words ! Shuffle words @@ -480,10 +481,10 @@ t over set-effect-terminated? \ set-slot { object object fixnum } { } "inferred-effect" set-word-prop -\ char-slot { fixnum object } { fixnum } "inferred-effect" set-word-prop -\ char-slot make-flushable +\ string-nth { fixnum string } { fixnum } "inferred-effect" set-word-prop +\ string-nth make-flushable -\ set-char-slot { fixnum fixnum object } { } "inferred-effect" set-word-prop +\ set-string-nth { fixnum fixnum string } { } "inferred-effect" set-word-prop \ resize-array { integer array } { array } "inferred-effect" set-word-prop \ resize-array make-flushable diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor old mode 100644 new mode 100755 index 28cecc033f..7f0404812d --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private namespaces sequences strings arrays -combinators splitting math ; +combinators splitting math assocs ; IN: math.parser DEFER: base> @@ -11,12 +11,30 @@ DEFER: base> 2dup and [ / ] [ 2drop f ] if ; : digit> ( ch -- n ) - { - { [ dup digit? ] [ CHAR: 0 - ] } - { [ dup letter? ] [ CHAR: a - 10 + ] } - { [ dup LETTER? ] [ CHAR: A - 10 + ] } - { [ t ] [ drop f ] } - } cond ; + H{ + { CHAR: 0 0 } + { CHAR: 1 1 } + { CHAR: 2 2 } + { CHAR: 3 3 } + { CHAR: 4 4 } + { CHAR: 5 5 } + { CHAR: 6 6 } + { CHAR: 7 7 } + { CHAR: 8 8 } + { CHAR: 9 9 } + { CHAR: A 10 } + { CHAR: B 11 } + { CHAR: C 12 } + { CHAR: D 13 } + { CHAR: E 14 } + { CHAR: F 15 } + { CHAR: a 10 } + { CHAR: b 11 } + { CHAR: c 12 } + { CHAR: d 13 } + { CHAR: e 14 } + { CHAR: f 15 } + } at ; : digits>integer ( radix seq -- n ) 0 rot [ swapd * + ] curry reduce ; diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index ec3c9c15da..e048e29f48 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: optimizer.math -USING: alien arrays generic hashtables kernel assocs math -math.private kernel.private sequences words parser +USING: alien alien.accessors arrays generic hashtables kernel +assocs math math.private kernel.private sequences words parser inference.class inference.dataflow vectors strings sbufs io namespaces assocs quotations math.intervals sequences.private -combinators splitting layouts math.parser classes -generic.math optimizer.pattern-match optimizer.backend -optimizer.def-use generic.standard system ; +combinators splitting layouts math.parser classes generic.math +optimizer.pattern-match optimizer.backend optimizer.def-use +generic.standard system ; { + bignum+ float+ fixnum+fast } { { { number 0 } [ drop ] } diff --git a/core/parser/parser.factor b/core/parser/parser.factor old mode 100644 new mode 100755 index 31a3ceac03..1a61573bd4 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -5,7 +5,8 @@ namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string io.streams.lines vocabs -source-files classes hashtables compiler.errors compiler.units ; +source-files classes hashtables compiler.errors compiler.units +ascii ; IN: parser TUPLE: lexer text line column ; diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index 86ac6cd926..f88ab4ca2a 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects -tuples classes float-arrays float-vectors ; +tuples classes float-arrays float-vectors ascii ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index bcc7536e6f..9de57c0801 100755 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -14,7 +14,7 @@ PRIVATE> : ( n -- sbuf ) 0 0 string>sbuf ; inline M: sbuf set-nth-unsafe - underlying >r >r >fixnum r> >fixnum r> set-char-slot ; + underlying >r >r >fixnum r> >fixnum r> set-string-nth ; M: sbuf new drop [ 0 ] keep >fixnum string>sbuf ; diff --git a/core/sbufs/tags.txt b/core/sbufs/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/sbufs/tags.txt +++ b/core/sbufs/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d42e8cc601..e09c6da0eb 100755 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -4,7 +4,11 @@ sbufs math ; IN: strings ARTICLE: "strings" "Strings" -"A string is a fixed-size mutable sequence of characters. The literal syntax is covered in " { $link "syntax-strings" } "." +"A string is a fixed-size mutable sequence of Unicode 5.0 code points." +$nl +"Characters are not a first-class type; they are simply represented as integers between 0 and 16777216 (2^24). Only characters up to 2097152 (2^21) have a defined meaning in Unicode." +$nl +"String literal syntax is covered in " { $link "syntax-strings" } "." $nl "String words are found in the " { $vocab-link "strings" } " vocabulary." $nl @@ -16,28 +20,25 @@ $nl { $subsection } "Creating a string from a single character:" { $subsection 1string } -"Characters are not a first-class type; they are simply represented as integers between 0 and 65535. A few words operate on characters:" -{ $subsection blank? } -{ $subsection letter? } -{ $subsection LETTER? } -{ $subsection digit? } -{ $subsection printable? } -{ $subsection control? } -{ $subsection quotable? } -{ $subsection ch>lower } -{ $subsection ch>upper } ; +"Since strings are sequences, basic string manipulation can be performed using sequence operations (" { $link "sequences" } "). More advanced functionality can be found in other vocabularies, including but not limited to:" +{ $list + { { $vocab-link "ascii" } " - traditional ASCII character classes" } + { { $vocab-link "unicode" } " - Unicode 5.0-aware character classes, case conversion, word breaks, ..." } + { { $vocab-link "regexp" } " - regular expressions" } + { { $vocab-link "peg" } " - parser expression grammars" } +} ; ABOUT: "strings" HELP: string { $description "The class of fixed-length character strings. See " { $link "syntax-strings" } " for syntax and " { $link "strings" } " for general information." } ; -HELP: char-slot ( n string -- ch ) +HELP: string-nth ( n string -- ch ) { $values { "n" fixnum } { "string" string } { "ch" "the character at the " { $snippet "n" } "th index" } } { $description "Unsafe string accessor, used to define " { $link nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link nth } " instead." } ; -HELP: set-char-slot ( ch n string -- ) +HELP: set-string-nth ( ch n string -- ) { $values { "ch" "a character" } { "n" fixnum } { "string" string } } { $description "Unsafe string mutator, used to define " { $link set-nth } " on strings." } { $warning "This word is in the " { $vocab-link "strings.private" } " vocabulary because it does not perform type or bounds checking. User code should call " { $link set-nth } " instead." } ; @@ -46,58 +47,6 @@ HELP: ( n ch -- string ) { $values { "n" "a positive integer specifying string length" } { "ch" "an initial character" } { "string" string } } { $description "Creates a new string with the given length and all characters initially set to " { $snippet "ch" } "." } ; -HELP: blank? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII whitespace character." } ; - -HELP: letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a lowercase alphabet ASCII character." } ; - -HELP: LETTER? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a uppercase alphabet ASCII character." } ; - -HELP: digit? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII decimal digit character." } ; - -HELP: Letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII alphabet character, both upper and lower case." } ; - -HELP: alpha? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an alphanumeric ASCII character." } ; - -HELP: printable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for a printable ASCII character." } ; - -HELP: control? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for an ASCII control character." } ; - -HELP: quotable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ; - -HELP: ch>lower -{ $values { "ch" "a character" } { "lower" "a character" } } -{ $description "Converts a character to lowercase." } ; - -HELP: ch>upper -{ $values { "ch" "a character" } { "upper" "a character" } } -{ $description "Converts a character to uppercase." } ; - -HELP: >lower -{ $values { "str" string } { "lower" string } } -{ $description "Converts a string to lowercase." } ; - -HELP: >upper -{ $values { "str" string } { "upper" string } } -{ $description "Converts a string to uppercase." } ; - HELP: 1string { $values { "ch" "a character"} { "str" string } } { $description "Outputs a string of one character." } ; diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor old mode 100644 new mode 100755 index 88f6f3e9ca..a3c49a08ba --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -1,5 +1,5 @@ USING: continuations kernel math namespaces strings sbufs -tools.test sequences vectors ; +tools.test sequences vectors arrays ; IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test @@ -66,3 +66,27 @@ unit-test ! Random tester found this [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test + +"hello world" "s" set + +[ ] [ HEX: 1234 1 "s" get set-nth ] unit-test +[ ] [ HEX: 4321 3 "s" get set-nth ] unit-test +[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test + +[ + { + CHAR: h + HEX: 1234 + CHAR: l + HEX: 4321 + CHAR: o + HEX: 654321 + CHAR: w + CHAR: o + CHAR: r + CHAR: l + CHAR: d + } +] [ + "s" get >array +] unit-test diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 33efed11e8..dc1d12cec9 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -7,11 +7,6 @@ IN: strings dup rot set-string-aux ] ?if - { byte-array } declare ; inline - : string-hashcode 3 slot ; inline : set-string-hashcode 3 set-slot ; inline @@ -35,43 +30,17 @@ M: string hashcode* nip dup string-hashcode [ ] [ dup rehash-string string-hashcode ] ?if ; -M: string nth-unsafe >r >fixnum r> char-slot ; +M: string nth-unsafe + >r >fixnum r> string-nth ; -M: string set-nth-unsafe +M: string set-nth-unsafe dup reset-string-hashcode - >r >fixnum >r >fixnum r> r> set-char-slot ; + >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone (clone) ; M: string resize resize-string ; -! Characters -: blank? ( ch -- ? ) " \t\n\r" member? ; inline -: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline -: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline -: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline -: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline - -: quotable? ( ch -- ? ) - dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline - -: Letter? ( ch -- ? ) - dup letter? [ drop t ] [ LETTER? ] if ; inline - -: alpha? ( ch -- ? ) - dup Letter? [ drop t ] [ digit? ] if ; inline - -: ch>lower ( ch -- lower ) - dup LETTER? [ HEX: 20 + ] when ; inline - -: ch>upper ( ch -- upper ) - dup letter? [ HEX: 20 - ] when ; inline - -: >lower ( str -- lower ) [ ch>lower ] map ; - -: >upper ( str -- upper ) [ ch>upper ] map ; - : 1string ( ch -- str ) 1 swap ; : >string ( seq -- str ) "" clone-like ; diff --git a/core/strings/tags.txt b/core/strings/tags.txt index 42d711b32b..de2741b09f 100644 --- a/core/strings/tags.txt +++ b/core/strings/tags.txt @@ -1 +1,2 @@ +text collections diff --git a/core/syntax/tags.txt b/core/syntax/tags.txt new file mode 100755 index 0000000000..e69de29bb2 diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index 54198a7dcc..f26fe50d79 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -2,8 +2,8 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers -USING: alien alien.c-types alien.syntax kernel kernel.private -libc math sequences strings hints ; +USING: alien alien.accessors alien.c-types alien.syntax kernel +kernel.private libc math sequences strings hints ; TUPLE: buffer size ptr fill pos ; diff --git a/extra/io/mmap/mmap.factor b/extra/io/mmap/mmap.factor index af020e5a26..59246115cf 100755 --- a/extra/io/mmap/mmap.factor +++ b/extra/io/mmap/mmap.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations io.backend kernel quotations sequences -system alien sequences.private ; +system alien alien.accessors sequences.private ; IN: io.mmap TUPLE: mapped-file length address handle closed? ; diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index b9ce5aad4c..77249df9f1 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -1,7 +1,8 @@ -USING: alien alien.c-types byte-arrays continuations destructors -io.nonblocking io io.sockets io.sockets.impl namespaces -io.streams.duplex io.windows io.windows.nt.backend -windows.winsock kernel libc math sequences threads tuples.lib ; +USING: alien alien.accessors alien.c-types byte-arrays +continuations destructors io.nonblocking io io.sockets +io.sockets.impl namespaces io.streams.duplex io.windows +io.windows.nt.backend windows.winsock kernel libc math sequences +threads tuples.lib ; IN: io.windows.nt.sockets : malloc-int ( object -- object ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 8fc320e34c..0d7522332f 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays io kernel libc math -math.vectors namespaces opengl opengl.gl prettyprint assocs +USING: alien alien.accessors alien.c-types arrays io kernel libc +math math.vectors namespaces opengl opengl.gl prettyprint assocs sequences io.files io.styles continuations freetype ui.gadgets.worlds ui.render ui.backend byte-arrays ; IN: ui.freetype From d9f7acae0f1f682fe295a483953b9b7b491aa19e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:03:10 -0600 Subject: [PATCH 044/317] VM changes for record1 strings --- vm/alien.c | 0 vm/code_heap.c | 2 +- vm/layouts.h | 3 --- vm/primitives.c | 4 ++-- vm/run.h | 18 ++++++++++++---- vm/types.c | 55 +++++++++++++++++++++++++++++++++++++------------ vm/types.h | 25 +++++++++------------- 7 files changed, 69 insertions(+), 38 deletions(-) mode change 100644 => 100755 vm/alien.c diff --git a/vm/alien.c b/vm/alien.c old mode 100644 new mode 100755 diff --git a/vm/code_heap.c b/vm/code_heap.c index 5771725f9d..f449445eb9 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -176,7 +176,7 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format) { F_FIXNUM value = to_fixnum(array_nth(array,i)); if(format == 1) - cput(here + i,value); + bput(here + i,value); else if(format == sizeof(unsigned int)) *(unsigned int *)(here + format * i) = value; else if(format == CELLS) diff --git a/vm/layouts.h b/vm/layouts.h index 2b8957ee66..ef6fb3d4ac 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -19,9 +19,6 @@ typedef signed long long s64; #define CELLS ((signed)sizeof(CELL)) -/* must always be 16 bits */ -#define CHARS ((signed)sizeof(u16)) - #define WORD_SIZE (CELLS*8) #define HALF_WORD_SIZE (CELLS*4) #define HALF_WORD_MASK (((unsigned long)1<aux == F) + return ch; + else + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + return (cget(BREF(aux,index * sizeof(u16))) << 8) | ch; + } +} + +void set_string_nth(F_STRING* string, CELL index, CELL value) +{ + bput(SREF(string,index),value & 0xff); + + if(string->aux == F) + { + if(value <= 0xff) + return; + else + { + string->aux = tag_object(allot_byte_array( + untag_fixnum_fast(string->length) + * sizeof(u16))); + } + } + + F_BYTE_ARRAY *aux = untag_object(string->aux); + cput(BREF(aux,index * sizeof(u16)),value >> 8); +} /* untagged */ F_STRING* allot_string_internal(CELL capacity) { - F_STRING* string = allot_object(STRING_TYPE, - sizeof(F_STRING) + (capacity + 1) * CHARS); + F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); /* strings are null-terminated in memory, even though they also have a length field. The null termination allows us to add the sizeof(F_STRING) to a Factor string to get a C-style char* string for C library calls. */ - set_string_nth(string,capacity,0); string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; + set_string_nth(string,capacity,0); return string; } void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) - memset((void*)SREF(string,start),'\0', - (capacity - start) * CHARS); + memset((void*)SREF(string,start),'\0',capacity - start); else { CELL i; @@ -466,7 +495,7 @@ DEFINE_PRIMITIVE(string) dpush(tag_object(allot_string(length,initial))); } -F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) +F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) { CELL to_copy = string_capacity(string); if(capacity < to_copy) @@ -476,7 +505,7 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, u16 fill) F_STRING *new_string = allot_string_internal(capacity); UNREGISTER_UNTAGGED(string); - memcpy(new_string + 1,string + 1,to_copy * CHARS); + memcpy(new_string + 1,string + 1,to_copy); fill_string(new_string,to_copy,capacity,fill); return new_string; @@ -530,7 +559,7 @@ bool check_string(F_STRING *s, CELL max) CELL i; for(i = 0; i < capacity; i++) { - u16 ch = string_nth(s,i); + CELL ch = string_nth(s,i); if(ch == '\0' || ch >= (1 << (max * 8))) return false; } @@ -572,7 +601,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) } \ type *to_##type##_string(F_STRING *s, bool check) \ { \ - if(sizeof(type) == sizeof(u16)) \ + if(sizeof(type) == sizeof(char)) \ { \ if(check && !check_string(s,sizeof(type))) \ general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ @@ -597,16 +626,16 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) STRING_TO_MEMORY(char); STRING_TO_MEMORY(u16); -DEFINE_PRIMITIVE(char_slot) +DEFINE_PRIMITIVE(string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); dpush(tag_fixnum(string_nth(string,index))); } -DEFINE_PRIMITIVE(set_char_slot) +DEFINE_PRIMITIVE(set_string_nth) { - F_STRING* string = untag_object(dpop()); + F_STRING *string = untag_object(dpop()); CELL index = untag_fixnum_fast(dpop()); CELL value = untag_fixnum_fast(dpop()); set_string_nth(string,index,value); diff --git a/vm/types.h b/vm/types.h index dca54e5951..6f4234af34 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + (size + 1) * CHARS; + return sizeof(F_STRING) + size + 1; } DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) @@ -83,7 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS) +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index) INLINE F_STRING* untag_string(CELL tagged) { @@ -91,16 +92,6 @@ INLINE F_STRING* untag_string(CELL tagged) return untag_object(tagged); } -INLINE CELL string_nth(F_STRING* string, CELL index) -{ - return cget(SREF(string,index)); -} - -INLINE void set_string_nth(F_STRING* string, CELL index, u16 value) -{ - cput(SREF(string,index),value); -} - DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) DEFINE_UNTAG(F_WORD,WORD_TYPE,word) @@ -141,7 +132,7 @@ DECLARE_PRIMITIVE(resize_float_array); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); DECLARE_PRIMITIVE(string); -F_STRING *reallot_string(F_STRING *string, CELL capacity, u16 fill); +F_STRING *reallot_string(F_STRING *string, CELL capacity, CELL fill); DECLARE_PRIMITIVE(resize_string); F_STRING *memory_to_char_string(const char *string, CELL length); @@ -166,8 +157,12 @@ u16* to_u16_string(F_STRING *s, bool check); DLLEXPORT u16 *unbox_u16_string(void); DECLARE_PRIMITIVE(string_to_u16_alien); -DECLARE_PRIMITIVE(char_slot); -DECLARE_PRIMITIVE(set_char_slot); +/* String getters and setters */ +CELL string_nth(F_STRING* string, CELL index); +void set_string_nth(F_STRING* string, CELL index, CELL value); + +DECLARE_PRIMITIVE(string_nth); +DECLARE_PRIMITIVE(set_string_nth); F_WORD *allot_word(CELL vocab, CELL name); DECLARE_PRIMITIVE(word); From 5dfe21d818c7e6406e511a6520c483b309bdec38 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:03:54 -0600 Subject: [PATCH 045/317] Better error reporting in planet --- extra/webapps/planet/planet.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) mode change 100644 => 100755 extra/webapps/planet/planet.factor diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor old mode 100644 new mode 100755 index da6cf6dfcc..3e09b57dd1 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -89,7 +89,7 @@ SYMBOL: last-update [ set-entry-title ] keep ; : ?fetch-feed ( triple -- feed/f ) - [ fetch-feed ] [ error. drop f ] recover ; + [ fetch-feed ] [ swap . error. f ] recover ; : fetch-blogroll ( blogroll -- entries ) dup 0 From af13a47485f6f23a727e8ac0a15c64e74e165231 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:04:11 -0600 Subject: [PATCH 046/317] Adding tags --- extra/multiline/tags.txt | 1 + extra/opengl/tags.txt | 3 +++ extra/parser-combinators/simple/tags.txt | 1 + extra/parser-combinators/tags.txt | 1 + extra/peg/tags.txt | 1 + extra/prolog/tags.txt | 2 +- extra/regexp/tags.txt | 2 ++ extra/space-invaders/resources/invaders.rom | Bin 0 -> 8192 bytes extra/tuple-syntax/tags.txt | 2 +- extra/unicode/breaks/tags.txt | 1 + extra/unicode/case/tags.txt | 1 + extra/unicode/categories/tags.txt | 1 + extra/unicode/data/tags.txt | 1 + extra/unicode/normalize/tags.txt | 1 + extra/unicode/syntax/tags.txt | 1 + extra/unicode/tags.txt | 1 + 16 files changed, 18 insertions(+), 2 deletions(-) create mode 100755 extra/multiline/tags.txt create mode 100755 extra/parser-combinators/simple/tags.txt create mode 100755 extra/parser-combinators/tags.txt create mode 100755 extra/regexp/tags.txt create mode 100644 extra/space-invaders/resources/invaders.rom create mode 100755 extra/unicode/breaks/tags.txt create mode 100755 extra/unicode/case/tags.txt create mode 100755 extra/unicode/categories/tags.txt create mode 100755 extra/unicode/data/tags.txt create mode 100755 extra/unicode/normalize/tags.txt create mode 100755 extra/unicode/syntax/tags.txt create mode 100755 extra/unicode/tags.txt diff --git a/extra/multiline/tags.txt b/extra/multiline/tags.txt new file mode 100755 index 0000000000..abf53a421b --- /dev/null +++ b/extra/multiline/tags.txt @@ -0,0 +1 @@ +reflection diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt index bb863cf9a0..5e477dbcb3 100644 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1 +1,4 @@ +opengl.glu +opengl.gl +opengl bindings diff --git a/extra/parser-combinators/simple/tags.txt b/extra/parser-combinators/simple/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/simple/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/parser-combinators/tags.txt b/extra/parser-combinators/tags.txt new file mode 100755 index 0000000000..9da56880c0 --- /dev/null +++ b/extra/parser-combinators/tags.txt @@ -0,0 +1 @@ +parsing diff --git a/extra/peg/tags.txt b/extra/peg/tags.txt index 9da56880c0..5af5dba748 100644 --- a/extra/peg/tags.txt +++ b/extra/peg/tags.txt @@ -1 +1,2 @@ +text parsing diff --git a/extra/prolog/tags.txt b/extra/prolog/tags.txt index 458345b533..eab42feac7 100644 --- a/extra/prolog/tags.txt +++ b/extra/prolog/tags.txt @@ -1 +1 @@ -prolog +languages diff --git a/extra/regexp/tags.txt b/extra/regexp/tags.txt new file mode 100755 index 0000000000..65bc471f6b --- /dev/null +++ b/extra/regexp/tags.txt @@ -0,0 +1,2 @@ +parsing +text diff --git a/extra/space-invaders/resources/invaders.rom b/extra/space-invaders/resources/invaders.rom new file mode 100644 index 0000000000000000000000000000000000000000..606ec01945d665881793becbde201b7292947a9e GIT binary patch literal 8192 zcmeG>|9=}*a&K3w)k?A@tu5KoN{Zh~w(Qu!m?gH8#THIV{3Xy3X!zD^FA3prC^1d~ z7u&&>orFLR3WN`EB+&B7^$uL1t;4mSkWY`MvbOel6&`V75`w~qVv5BgcP4)oT+xC zeuW2<%aM8(8~c+{G|H4KXEAB<4Jlt?^-CDriPZCWFwsd#1`~gc$bZ^2=zAWJok;tE zCCUJ$b|WH9#j1jp0Zb4>T3J$PMU%&er!VUWo+0?`A9H&Rsl(WLVkeR@CO5NW83R1Y z>{ zQ!0-;)ppz-8=OqmG2w75+?+Nn7R%ZqB%^@uZ1>=Q-N01ZG4CQ1o*@NcU9LgCv%0zw z500q_560#*-wB%;P!~UR8(4M~rO7v4%9$H6*v= z`*n~_=IcRTb7F+iC-o@9e=4)3+I#MBbGYa6u5kC`T{<5ZkzYnwQzUu0tX*Q{%pEx7aIo6?qS2<58pX;c1rGK|L5eFlVTq7 zX*aWGF44y}nm1Q=FgPjZmljIGiaBaM0NZE*$2XM4T`5W9_XAajUUNKcl zRR5)J_?qbQLsOA>L_YSZ9aR6|fn(R9(#zySAE~wuCOeAA7v9)la*;`WAAA%*JHF^l zDJJ4zNw@HDcxzSFW<)+`rkzolM<)tQJdTExc1#Z0h7=KZPna8&eVClGl7311)k$ADi0;mO0*^9{y z5^0ghQg;+71z7JkK1z0)8WcYU(r%*$kj5MWR#rS1T+kwK4(#p>c_~F=B`618TC+*4 z#Dte7$3cWKgGtVq3^r-w!muAIx!PnM7c-pkDN@6c+uf7l#o=&mE&SGo>jdc2kh`G^ zBpwwM;F87ReR669h=(VStBdgNPGun`&$-q0pjCy%x?vvE>NvR^Yp{SUSGf#}Wq#fQ zR;YX$FX}Tkr2c}dUK4s6S3Zjug`UOgV_=q8nqd~QiHA7mQ$v0dZwZGt>yxVDR}@^i z1o!=0;z_P5v;^y7EslOmR-4sktZc^Womkm|$p*99jR)mgocNwutnte=V1IDqN%bLW z@BwTvad8EXeog1qeRtkAY`9WiaB8bx*@m-RR%E#}`Q;|+MT(^E#El8T4BPP`T)7Qv zF@93K14qyNK?q=(69SldQj5*%-B+01k!7~pFR#uq0|ueHv99!E`C-i4K}c~90v<~b zB!Jl!O2CFM-3U594nb$AM4}mV0q+ZB=b;lvnz&wuv8%YcSM9 zonL#-J=eJ19csnk3t&bzF7JXsoOGJO@Pi4bnZ}N{c(9Nmq@3nDhBR2jC$lS+chiV{ ziU(hcg~N|4(A!|42*lTKd1La#x4h095EQ~7R7vt?i{VY?Sq9_$d3hg>9q3Bq2{Y_o zvfM(By5Xz5jjXlshW4=!9AO%RCpSAdd38{{B`6(ER#?J?`H7$Si{;*6=n1TW%)9*H3BdSyoQ+I9K8PlAVU2j9#KDmZ z0vwl(va7=3PTVDk$0X=E!=$-nzlGmFq`Z$|cwp|Rl@SVE!l7AA%6z2C2Qf}&m|o>P z4t;?`Q<&W8Bj*`%ks-$gB_k`D5cv=eR6|yb5Q#H{^U2*yLbGycHUt3=A{lvF08xNs z7?WcRnAMruDv&}J5b`!6$9-^c&3K8oh}eAOf`{y}f-we@=dHw1OlqyzI za$qT#6FSeZY161lr=DXSk6u<{;K&gD<3PY;?Wo&fl1`G0a2%|9LC{6CU@C$-!K%Kq zle{p&gF#g*HoC_vpQEv9p;bmam~R)Z3O$E)A{JF=Vmfj8s;VIB@*en_kZiR=I7wQ= zvBRg~+*usEC^KcHrHzTZpo8xP zh7}Hh3rn{M`EJ$%{^S(oQmBozA|G>!XsE z$!bi#gip(}a5Z5|;lj|DE-?bBUs**S`Ff3})JImGG{DLBB|XwWZx`v&2ge=N{#3OQ zOIsScY*6al_^$VLbwbAQLy#+MxDu+{h-Zm#v zA_ZLu%;&)-9GWmqn8{AxW%9O7JqL$MagBpZ{K_uQ1jzF?aVSWR*a%unV72gWNDmA+uwzKxKuMi1^jtJ{; z!sfgBT-Cr;4P4d0RSjI#z*PEi3jH{5V_T92o%NC$oYaiwp5=03MRG}1LE(0guOEyGZ-fV@&& zh>g=NCu%$@3)kyz9JqUh?;z;5>(6WFxuPqgG;?>W1#aQ8T@h?eIW0TH}F| z+gcl~*i3k$F2w}*RTGSAD?PFa*TyUFqq%>nJIX=l5EM!H-$5FQ9O&H-_IlnOA9dwv zf9ZiQ{eZ0TEHi)N>eN*mhW00}cBr>0yRo*y(+%~Vfq{V?joIp>o;T{6+3V5Oe7JwU z-++zmxe)qxcYT<}ZF=m44a4ry>DAd}EO&j6)2d#$`CuHhnX9iQZ!c1> z0nu8EpsJO2je%TcSh)r=BZ|gp3#vkOOy$=&+-Jm68;YtQ34M)YN)YSy`cN(l0;NK> zBwobQ5r37Ge5&Zgz9Q|}q9XvPL&OTmYG1Zurx(el3h{Nx;fA|wSsCxoCVTG`@quo* z4Aa|kw!WtqXkikI_@D*J9 zUPm#l0w+6)-$Ih!qa6j#NvsSbF^E5KkMPS;GBb@fG{ezRB>B~hkTs3Rwy zf$wO$izVeHOsA)7T4HIZ#c(BlRvcvxb`2>nVtGIC=Fihl&s8#j6E&9eL=wvM`WY5} z)7+T)GS~_h3=2JFH77m>2FlAA)_PfdHy{^5(nD4BHso3_V<<~#pybDB>BVA!noFE# zXkzNB5PuqQcpw9b+LTS0ITD1lBUSGuH+i)RFHB~R(Vo+giD;^K1UA7^_pm;qZo;<$ z^I_d)Wa`H{O}2KEZLP_6muZk@VT;47pnlz=Ch_6qKChaC6-5M zA?2(#;el8JLLUWRT8+hcuFeY;{Q(TQa}0wnhp~DGPBY2F-YiVSy);9LAn*$9kc}=L zku(D}k*ENM)4sBSn&dCAb3Cl`EGWD&>q4_@MFvo-pY$3TYYxzM;M30V=9e$jBW5 zc|oc8xujhXAg$J}^Fd+_Z>VO^r{fNb%+!i+lmG=3YGkHC`?*#AEhQptOILl>U{7I6s^HWQ{Jb18kB{=*N^xdg}{ymQ*{CCvw!kIJ!sph zt?>qB0j5o3aa{ISi@&owtUy;WpT~(#hlmOVM}7tH{}Ss%+Jq0m3J=V!kSR~j_@EZS zyKV(j^)x2V`M_vL-MvO_V#cS-TXD0L9{9(2y{=T128zUdn_%J1oQY)?SC@wZUQeOR zk)LO`TFe;j{)a z7=&E(gKYPb?j`6FLIda-He=3P7r-?x7=-5+Cgj>1sHkB$l*s_)HZI%E{W^e<37Urh zXHby)Y!2Va1I`Dzaf)Y99Dqw^Pz@>oVk+AF8vJFmh@mVIzArew(95m~A_39aO~4Rk zmyb+bx4Te~8aK|)Zful*mN~rdfZvrt2mF9g=^eD3iI8PHF!l<_LnqkbKO!?T9jY%o zl6?U~=8+Ou9(@AW!e2T3Ek$T)&-RDT&CHy8XnPM}@N@@{Y-(s|*mNY=oyF02nJwAg z-$Cg+`nNC1jyt?ZIvN`qJC1lAIr={m7CM|I@bqW;DS&bV#}t|@|LVNfbZr}Ff|Uy9 zpV~~{bC#FeZ*F=_Y<2E$h&8?&?cHDQmm*GwkY89(kuw=Gc~CyfMG6sP=PFnit|=7k z;QwtQ_m1Ug`3`re4ff4VZ@TuZ3Ax_9DYRzKO3#rSzhB19a;{kyp2Y*R1IR$7MghEA zjlE!rg`g7)!!Vqk;Y|!Ybz2N(rN`6IcXejbHaw6#&b%a^s?b3ed5cWFP>{?^-W zyKNP~1q<8SngKSow60zUux?Hd*R{2+Yyf<2Ik3)@~ literal 0 HcmV?d00001 diff --git a/extra/tuple-syntax/tags.txt b/extra/tuple-syntax/tags.txt index 71c0ff7282..abf53a421b 100644 --- a/extra/tuple-syntax/tags.txt +++ b/extra/tuple-syntax/tags.txt @@ -1 +1 @@ -syntax +reflection diff --git a/extra/unicode/breaks/tags.txt b/extra/unicode/breaks/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/breaks/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/case/tags.txt b/extra/unicode/case/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/case/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/categories/tags.txt b/extra/unicode/categories/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/categories/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/data/tags.txt b/extra/unicode/data/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/data/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/normalize/tags.txt b/extra/unicode/normalize/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/normalize/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/syntax/tags.txt b/extra/unicode/syntax/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/syntax/tags.txt @@ -0,0 +1 @@ +text diff --git a/extra/unicode/tags.txt b/extra/unicode/tags.txt new file mode 100755 index 0000000000..8e27be7d61 --- /dev/null +++ b/extra/unicode/tags.txt @@ -0,0 +1 @@ +text From d7c1349c8daf61875326bf3c572dcb1296e517a9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 31 Jan 2008 23:21:06 -0600 Subject: [PATCH 047/317] Fix a bunch of load-everything hiccups --- extra/cryptlib/streams/streams.factor | 2 +- extra/html/elements/elements.factor | 2 +- extra/html/html.factor | 4 ++-- extra/io/streams/null/null.factor | 2 +- extra/tar/tar.factor | 5 ++--- extra/webapps/pastebin/pastebin.factor | 4 ++-- 6 files changed, 9 insertions(+), 10 deletions(-) diff --git a/extra/cryptlib/streams/streams.factor b/extra/cryptlib/streams/streams.factor index 64b5ee9992..828476d2e2 100755 --- a/extra/cryptlib/streams/streams.factor +++ b/extra/cryptlib/streams/streams.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Matthew Willis ! See http://factorcode.org/license.txt for BSD license. -USING: cryptlib cryptlib.libcl kernel alien sequences +USING: cryptlib cryptlib.libcl kernel alien sequences continuations byte-arrays namespaces io.buffers math generic io strings io.streams.lines io.streams.plain io.streams.duplex combinators alien.c-types ; diff --git a/extra/html/elements/elements.factor b/extra/html/elements/elements.factor index ff3e7b1283..0f76c2e91e 100644 --- a/extra/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io kernel namespaces prettyprint quotations -sequences strings words xml.writer compiler.units effects ; +sequences strings words xml.writer xml.entities compiler.units effects ; IN: html.elements diff --git a/extra/html/html.factor b/extra/html/html.factor index b5d4e63930..b5b0a5e2a9 100755 --- a/extra/html/html.factor +++ b/extra/html/html.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2004, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic assocs help http io io.styles io.files +USING: generic assocs help http io io.styles io.files continuations io.streams.string kernel math math.parser namespaces quotations assocs sequences strings words html.elements -xml.writer sbufs ; +xml.writer xml.entities sbufs ; IN: html GENERIC: browser-link-href ( presented -- href ) diff --git a/extra/io/streams/null/null.factor b/extra/io/streams/null/null.factor index 28d1b29be8..f76b0cbce3 100755 --- a/extra/io/streams/null/null.factor +++ b/extra/io/streams/null/null.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.streams.null -USING: kernel io ; +USING: kernel io continuations ; TUPLE: null-stream ; diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index ee312c1111..d3412568fe 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,6 @@ -USING: combinators io io.files io.streams.duplex +USING: combinators io io.files io.streams.duplex continuations io.streams.string kernel math math.parser -namespaces pack prettyprint sequences strings system ; -USING: hexdump tools.interpreter ; +namespaces pack prettyprint sequences strings system hexdump ; IN: tar : zero-checksum 256 ; diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 5ac322a952..e02e5c01f2 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,5 +1,5 @@ USING: calendar furnace furnace.validator io.files kernel -namespaces sequences http.server.responders html math.parser rss +namespaces sequences http.server.responders html math math.parser rss xml.writer xmode.code2html ; IN: webapps.pastebin @@ -94,7 +94,7 @@ C: annotation : annotate-paste ( n summary author mode contents -- ) swap get-paste - [ paste-annotations push store save-store ] keep + [ paste-annotations push ] keep paste-link permanent-redirect ; [ "n" show-paste ] From da1d8967c4745f91eeca43944de73710dabac9b9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 31 Jan 2008 23:48:51 -0600 Subject: [PATCH 048/317] Load fixes --- extra/documents/documents.factor | 2 +- extra/help/tutorial/tutorial.factor | 5 +++-- extra/io/windows/nt/backend/backend.factor | 2 +- extra/tools/completion/completion.factor | 5 +++-- extra/ui/commands/commands.factor | 4 ++-- extra/ui/tools/search/search.factor | 2 +- extra/ui/windows/windows.factor | 7 +++++-- 7 files changed, 16 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/ui/commands/commands.factor diff --git a/extra/documents/documents.factor b/extra/documents/documents.factor index 19fca8b24c..a9b696179e 100755 --- a/extra/documents/documents.factor +++ b/extra/documents/documents.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel math models namespaces sequences strings -splitting io.streams.lines combinators ; +splitting io.streams.lines combinators unicode.categories ; IN: documents : +col ( loc n -- newloc ) >r first2 r> + 2array ; diff --git a/extra/help/tutorial/tutorial.factor b/extra/help/tutorial/tutorial.factor index f20ca27a5f..f6b1faf385 100755 --- a/extra/help/tutorial/tutorial.factor +++ b/extra/help/tutorial/tutorial.factor @@ -1,6 +1,7 @@ USING: help.markup help.syntax ui.commands ui.operations ui.tools.search ui.tools.workspace editors vocabs.loader -kernel sequences prettyprint tools.test strings ; +kernel sequences prettyprint tools.test strings +unicode.categories unicode.case ; IN: help.tutorial ARTICLE: "first-program-start" "Creating a vocabulary for your first program" @@ -134,7 +135,7 @@ $nl { $code "[ Letter? ] subset >lower" } "This code starts with a string on the stack, removes non-alphabetical characters, and converts the result to lower case, leaving a new string on the stack. We put this code in a new word, and add the new word to " { $snippet "palindrome.factor" } ":" { $code ": normalize ( str -- newstr ) [ Letter? ] subset >lower ;" } -"You will need to add " { $vocab-link "strings" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." +"You will need to add " { $vocab-link "unicode.categories" } " to the vocabulary search path, so that " { $link Letter? } " can be used in the source file." $nl "We modify " { $snippet "palindrome?" } " to first apply " { $snippet "normalize" } " to its input:" { $code ": palindrome? ( str -- ? ) normalize dup reverse = ;" } diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 940b1b7fee..67f2a9861c 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,7 +2,7 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ; +strings splitting io.files qualified ascii ; QUALIFIED: windows.winsock IN: io.windows.nt.backend diff --git a/extra/tools/completion/completion.factor b/extra/tools/completion/completion.factor index 539b348706..e44c3c401e 100755 --- a/extra/tools/completion/completion.factor +++ b/extra/tools/completion/completion.factor @@ -1,8 +1,9 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: tools.completion USING: kernel arrays sequences math namespaces strings io -vectors words assocs combinators sorting ; +vectors words assocs combinators sorting unicode.case +unicode.categories ; : (fuzzy) ( accum ch i full -- accum i ? ) index* diff --git a/extra/ui/commands/commands.factor b/extra/ui/commands/commands.factor old mode 100644 new mode 100755 index e0d991e1b2..04f655853a --- a/extra/ui/commands/commands.factor +++ b/extra/ui/commands/commands.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions kernel sequences strings math assocs words generic namespaces assocs quotations splitting -ui.gestures ; +ui.gestures unicode.case unicode.categories ; IN: ui.commands SYMBOL: +nullary+ @@ -51,7 +51,7 @@ GENERIC: command-word ( command -- word ) update-gestures ; : (command-name) ( string -- newstring ) - "-" split " " join unclip ch>upper add* ; + "-" split " " join >title ; M: word command-name ( word -- str ) word-name diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index ea3fcb02eb..27ca4a165d 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -7,7 +7,7 @@ source-files strings tools.completion tools.crossref tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader -tools.browser ; +tools.browser unicode.case ; IN: ui.tools.search TUPLE: live-search field list ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 9311a1b2a6..c3ef328b29 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,7 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads timers libc combinators continuations -command-line shuffle opengl ui.render ; +command-line shuffle opengl ui.render unicode.case ascii ; IN: ui.windows TUPLE: windows-ui-backend ; @@ -140,7 +140,10 @@ SYMBOL: mouse-captured : ctrl? ( -- ? ) left-ctrl? right-ctrl? or ; : alt? ( -- ? ) left-alt? right-alt? or ; : caps-lock? ( -- ? ) VK_CAPITAL GetKeyState zero? not ; -: switch-case ( seq -- seq ) dup first CHAR: a >= [ >upper ] [ >lower ] if ; + +: switch-case ( seq -- seq ) + dup first CHAR: a >= [ >upper ] [ >lower ] if ; + : switch-case? ( -- ? ) shift? caps-lock? xor not ; : key-modifiers ( -- seq ) From 71bac0da210be60088eca406785cd7c5ffed610e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 31 Jan 2008 23:59:29 -0600 Subject: [PATCH 049/317] Load fixes --- extra/io/unix/unix-tests.factor | 2 +- extra/parser-combinators/parser-combinators.factor | 3 ++- extra/xml/writer/writer.factor | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index ce2f052450..e49364fad3 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences -prettyprint system ; +prettyprint system unicode.case ; IN: temporary ! Unix domain stream sockets diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 4376aed95a..b7b62b3c2e 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: lazy-lists promises kernel sequences strings math -arrays splitting quotations combinators namespaces ; +arrays splitting quotations combinators namespaces +unicode.case unicode.categories ; IN: parser-combinators ! Parser combinator protocol diff --git a/extra/xml/writer/writer.factor b/extra/xml/writer/writer.factor index 95f38f3da9..8c7b51d756 100644 --- a/extra/xml/writer/writer.factor +++ b/extra/xml/writer/writer.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings -io io.streams.string xml.data assocs wrap xml.entities ; +io io.streams.string xml.data assocs wrap xml.entities +unicode.categories ; IN: xml.writer SYMBOL: xml-pprint? From e37f2101c6d355e437d4ca9654e59f6354473748 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Fri, 1 Feb 2008 14:45:29 -0500 Subject: [PATCH 050/317] Solution to Project Euler problem 38 --- extra/project-euler/032/032.factor | 5 +-- extra/project-euler/038/038.factor | 55 ++++++++++++++++++++++++ extra/project-euler/common/common.factor | 6 ++- extra/project-euler/project-euler.factor | 4 +- 4 files changed, 63 insertions(+), 7 deletions(-) create mode 100644 extra/project-euler/038/038.factor diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index d10326a076..2baa6f8714 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences sorting ; + math.ranges project-euler.common sequences ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 @@ -63,9 +63,6 @@ PRIVATE> : source-032a ( -- seq ) 50 [1,b] 2000 [1,b] cartesian-product ; -: pandigital? ( n -- ? ) - number>string natural-sort "123456789" = ; - ! multiplicand/multiplier/product : mmp ( pair -- n ) first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor new file mode 100644 index 0000000000..cbe6f2363c --- /dev/null +++ b/extra/project-euler/038/038.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser math.ranges project-euler.common sequences ; +IN: project-euler.038 + +! http://projecteuler.net/index.php?section=problems&id=38 + +! DESCRIPTION +! ----------- + +! Take the number 192 and multiply it by each of 1, 2, and 3: + +! 192 × 1 = 192 +! 192 × 2 = 384 +! 192 × 3 = 576 + +! By concatenating each product we get the 1 to 9 pandigital, 192384576. We +! will call 192384576 the concatenated product of 192 and (1,2,3) + +! The same can be achieved by starting with 9 and multiplying by 1, 2, 3, 4, +! and 5, giving the pandigital, 918273645, which is the concatenated product of +! 9 and (1,2,3,4,5). + +! What is the largest 1 to 9 pandigital 9-digit number that can be formed as +! the concatenated product of an integer with (1,2, ... , n) where n > 1? + + +! SOLUTION +! -------- + +! Only need to search 4-digit numbers starting with 9 since a 2-digit number +! starting with 9 would produce 8 or 11 digits, and a 3-digit number starting +! with 9 would produce 7 or 11 digits. + + [ + 2drop 10 swap digits>integer + ] [ + [ * number>digits over push-all ] 2keep 1+ (concat-product) + ] if ; + +: concat-product ( n -- m ) + V{ } clone swap 1 (concat-product) ; + +PRIVATE> + +: euler038 ( -- answer ) + 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ; + +! [ euler038 ] 100 ave-time +! 37 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler038 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2e718ab5a2..609492c724 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,5 +1,5 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin - math.parser math.primes.factors math.ranges namespaces sequences ; + math.parser math.primes.factors math.ranges namespaces sequences sorting ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -12,6 +12,7 @@ IN: project-euler.common ! log10 - #25, #134 ! max-path - #18, #67 ! number>digits - #16, #20, #30, #34 +! pandigital? - #32, #38 ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 @@ -67,6 +68,9 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; +: pandigital? ( n -- ? ) + number>string natural-sort "123456789" = ; + ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- newtriangle ) diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index fbb62961a9..0037e4462f 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -11,8 +11,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.037 project-euler.067 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.037 project-euler.038 project-euler.067 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Fri, 1 Feb 2008 14:40:06 -0600 Subject: [PATCH 051/317] Fix PPC bootstrap --- core/cpu/ppc/intrinsics/intrinsics.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/cpu/ppc/intrinsics/intrinsics.factor b/core/cpu/ppc/intrinsics/intrinsics.factor index 693bcdb5e4..91bf5ed1e3 100755 --- a/core/cpu/ppc/intrinsics/intrinsics.factor +++ b/core/cpu/ppc/intrinsics/intrinsics.factor @@ -1,6 +1,6 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types arrays cpu.ppc.assembler +USING: alien alien.accessors alien.c-types arrays cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel kernel.private math math.private namespaces sequences words generic quotations byte-arrays hashtables hashtables.private From ff55f0f4cc25f75690e82fe6be48e8c324b01887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 15:00:02 -0600 Subject: [PATCH 052/317] New \u...... syntax; io.utf8 and io.utf16 can actually use strings now --- core/alien/c-types/c-types-tests.factor | 8 +++---- core/ascii/ascii.factor | 3 ++- core/io/binary/binary-tests.factor | 4 ++-- core/io/encodings/encodings.factor | 2 +- core/io/utf16/utf16-tests.factor | 20 ++++++++-------- core/io/utf16/utf16.factor | 1 - core/parser/parser-tests.factor | 10 ++++---- core/parser/parser.factor | 2 +- core/prettyprint/backend/backend-docs.factor | 2 +- core/prettyprint/backend/backend.factor | 2 +- core/prettyprint/prettyprint-tests.factor | 4 ++-- core/sequences/sequences-tests.factor | 2 +- core/strings/strings-docs.factor | 2 +- core/syntax/syntax-docs.factor | 4 ++-- extra/asn1/asn1-tests.factor | 2 +- extra/crypto/hmac/hmac-tests.factor | 12 +++++----- extra/crypto/sha1/sha1-tests.factor | 4 ++-- extra/io/nonblocking/nonblocking.factor | 24 +++++++++++-------- extra/io/windows/nt/backend/backend.factor | 2 +- extra/pack/pack-tests.factor | 2 +- extra/regexp/regexp-tests.factor | 4 ++-- extra/slides/slides.factor | 2 +- extra/unicode/breaks/breaks-tests.factor | 6 ++--- extra/unicode/case/case-tests.factor | 10 ++++---- extra/unicode/case/case.factor | 4 ++-- .../unicode/normalize/normalize-tests.factor | 16 ++++++------- extra/xml/char-classes/char-classes.factor | 6 ++--- {extra => unmaintained}/cabal/authors.txt | 0 {extra => unmaintained}/cabal/cabal.factor | 0 {extra => unmaintained}/cabal/summary.txt | 0 {extra => unmaintained}/cabal/ui/authors.txt | 0 {extra => unmaintained}/cabal/ui/summary.txt | 0 {extra => unmaintained}/cabal/ui/ui.factor | 0 {extra => unmaintained}/lisp/README | 0 {extra => unmaintained}/lisp/authors.txt | 0 .../lisp/lexer/lexer.factor | 0 {extra => unmaintained}/lisp/lisp.factor | 0 .../lisp/listener/listener.factor | 0 .../lisp/listener/mod/mod.factor | 0 .../lisp/parser/mod/mod.factor | 0 {extra => unmaintained}/lisp/summary.txt | 0 .../lisp/syntax/syntax.factor | 0 {extra => unmaintained}/lisp/tags.txt | 0 43 files changed, 81 insertions(+), 79 deletions(-) mode change 100644 => 100755 core/alien/c-types/c-types-tests.factor mode change 100644 => 100755 core/io/binary/binary-tests.factor mode change 100644 => 100755 core/io/encodings/encodings.factor mode change 100644 => 100755 core/io/utf16/utf16-tests.factor mode change 100644 => 100755 core/prettyprint/backend/backend-docs.factor mode change 100644 => 100755 extra/asn1/asn1-tests.factor mode change 100644 => 100755 extra/crypto/hmac/hmac-tests.factor mode change 100644 => 100755 extra/crypto/sha1/sha1-tests.factor mode change 100644 => 100755 extra/pack/pack-tests.factor mode change 100644 => 100755 extra/unicode/breaks/breaks-tests.factor mode change 100644 => 100755 extra/unicode/case/case-tests.factor mode change 100644 => 100755 extra/unicode/case/case.factor mode change 100644 => 100755 extra/unicode/normalize/normalize-tests.factor mode change 100644 => 100755 extra/xml/char-classes/char-classes.factor rename {extra => unmaintained}/cabal/authors.txt (100%) rename {extra => unmaintained}/cabal/cabal.factor (100%) rename {extra => unmaintained}/cabal/summary.txt (100%) rename {extra => unmaintained}/cabal/ui/authors.txt (100%) rename {extra => unmaintained}/cabal/ui/summary.txt (100%) rename {extra => unmaintained}/cabal/ui/ui.factor (100%) rename {extra => unmaintained}/lisp/README (100%) rename {extra => unmaintained}/lisp/authors.txt (100%) rename {extra => unmaintained}/lisp/lexer/lexer.factor (100%) rename {extra => unmaintained}/lisp/lisp.factor (100%) rename {extra => unmaintained}/lisp/listener/listener.factor (100%) rename {extra => unmaintained}/lisp/listener/mod/mod.factor (100%) rename {extra => unmaintained}/lisp/parser/mod/mod.factor (100%) rename {extra => unmaintained}/lisp/summary.txt (100%) rename {extra => unmaintained}/lisp/syntax/syntax.factor (100%) rename {extra => unmaintained}/lisp/tags.txt (100%) diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor old mode 100644 new mode 100755 index c988446e20..3148b85782 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -2,16 +2,16 @@ IN: temporary USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc ; -[ "\u00ff" ] -[ "\u00ff" string>char-alien alien>char-string ] +[ "\u0000ff" ] +[ "\u0000ff" string>char-alien alien>char-string ] unit-test [ "hello world" ] [ "hello world" string>char-alien alien>char-string ] unit-test -[ "hello\uabcdworld" ] -[ "hello\uabcdworld" string>u16-alien alien>u16-string ] +[ "hello\u00abcdworld" ] +[ "hello\u00abcdworld" string>u16-alien alien>u16-string ] unit-test [ t ] [ f expired? ] unit-test diff --git a/core/ascii/ascii.factor b/core/ascii/ascii.factor index eeb6b2d480..019db5f3b2 100755 --- a/core/ascii/ascii.factor +++ b/core/ascii/ascii.factor @@ -13,7 +13,8 @@ IN: ascii : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline -: control? ( ch -- ? ) "\0\e\r\n\t\u0008\u007f" member? ; inline +: control? ( ch -- ? ) + "\0\e\r\n\t\u000008\u00007f" member? ; inline : quotable? ( ch -- ? ) dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline diff --git a/core/io/binary/binary-tests.factor b/core/io/binary/binary-tests.factor old mode 100644 new mode 100755 index 5d80443e84..69e733b55a --- a/core/io/binary/binary-tests.factor +++ b/core/io/binary/binary-tests.factor @@ -1,8 +1,8 @@ USING: io.binary tools.test ; IN: temporary -[ "\0\0\u0004\u00d2" ] [ 1234 4 >be ] unit-test -[ "\u00d2\u0004\0\0" ] [ 1234 4 >le ] unit-test +[ "\0\0\u000004\u0000d2" ] [ 1234 4 >be ] unit-test +[ "\u0000d2\u000004\0\0" ] [ 1234 4 >le ] unit-test [ 1234 ] [ 1234 4 >be be> ] unit-test [ 1234 ] [ 1234 4 >le le> ] unit-test diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor old mode 100644 new mode 100755 index f363389b59..83ab576faf --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -21,5 +21,5 @@ SYMBOL: begin begin eq? [ decode-error ] unless drop { } like ; : decode ( seq quot -- str ) - >r [ length 0 begin ] keep r> each + >r [ length 0 begin ] keep r> each finish-decoding ; inline diff --git a/core/io/utf16/utf16-tests.factor b/core/io/utf16/utf16-tests.factor old mode 100644 new mode 100755 index 014d834016..7a4b766941 --- a/core/io/utf16/utf16-tests.factor +++ b/core/io/utf16/utf16-tests.factor @@ -1,15 +1,15 @@ USING: tools.test io.utf16 ; -[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be ] unit-test -[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be ] unit-test -[ { BIN: 11011111 CHAR: q } decode-utf16be ] unit-test-fails -[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be ] unit-test-fails +[ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test +[ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test +[ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test-fails +[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test-fails -[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test +[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be >array ] unit-test -[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le ] unit-test -[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le ] unit-test -[ { 0 BIN: 11011111 } decode-utf16le ] unit-test-fails -[ { 0 BIN: 11011011 0 0 } decode-utf16le ] unit-test-fails +[ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test +[ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test +[ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test-fails +[ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test-fails -[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test +[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le >array ] unit-test diff --git a/core/io/utf16/utf16.factor b/core/io/utf16/utf16.factor index 7ed27a626e..d6b160e156 100755 --- a/core/io/utf16/utf16.factor +++ b/core/io/utf16/utf16.factor @@ -110,4 +110,3 @@ SYMBOL: quad3 { [ utf16be? ] [ decode-utf16be ] } { [ t ] [ decode-error ] } } cond ; - diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 55d43ce8e0..213f0868c0 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -9,13 +9,13 @@ IN: temporary [ 0 "abcd" next-char ] unit-test [ 6 CHAR: \s ] - [ 1 "\\u0020hello" next-escape ] unit-test + [ 1 "\\u000020hello" next-escape ] unit-test [ 2 CHAR: \n ] [ 1 "\\nhello" next-escape ] unit-test [ 6 CHAR: \s ] - [ 0 "\\u0020hello" next-char ] unit-test + [ 0 "\\u000020hello" next-char ] unit-test [ 1 [ 2 [ 3 ] 4 ] 5 ] [ "1\n[\n2\n[\n3\n]\n4\n]\n5" eval ] @@ -46,15 +46,13 @@ IN: temporary ! Test escapes [ " " ] - [ "\"\\u0020\"" eval ] + [ "\"\\u000020\"" eval ] unit-test [ "'" ] - [ "\"\\u0027\"" eval ] + [ "\"\\u000027\"" eval ] unit-test - [ "\\u123" eval ] unit-test-fails - ! Test EOL comments in multiline strings. [ "Hello" ] [ "#! This calls until-eol.\n\"Hello\"" eval ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 1a61573bd4..862b266d05 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -120,7 +120,7 @@ M: bad-escape summary drop "Bad escape code" ; : next-escape ( m str -- n ch ) 2dup nth CHAR: u = - [ >r 1+ dup 4 + tuck r> subseq hex> ] + [ >r 1+ dup 6 + tuck r> subseq hex> ] [ over 1+ -rot nth escape ] if ; : next-char ( m str -- n ch ) diff --git a/core/prettyprint/backend/backend-docs.factor b/core/prettyprint/backend/backend-docs.factor old mode 100644 new mode 100755 index 4605308a95..c7ca380fbd --- a/core/prettyprint/backend/backend-docs.factor +++ b/core/prettyprint/backend/backend-docs.factor @@ -20,7 +20,7 @@ HELP: ch>ascii-escape HELP: ch>unicode-escape { $values { "ch" "a character" } { "str" string } } -{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u1234"} ")." } ; +{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u123456"} ")." } ; HELP: unparse-ch { $values { "ch" "a character" } } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index f88ab4ca2a..a5d0cee6c5 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -68,7 +68,7 @@ M: f pprint* drop \ f pprint-word ; } at ; : ch>unicode-escape ( ch -- str ) - >hex 4 CHAR: 0 pad-left "\\u" swap append ; + >hex 6 CHAR: 0 pad-left "\\u" swap append ; : unparse-ch ( ch -- ) dup quotable? [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 9c5ec885ae..7f7d946347 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -21,8 +21,8 @@ IN: temporary [ "hello\\backslash" unparse ] unit-test -[ "\"\\u1234\"" ] -[ "\u1234" unparse ] +[ "\"\\u123456\"" ] +[ "\u123456" unparse ] unit-test [ "\"\\e\"" ] diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 1509fa8c05..e988a62feb 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -151,7 +151,7 @@ unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test [ 5 ] [ 1 >bignum { 1 5 7 } nth-unsafe ] unit-test -[ 5 ] [ 1 >bignum "\u0001\u0005\u0007" nth-unsafe ] unit-test +[ 5 ] [ 1 >bignum "\u000001\u000005\u000007" nth-unsafe ] unit-test [ SBUF" before&after" ] [ "&" 6 11 SBUF" before and after" [ replace-slice ] keep diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index e09c6da0eb..d8cef5557a 100755 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -58,4 +58,4 @@ HELP: >string HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } -{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u0000" } "." } ; +{ $description "Creates a new string " { $snippet "n" } " characters long The contents of the existing string are copied into the new string; if the new string is shorter, only an initial segment is copied, and if the new string is longer the remaining space is filled with " { $snippet "\\u000000" } "." } ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index df96743e3d..2e5b41cd8d 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -99,9 +99,9 @@ ARTICLE: "escape" "Character escape codes" { { $snippet "\\e" } "escape (ASCII 27)" } { { $snippet "\\\"" } { $snippet "\"" } } } -"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a four-digit hexadecimal number. That is, the following two expressions are equivalent:" +"A Unicode character can be specified by its code number by writing " { $snippet "\\u" } " followed by a six-digit hexadecimal number. That is, the following two expressions are equivalent:" { $code - "CHAR: \\u0078" + "CHAR: \\u000078" "78" } "While not useful for single characters, this syntax is also permitted inside strings." ; diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor old mode 100644 new mode 100755 index 1277090ec7..1c9bc79d76 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -1,7 +1,7 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ; [ 6 ] [ - "\u0002\u0001\u0006" [ asn-syntax read-ber ] with-stream + "\u000002\u000001\u000006" [ asn-syntax read-ber ] with-stream ] unit-test [ "testing" ] [ diff --git a/extra/crypto/hmac/hmac-tests.factor b/extra/crypto/hmac/hmac-tests.factor old mode 100644 new mode 100755 index ccb380e1e0..64efb96f90 --- a/extra/crypto/hmac/hmac-tests.factor +++ b/extra/crypto/hmac/hmac-tests.factor @@ -1,11 +1,11 @@ USING: kernel io strings sequences namespaces math parser crypto.hmac tools.test ; IN: temporary -[ "\u0092\u0094rz68\u00bb\u001c\u0013\u00f4\u008e\u00f8\u0015\u008b\u00fc\u009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test -[ "u\u000cx>j\u00b0\u00b5\u0003\u00ea\u00a8n1\n]\u00b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test -[ "V\u00be4R\u001d\u0014L\u0088\u00db\u00b8\u00c73\u00f0\u00e8\u00b3\u00f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test +[ "\u000092\u000094rz68\u0000bb\u00001c\u000013\u0000f4\u00008e\u0000f8\u000015\u00008b\u0000fc\u00009d" ] [ 16 11 "Hi There" string>md5-hmac >string ] unit-test +[ "u\u00000cx>j\u0000b0\u0000b5\u000003\u0000ea\u0000a8n1\n]\u0000b78" ] [ "Jefe" "what do ya want for nothing?" string>md5-hmac >string ] unit-test +[ "V\u0000be4R\u00001d\u000014L\u000088\u0000db\u0000b8\u0000c73\u0000f0\u0000e8\u0000b3\u0000f6" ] [ 16 HEX: aa 50 HEX: dd string>md5-hmac >string ] unit-test -[ "g[\u000b:\eM\u00dfN\u0012Hr\u00dal/c+\u00fe\u00d9W\u00e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test -[ "\u00ef\u00fc\u00dfj\u00e5\u00eb/\u00a2\u00d2t\u0016\u00d5\u00f1\u0084\u00df\u009c%\u009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test -[ "\u00d70YM\u0016~5\u00d5\u0095o\u00d8\0=\r\u00b3\u00d3\u00f4m\u00c7\u00bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test +[ "g[\u00000b:\eM\u0000dfN\u000012Hr\u0000dal/c+\u0000fe\u0000d9W\u0000e9" ] [ 16 11 "Hi There" string>sha1-hmac >string ] unit-test +[ "\u0000ef\u0000fc\u0000dfj\u0000e5\u0000eb/\u0000a2\u0000d2t\u000016\u0000d5\u0000f1\u000084\u0000df\u00009c%\u00009a|y" ] [ "Jefe" "what do ya want for nothing?" string>sha1-hmac >string ] unit-test +[ "\u0000d70YM\u000016~5\u0000d5\u000095o\u0000d8\0=\r\u0000b3\u0000d3\u0000f4m\u0000c7\u0000bb" ] [ 16 HEX: aa 50 HEX: dd string>sha1-hmac >string ] unit-test diff --git a/extra/crypto/sha1/sha1-tests.factor b/extra/crypto/sha1/sha1-tests.factor old mode 100644 new mode 100755 index c4f06800c8..795ee4971d --- a/extra/crypto/sha1/sha1-tests.factor +++ b/extra/crypto/sha1/sha1-tests.factor @@ -7,8 +7,8 @@ USING: arrays kernel math namespaces sequences tools.test crypto.sha1 ; 10 swap concat string>sha1str ] unit-test [ - ";\u009b\u00fd\u00cdK\u00a3^s\u00d0*\u00e3\\\u00b5\u0013<\u00e8wA\u00b2\u0083\u00d20\u00f1\u00e6\u00cc\u00d8\u001e\u009c\u0004\u00d7PT]\u00ce,\u0001\u0012\u0080\u0096\u0099" + ";\u00009b\u0000fd\u0000cdK\u0000a3^s\u0000d0*\u0000e3\\\u0000b5\u000013<\u0000e8wA\u0000b2\u000083\u0000d20\u0000f1\u0000e6\u0000cc\u0000d8\u00001e\u00009c\u000004\u0000d7PT]\u0000ce,\u000001\u000012\u000080\u000096\u000099" ] [ - "\u0066\u0053\u00f1\u000c\u001a\u00fa\u00b5\u004c\u0061\u00c8\u0025\u0075\u00a8\u004a\u00fe\u0030\u00d8\u00aa\u001a\u003a\u0096\u0096\u00b3\u0018\u0099\u0092\u00bf\u00e1\u00cb\u007f\u00a6\u00a7" + "\u000066\u000053\u0000f1\u00000c\u00001a\u0000fa\u0000b5\u00004c\u000061\u0000c8\u000025\u000075\u0000a8\u00004a\u0000fe\u000030\u0000d8\u0000aa\u00001a\u00003a\u000096\u000096\u0000b3\u000018\u000099\u000092\u0000bf\u0000e1\u0000cb\u00007f\u0000a6\u0000a7" string>sha1-interleave ] unit-test diff --git a/extra/io/nonblocking/nonblocking.factor b/extra/io/nonblocking/nonblocking.factor index 3588ea5d14..5dbd3d1490 100755 --- a/extra/io/nonblocking/nonblocking.factor +++ b/extra/io/nonblocking/nonblocking.factor @@ -67,14 +67,14 @@ timeout-queue global [ [ ] unless* ] change-at dup timeout-queue get-global push-front* swap set-port-timeout-entry ; -HOOK: expire-port io-backend ( port -- ) +HOOK: cancel-io io-backend ( port -- ) -M: object expire-port drop ; +M: object cancel-io drop ; : expire-timeouts ( -- ) timeout-queue get-global dup dlist-empty? [ drop ] [ dup peek-back timeout? - [ pop-back expire-port expire-timeouts ] [ drop ] if + [ pop-back cancel-io expire-timeouts ] [ drop ] if ] if ; : begin-timeout ( port -- ) @@ -193,14 +193,18 @@ GENERIC: port-flush ( port -- ) M: output-port stream-flush ( port -- ) dup port-flush pending-error ; +: close-port ( port type -- ) + output-port eq? [ dup port-flush ] when + dup cancel-io + dup port-handle close-handle + dup delegate [ buffer-free ] when* + f swap set-delegate ; + M: port dispose - dup port-type closed eq? [ - dup port-type >r closed over set-port-type r> - output-port eq? [ dup port-flush ] when - dup port-handle close-handle - dup delegate [ buffer-free ] when* - f over set-delegate - ] unless drop ; + dup port-type closed eq? + [ drop ] + [ dup port-type >r closed over set-port-type r> close-port ] + if ; TUPLE: server-port addr client ; diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 67f2a9861c..88e7cdf84a 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -122,7 +122,7 @@ M: windows-nt-io add-completion ( handle -- ) : drain-overlapped ( timeout -- ) handle-overlapped [ 0 drain-overlapped ] unless ; -M: windows-nt-io expire-port +M: windows-nt-io cancel-io port-handle win32-file-handle CancelIo drop ; M: windows-nt-io io-multiplex ( ms -- ) diff --git a/extra/pack/pack-tests.factor b/extra/pack/pack-tests.factor old mode 100644 new mode 100755 index b2fdc8ab0d..7a88881189 --- a/extra/pack/pack-tests.factor +++ b/extra/pack/pack-tests.factor @@ -43,5 +43,5 @@ USING: io io.streams.string kernel namespaces pack strings tools.test ; [ "FRAM" ] [ "FRAM\0" [ read-c-string ] string-in ] unit-test [ f ] [ "" [ read-c-string ] string-in ] unit-test -[ 5 ] [ "FRAM\0\u0005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test +[ 5 ] [ "FRAM\0\u000005\0\0\0\0\0\0\0" [ read-c-string drop read-u64 ] string-in ] unit-test diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 823e7c7f36..9c0ed5bd81 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -158,8 +158,8 @@ IN: regexp-tests [ t ] [ "SXY" "\\0123XY" f matches? ] unit-test [ t ] [ "x" "\\x78" f matches? ] unit-test [ f ] [ "y" "\\x78" f matches? ] unit-test -[ t ] [ "x" "\\u0078" f matches? ] unit-test -[ f ] [ "y" "\\u0078" f matches? ] unit-test +[ t ] [ "x" "\\u000078" f matches? ] unit-test +[ f ] [ "y" "\\u000078" f matches? ] unit-test [ t ] [ "ab" "a+b" f matches? ] unit-test [ f ] [ "b" "a+b" f matches? ] unit-test diff --git a/extra/slides/slides.factor b/extra/slides/slides.factor index ba423699c3..a0065d6fe3 100755 --- a/extra/slides/slides.factor +++ b/extra/slides/slides.factor @@ -33,7 +33,7 @@ IN: slides { list-style H{ { table-gap { 10 20 } } } } - { bullet "\u00b7" } + { bullet "\u0000b7" } } ; : $title ( string -- ) diff --git a/extra/unicode/breaks/breaks-tests.factor b/extra/unicode/breaks/breaks-tests.factor old mode 100644 new mode 100755 index 26f419ff0e..77ba0e82fa --- a/extra/unicode/breaks/breaks-tests.factor +++ b/extra/unicode/breaks/breaks-tests.factor @@ -1,7 +1,7 @@ USING: tools.test unicode.breaks sequences math kernel ; -[ "\u1112\u1161\u11abA\u0300a\r\r\n" ] -[ "\r\n\raA\u0300\u1112\u1161\u11ab" string-reverse ] unit-test +[ "\u001112\u001161\u0011abA\u000300a\r\r\n" ] +[ "\r\n\raA\u000300\u001112\u001161\u0011ab" string-reverse ] unit-test [ "dcba" ] [ "abcd" string-reverse ] unit-test -[ 3 ] [ "\u1112\u1161\u11abA\u0300a" +[ 3 ] [ "\u001112\u001161\u0011abA\u000300a" dup last-grapheme head last-grapheme ] unit-test diff --git a/extra/unicode/case/case-tests.factor b/extra/unicode/case/case-tests.factor old mode 100644 new mode 100755 index 0ac074cfae..531fa2faab --- a/extra/unicode/case/case-tests.factor +++ b/extra/unicode/case/case-tests.factor @@ -1,14 +1,14 @@ USING: unicode.case tools.test namespaces ; [ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test -[ "FUSS" ] [ "Fu\u00DF" >upper ] unit-test -[ "\u03C3\u03C2" ] [ "\u03A3\u03A3" >lower ] unit-test +[ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test +[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test [ "tr" locale set - [ "i\u0131i \u0131jj" ] [ "i\u0131I\u0307 IJj" >lower ] unit-test -! [ "I\u307\u0131i Ijj" ] [ "i\u0131I\u0307 IJj" >title ] unit-test - [ "I\u0307II\u0307 IJJ" ] [ "i\u0131I\u0307 IJj" >upper ] unit-test + [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test +! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test + [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test "lt" locale set ! Lithuanian casing tests ] with-scope diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor old mode 100644 new mode 100755 index 5f142297ef..96ae9a790b --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -13,7 +13,7 @@ SYMBOL: locale ! Just casing locale, or overall? : lithuanian? ( -- ? ) locale get "lt" = ; -: dot-over ( -- ch ) CHAR: \u0307 ; +: dot-over ( -- ch ) HEX: 307 ; : lithuanian-ch>upper ( ? next ch -- ? ) rot [ 2drop f ] @@ -46,7 +46,7 @@ SYMBOL: locale ! Just casing locale, or overall? { [ rot ] [ 2drop f ] } { [ dup CHAR: I = ] [ drop dot-over = - dup CHAR: i CHAR: \u0131 ? , + dup CHAR: i HEX: 131 ? , ] } { [ t ] [ , drop f ] } } cond ; diff --git a/extra/unicode/normalize/normalize-tests.factor b/extra/unicode/normalize/normalize-tests.factor old mode 100644 new mode 100755 index d98aec6170..ca2701f728 --- a/extra/unicode/normalize/normalize-tests.factor +++ b/extra/unicode/normalize/normalize-tests.factor @@ -1,18 +1,18 @@ USING: unicode.normalize kernel tools.test sequences ; -[ "ab\u0323\u0302cd" ] [ "ab\u0302" "\u0323cd" string-append ] unit-test +[ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test -[ "ab\u064b\u034d\u034e\u0347\u0346" ] [ "ab\u0346\u0347\u064b\u034e\u034d" dup reorder ] unit-test +[ "ab\u00064b\u00034d\u00034e\u000347\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test [ "hello" "hello" ] [ "hello" [ nfd ] keep nfkd ] unit-test -[ "\uFB012\u2075\u017F\u0323\u0307" "fi25s\u0323\u0307" ] -[ "\uFB012\u2075\u1E9B\u0323" [ nfd ] keep nfkd ] unit-test +[ "\u00FB012\u002075\u00017F\u000323\u000307" "fi25s\u000323\u000307" ] +[ "\u00FB012\u002075\u001E9B\u000323" [ nfd ] keep nfkd ] unit-test -[ "\u1E69" "s\u0323\u0307" ] [ "\u1E69" [ nfc ] keep nfd ] unit-test -[ "\u1E0D\u0307" ] [ "\u1E0B\u0323" nfc ] unit-test +[ "\u001E69" "s\u000323\u000307" ] [ "\u001E69" [ nfc ] keep nfd ] unit-test +[ "\u001E0D\u000307" ] [ "\u001E0B\u000323" nfc ] unit-test [ 54620 ] [ 4370 4449 4523 jamo>hangul ] unit-test [ 4370 4449 4523 ] [ 54620 hangul>jamo first3 ] unit-test [ t ] [ 54620 hangul? ] unit-test [ f ] [ 0 hangul? ] unit-test -[ "\u1112\u1161\u11ab" ] [ "\ud55c" nfd ] unit-test -[ "\ud55c" ] [ "\u1112\u1161\u11ab" nfc ] unit-test +[ "\u001112\u001161\u0011ab" ] [ "\u00d55c" nfd ] unit-test +[ "\u00d55c" ] [ "\u001112\u001161\u0011ab" nfc ] unit-test diff --git a/extra/xml/char-classes/char-classes.factor b/extra/xml/char-classes/char-classes.factor old mode 100644 new mode 100755 index d5254ed3f7..ddf935a30b --- a/extra/xml/char-classes/char-classes.factor +++ b/extra/xml/char-classes/char-classes.factor @@ -3,16 +3,16 @@ USING: kernel sequences unicode.syntax math ; IN: xml.char-classes -CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u0559\u06E5\u06E6_ ; +CATEGORY: 1.0name-start* Ll Lu Lo Lt Nl \u000559\u0006E5\u0006E6_ ; : 1.0name-start? ( char -- ? ) dup 1.0name-start*? [ drop t ] [ HEX: 2BB HEX: 2C1 between? ] if ; -CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u0387 ; +CATEGORY: 1.0name-char Ll Lu Lo Lt Nl Mc Me Mn Lm Nd _-.\u000387 ; CATEGORY: 1.1name-start Ll Lu Lo Lm Ln Nl _ ; -CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u00b7 ; +CATEGORY: 1.1name-char Ll Lu Lo Lm Ln Nl Mc Mn Nd Pc Cf _-.\u0000b7 ; : name-start? ( 1.0? char -- ? ) swap [ 1.0name-start? ] [ 1.1name-start? ] if ; diff --git a/extra/cabal/authors.txt b/unmaintained/cabal/authors.txt similarity index 100% rename from extra/cabal/authors.txt rename to unmaintained/cabal/authors.txt diff --git a/extra/cabal/cabal.factor b/unmaintained/cabal/cabal.factor similarity index 100% rename from extra/cabal/cabal.factor rename to unmaintained/cabal/cabal.factor diff --git a/extra/cabal/summary.txt b/unmaintained/cabal/summary.txt similarity index 100% rename from extra/cabal/summary.txt rename to unmaintained/cabal/summary.txt diff --git a/extra/cabal/ui/authors.txt b/unmaintained/cabal/ui/authors.txt similarity index 100% rename from extra/cabal/ui/authors.txt rename to unmaintained/cabal/ui/authors.txt diff --git a/extra/cabal/ui/summary.txt b/unmaintained/cabal/ui/summary.txt similarity index 100% rename from extra/cabal/ui/summary.txt rename to unmaintained/cabal/ui/summary.txt diff --git a/extra/cabal/ui/ui.factor b/unmaintained/cabal/ui/ui.factor similarity index 100% rename from extra/cabal/ui/ui.factor rename to unmaintained/cabal/ui/ui.factor diff --git a/extra/lisp/README b/unmaintained/lisp/README similarity index 100% rename from extra/lisp/README rename to unmaintained/lisp/README diff --git a/extra/lisp/authors.txt b/unmaintained/lisp/authors.txt similarity index 100% rename from extra/lisp/authors.txt rename to unmaintained/lisp/authors.txt diff --git a/extra/lisp/lexer/lexer.factor b/unmaintained/lisp/lexer/lexer.factor similarity index 100% rename from extra/lisp/lexer/lexer.factor rename to unmaintained/lisp/lexer/lexer.factor diff --git a/extra/lisp/lisp.factor b/unmaintained/lisp/lisp.factor similarity index 100% rename from extra/lisp/lisp.factor rename to unmaintained/lisp/lisp.factor diff --git a/extra/lisp/listener/listener.factor b/unmaintained/lisp/listener/listener.factor similarity index 100% rename from extra/lisp/listener/listener.factor rename to unmaintained/lisp/listener/listener.factor diff --git a/extra/lisp/listener/mod/mod.factor b/unmaintained/lisp/listener/mod/mod.factor similarity index 100% rename from extra/lisp/listener/mod/mod.factor rename to unmaintained/lisp/listener/mod/mod.factor diff --git a/extra/lisp/parser/mod/mod.factor b/unmaintained/lisp/parser/mod/mod.factor similarity index 100% rename from extra/lisp/parser/mod/mod.factor rename to unmaintained/lisp/parser/mod/mod.factor diff --git a/extra/lisp/summary.txt b/unmaintained/lisp/summary.txt similarity index 100% rename from extra/lisp/summary.txt rename to unmaintained/lisp/summary.txt diff --git a/extra/lisp/syntax/syntax.factor b/unmaintained/lisp/syntax/syntax.factor similarity index 100% rename from extra/lisp/syntax/syntax.factor rename to unmaintained/lisp/syntax/syntax.factor diff --git a/extra/lisp/tags.txt b/unmaintained/lisp/tags.txt similarity index 100% rename from extra/lisp/tags.txt rename to unmaintained/lisp/tags.txt From 0bfad408721f53c72b555e83969eb0861bb6468b Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 15:36:26 -0600 Subject: [PATCH 053/317] USE fix for pastebin --- extra/webapps/pastebin/pastebin.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/webapps/pastebin/pastebin.factor b/extra/webapps/pastebin/pastebin.factor index 5ac322a952..7a7a88dcc6 100755 --- a/extra/webapps/pastebin/pastebin.factor +++ b/extra/webapps/pastebin/pastebin.factor @@ -1,6 +1,6 @@ USING: calendar furnace furnace.validator io.files kernel namespaces sequences http.server.responders html math.parser rss -xml.writer xmode.code2html ; +xml.writer xmode.code2html math ; IN: webapps.pastebin TUPLE: pastebin pastes ; From 8dd333cbb54bc827bb9fa4a7b4cecbad4aae786a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 16:02:02 -0600 Subject: [PATCH 054/317] Fix unit tests and fix string clone --- core/ascii/ascii-tests.factor | 15 +++++++++++++ core/parser/parser-tests.factor | 4 ++-- core/sequences/sequences-tests.factor | 16 +++++++------- core/strings/strings-tests.factor | 22 +++++++++---------- core/strings/strings.factor | 3 ++- extra/io/unix/unix-tests.factor | 6 ++--- .../parser-combinators-tests.factor | 3 +-- extra/ui/gadgets/buttons/buttons-tests.factor | 2 +- 8 files changed, 42 insertions(+), 29 deletions(-) create mode 100644 core/ascii/ascii-tests.factor diff --git a/core/ascii/ascii-tests.factor b/core/ascii/ascii-tests.factor new file mode 100644 index 0000000000..ec76d89d7c --- /dev/null +++ b/core/ascii/ascii-tests.factor @@ -0,0 +1,15 @@ +IN: temporary +USING: ascii tools.test sequences kernel math ; + +[ t ] [ CHAR: a letter? ] unit-test +[ f ] [ CHAR: A letter? ] unit-test +[ f ] [ CHAR: a LETTER? ] unit-test +[ t ] [ CHAR: A LETTER? ] unit-test +[ t ] [ CHAR: 0 digit? ] unit-test +[ f ] [ CHAR: x digit? ] unit-test + + +[ 4 ] [ + 0 "There are Four Upper Case characters" + [ LETTER? [ 1+ ] when ] each +] unit-test diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index 213f0868c0..b00e8e26b4 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -8,13 +8,13 @@ IN: temporary [ 1 CHAR: a ] [ 0 "abcd" next-char ] unit-test - [ 6 CHAR: \s ] + [ 8 CHAR: \s ] [ 1 "\\u000020hello" next-escape ] unit-test [ 2 CHAR: \n ] [ 1 "\\nhello" next-escape ] unit-test - [ 6 CHAR: \s ] + [ 8 CHAR: \s ] [ 0 "\\u000020hello" next-char ] unit-test [ 1 [ 2 [ 3 ] 4 ] 5 ] diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index e988a62feb..73ae4737ba 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -235,12 +235,12 @@ unit-test [ 11 10 nth ] unit-test-fails [ -1./0. 0 delete-nth ] unit-test-fails -[ "" ] [ "" [ blank? ] trim ] unit-test -[ "" ] [ "" [ blank? ] left-trim ] unit-test -[ "" ] [ "" [ blank? ] right-trim ] unit-test -[ "" ] [ " " [ blank? ] left-trim ] unit-test -[ "" ] [ " " [ blank? ] right-trim ] unit-test -[ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test -[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test -[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test +[ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test +[ "" ] [ " " [ CHAR: \s = ] left-trim ] unit-test +[ "" ] [ " " [ CHAR: \s = ] right-trim ] unit-test +[ "asdf" ] [ " asdf " [ CHAR: \s = ] trim ] unit-test +[ "asdf " ] [ " asdf " [ CHAR: \s = ] left-trim ] unit-test +[ " asdf" ] [ " asdf " [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index a3c49a08ba..5ab7f1dffe 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -28,23 +28,11 @@ IN: temporary [ "end" ] [ "Beginning and end" 14 tail ] unit-test -[ t ] [ CHAR: a letter? ] unit-test -[ f ] [ CHAR: A letter? ] unit-test -[ f ] [ CHAR: a LETTER? ] unit-test -[ t ] [ CHAR: A LETTER? ] unit-test -[ t ] [ CHAR: 0 digit? ] unit-test -[ f ] [ CHAR: x digit? ] unit-test - [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test [ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test -[ 4 ] [ - 0 "There are Four Upper Case characters" - [ LETTER? [ 1+ ] when ] each -] unit-test - [ "Replacing+spaces+with+plus" ] [ "Replacing spaces with plus" @@ -67,6 +55,7 @@ unit-test [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test +! Make sure 24-bit strings work "hello world" "s" set [ ] [ HEX: 1234 1 "s" get set-nth ] unit-test @@ -90,3 +79,12 @@ unit-test ] [ "s" get >array ] unit-test + +! Make sure we clear aux vector when storing octets +[ "\u123456hi" ] [ "ih\u123456" clone dup reverse-here ] unit-test + +! Make sure aux vector is not shared +[ "\udeadbe" ] [ + "\udeadbe" clone + CHAR: \u123456 over clone set-first +] unit-test diff --git a/core/strings/strings.factor b/core/strings/strings.factor index dc1d12cec9..50c75d784e 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -37,7 +37,8 @@ M: string set-nth-unsafe dup reset-string-hashcode >r >fixnum >r >fixnum r> r> set-string-nth ; -M: string clone (clone) ; +M: string clone + (clone) dup string-aux clone over set-string-aux ; M: string resize resize-string ; diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index e49364fad3..8a621f8f48 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -1,6 +1,6 @@ USING: io.files io.sockets io kernel threads namespaces tools.test continuations strings byte-arrays sequences -prettyprint system unicode.case ; +prettyprint system ; IN: temporary ! Unix domain stream sockets @@ -56,7 +56,7 @@ yield "Receive 2" print - "d" get receive >r >upper r> + "d" get receive >r " world" append r> "Send 1" print dup . @@ -98,7 +98,7 @@ client-addr "d" get send ] unit-test -[ "HELLO" t ] [ +[ "hello world" t ] [ "d" get receive server-addr = >r >string r> diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index 8d55cc5770..fc8cec770b 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2005 Chris Double. ! See http://factorcode.org/license.txt for BSD license. -! USING: kernel lazy-lists tools.test strings math -sequences parser-combinators arrays math.parser ; +sequences parser-combinators arrays math.parser unicode.categories ; IN: scratchpad ! Testing <&> diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index a2786ea878..77dfd30d96 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -17,7 +17,7 @@ TUPLE: foo-gadget ; T{ foo-gadget } "t" set [ 2 ] [ "t" get gadget-children length ] unit-test -[ "Foo a" ] [ "t" get gadget-child gadget-child label-string ] unit-test +[ "Foo A" ] [ "t" get gadget-child gadget-child label-string ] unit-test [ ] [ 2 { From 1ee12b512cf3e4149f52a8f454fc755e827591de Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 16:04:41 -0600 Subject: [PATCH 055/317] builder: minor tweaks --- extra/builder/builder.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a2b5dffb4d..4c770ff4ce 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -31,8 +31,6 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: boot-image ( -- filename ) `{ "boot" ,[ cpu ] "image" } "." join ; - : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -61,7 +59,7 @@ if "factor" cd -{ "/usr/bin/git" "show" } +{ "git" "show" } [ readln ] with-stream " " split second "../git-id" [ print ] with-stream @@ -76,7 +74,7 @@ if "builder: vm compile" throw ] if -"wget http://factorcode.org/images/latest/" boot-image append system +"wget http://factorcode.org/images/latest/" boot-image-name append system 0 = [ ] [ @@ -84,7 +82,11 @@ if "builder: image download" throw ] if -[ "./factor -i=" boot-image " -no-user-init > ../boot-log" 3append system ] +[ + "./factor -i=" boot-image-name " -no-user-init > ../boot-log" + 3append + system +] benchmark nip "../boot-time" [ . ] with-stream 0 = From a849bc3097ef5bc7942a0a7b74332274a95c072b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 16:10:18 -0600 Subject: [PATCH 056/317] builder: fix using --- extra/builder/builder.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 4c770ff4ce..a9a4c159f8 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,5 +1,5 @@ -USING: kernel io io.files io.launcher +USING: kernel io io.files io.launcher tools.deploy.backend system namespaces sequences splitting math.parser unix prettyprint tools.time calendar bake vars ; From 27ebd08b99f54c55a5dfb84f3885cdd19d16e4b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 16:21:42 -0600 Subject: [PATCH 057/317] Encodings fix --- core/io/encodings/encodings.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 83ab576faf..5bc679cd27 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -18,7 +18,7 @@ SYMBOL: begin over push 0 begin ; : finish-decoding ( buf ch state -- str ) - begin eq? [ decode-error ] unless drop { } like ; + begin eq? [ decode-error ] unless drop "" like ; : decode ( seq quot -- str ) >r [ length 0 begin ] keep r> each From cef80543ad7504c0c77fdf8b04ab050e92ff0fba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 16:26:11 -0600 Subject: [PATCH 058/317] Fix set-string-nth GC issue --- vm/types.c | 28 +++++++++++++++++++++++++--- 1 file changed, 25 insertions(+), 3 deletions(-) diff --git a/vm/types.c b/vm/types.c index f34f5e57ca..1f0287b1f0 100755 --- a/vm/types.c +++ b/vm/types.c @@ -431,23 +431,30 @@ CELL string_nth(F_STRING* string, CELL index) } } +/* allocates memory */ void set_string_nth(F_STRING* string, CELL index, CELL value) { bput(SREF(string,index),value & 0xff); + F_BYTE_ARRAY *aux; + if(string->aux == F) { if(value <= 0xff) return; else { - string->aux = tag_object(allot_byte_array( + REGISTER_UNTAGGED(string); + aux = allot_byte_array( untag_fixnum_fast(string->length) - * sizeof(u16))); + * sizeof(u16)); + UNREGISTER_UNTAGGED(string); + string->aux = tag_object(aux); } } + else + aux = untag_object(string->aux); - F_BYTE_ARRAY *aux = untag_object(string->aux); cput(BREF(aux,index * sizeof(u16)),value >> 8); } @@ -463,10 +470,13 @@ F_STRING* allot_string_internal(CELL capacity) string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; + set_string_nth(string,capacity,0); + return string; } +/* allocates memory */ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) @@ -476,7 +486,11 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) CELL i; for(i = start; i < capacity; i++) + { + REGISTER_UNTAGGED(string); set_string_nth(string,i,fill); + UNREGISTER_UNTAGGED(string); + } } } @@ -484,7 +498,9 @@ void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) F_STRING *allot_string(CELL capacity, CELL fill) { F_STRING* string = allot_string_internal(capacity); + REGISTER_UNTAGGED(string); fill_string(string,0,capacity,fill); + UNREGISTER_UNTAGGED(string); return string; } @@ -506,7 +522,10 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) UNREGISTER_UNTAGGED(string); memcpy(new_string + 1,string + 1,to_copy); + + REGISTER_UNTAGGED(string); fill_string(new_string,to_copy,capacity,fill); + UNREGISTER_UNTAGGED(string); return new_string; } @@ -529,7 +548,9 @@ DEFINE_PRIMITIVE(resize_string) CELL i; \ for(i = 0; i < length; i++) \ { \ + REGISTER_UNTAGGED(s); \ set_string_nth(s,i,(utype)*string); \ + UNREGISTER_UNTAGGED(s); \ string++; \ } \ return s; \ @@ -552,6 +573,7 @@ DEFINE_PRIMITIVE(resize_string) MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(u16,u16) +// MEMORY_TO_STRING(u32,u32) bool check_string(F_STRING *s, CELL max) { From 7cd7af7bd1e5b684289a0a35ea2a09e5abf16cbe Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 16:43:12 -0600 Subject: [PATCH 059/317] Bug fix in word wrap --- extra/wrap/wrap.factor | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/extra/wrap/wrap.factor b/extra/wrap/wrap.factor index 4392ac81a6..41dea1bd13 100644 --- a/extra/wrap/wrap.factor +++ b/extra/wrap/wrap.factor @@ -12,15 +12,17 @@ SYMBOL: width : (split-chunk) ( words -- ) -1 over [ length + 1+ dup width get > ] find drop nip - [ cut-slice swap , (split-chunk) ] [ , ] if* ; + [ 1 max cut-slice swap , (split-chunk) ] [ , ] if* ; : split-chunk ( words -- lines ) [ (split-chunk) ] { } make ; +: join-spaces ( words-seqs -- lines ) + [ [ " " join ] map ] map concat ; + : broken-lines ( string width -- lines ) width [ - line-chunks - [ split-chunk [ " " join ] map ] map concat + line-chunks [ split-chunk ] map join-spaces ] with-variable ; : line-break ( string width -- newstring ) From f710d192f7e14ab4037ad35ef0269d95534bf627 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:13:57 -0600 Subject: [PATCH 060/317] Fix inaccurate notifications in io.monitor on Windows --- extra/io/monitor/monitor-docs.factor | 33 ++++++++++------------ extra/io/monitor/monitor.factor | 9 +++--- extra/io/windows/launcher/launcher.factor | 11 ++++++-- extra/io/windows/nt/monitor/monitor.factor | 32 ++++++++------------- extra/windows/kernel32/kernel32.factor | 6 ++++ 5 files changed, 46 insertions(+), 45 deletions(-) diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitor/monitor-docs.factor index 56fd203bde..de649f48e7 100755 --- a/extra/io/monitor/monitor-docs.factor +++ b/extra/io/monitor/monitor-docs.factor @@ -8,35 +8,32 @@ $nl "Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; HELP: next-change -{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a sequence of change descriptors" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence containing at least one change descriptor; see " { $link "io.monitor.descriptors" } "." } ; +{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } { $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; -HELP: +change-file+ -{ $description "Indicates that the contents of the file have changed." } ; +HELP: +add-file+ +{ $description "Indicates that the file has been added to the directory." } ; -HELP: +change-name+ -{ $description "Indicates that the file name has changed." } ; +HELP: +remove-file+ +{ $description "Indicates that the file has been removed from the directory." } ; -HELP: +change-size+ -{ $description "Indicates that the file size has changed." } ; +HELP: +modify-file+ +{ $description "Indicates that the file contents have changed." } ; -HELP: +change-attributes+ -{ $description "Indicates that file attributes has changed. Attributes are operating system-specific but may include the creation time and permissions." } ; - -HELP: +change-modified+ -{ $description "Indicates that the last modification time of the file has changed." } ; +HELP: +rename-file+ +{ $description "Indicates that file has been renamed." } ; ARTICLE: "io.monitor.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" -{ $subsection +change-file+ } -{ $subsection +change-name+ } -{ $subsection +change-size+ } -{ $subsection +change-attributes+ } -{ $subsection +change-modified+ } ; +{ $subsection +add-file+ } +{ $subsection +remove-file+ } +{ $subsection +modify-file+ } +{ $subsection +rename-file+ } +{ $subsection +add-file+ } ; ARTICLE: "io.monitor" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 044fa9572b..4dc5081513 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -7,11 +7,10 @@ HOOK: io-backend ( path recursive? -- monitor ) HOOK: next-change io-backend ( monitor -- path changes ) -SYMBOL: +change-file+ -SYMBOL: +change-name+ -SYMBOL: +change-size+ -SYMBOL: +change-attributes+ -SYMBOL: +change-modified+ +SYMBOL: +add-file+ +SYMBOL: +remove-file+ +SYMBOL: +modify-file+ +SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 8f1d1c6756..ec53d9152c 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -119,8 +119,15 @@ TUPLE: CreateProcess-args drop STD_ERROR_HANDLE GetStdHandle ; : redirect-stderr ( args -- handle ) - +stderr+ get GENERIC_WRITE CREATE_ALWAYS redirect - swap inherited-stderr ?closed ; + +stderr+ get + dup +stdout+ eq? [ + drop + CreateProcess-args-lpStartupInfo + STARTUPINFO-hStdOutput + ] [ + GENERIC_WRITE CREATE_ALWAYS redirect + swap inherited-stderr ?closed + ] if ; : inherited-stdin ( args -- handle ) CreateProcess-args-stdin-pipe diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index a7c065b878..8e0e63923d 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -4,7 +4,7 @@ USING: alien.c-types destructors io.windows io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations io.monitor io.nonblocking io.buffers io.files io sequences -hashtables sorting arrays ; +hashtables sorting arrays combinators ; IN: io.windows.nt.monitor TUPLE: monitor path recursive? queue closed? ; @@ -53,25 +53,17 @@ M: windows-nt-io ( path recursive? -- monitor ) ] with-port-timeout ] with-destructors ; -: parse-action-flag ( action mask symbol -- action ) - >r over bitand 0 > [ r> , ] [ r> drop ] if ; +: parse-action ( action -- changed ) + { + { [ dup FILE_ACTION_ADDED = ] [ +add-file+ ] } + { [ dup FILE_ACTION_REMOVED = ] [ +remove-file+ ] } + { [ dup FILE_ACTION_MODIFIED = ] [ +modify-file+ ] } + { [ dup FILE_ACTION_RENAMED_OLD_NAME = ] [ +rename-file+ ] } + { [ dup FILE_ACTION_RENAMED_NEW_NAME = ] [ +rename-file+ ] } + { [ t ] [ +modify-file+ ] } + } cond nip ; -: parse-action ( action -- changes ) - [ - FILE_NOTIFY_CHANGE_FILE +change-file+ parse-action-flag - FILE_NOTIFY_CHANGE_DIR_NAME +change-name+ parse-action-flag - FILE_NOTIFY_CHANGE_ATTRIBUTES +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_SIZE +change-size+ parse-action-flag - FILE_NOTIFY_CHANGE_LAST_WRITE +change-modified+ parse-action-flag - FILE_NOTIFY_CHANGE_LAST_ACCESS +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_EA +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_CREATION +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_SECURITY +change-attributes+ parse-action-flag - FILE_NOTIFY_CHANGE_FILE_NAME +change-name+ parse-action-flag - drop - ] { } make ; - -: changed-file ( directory buffer -- changes path ) +: changed-file ( directory buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength @@ -79,7 +71,7 @@ M: windows-nt-io ( path recursive? -- monitor ) } get-slots >r memory>u16-string path+ r> parse-action swap ; : (changed-files) ( directory buffer -- ) - 2dup changed-file namespace [ append ] change-at + 2dup changed-file namespace [ swap add ] change-at dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 3drop ] [ swap (changed-files) ] if ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 15bdcd3e37..77c7666bfd 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -83,6 +83,12 @@ IN: windows.kernel32 : FILE_NOTIFY_CHANGE_FILE_NAME HEX: 200 ; inline : FILE_NOTIFY_CHANGE_ALL HEX: 3ff ; inline +: FILE_ACTION_ADDED 1 ; inline +: FILE_ACTION_REMOVED 2 ; inline +: FILE_ACTION_MODIFIED 3 ; inline +: FILE_ACTION_RENAMED_OLD_NAME 4 ; inline +: FILE_ACTION_RENAMED_NEW_NAME 5 ; inline + C-STRUCT: FILE_NOTIFY_INFORMATION { "DWORD" "NextEntryOffset" } { "DWORD" "Action" } From 3917a9472a4f8ee66f145e1de5c60cc3e45919d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:14:10 -0600 Subject: [PATCH 061/317] Implement default_vm_path() on netbsd --- vm/os-netbsd.c | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) mode change 100644 => 100755 vm/os-netbsd.c diff --git a/vm/os-netbsd.c b/vm/os-netbsd.c old mode 100644 new mode 100755 index b9238b7877..c33b4ad69c --- a/vm/os-netbsd.c +++ b/vm/os-netbsd.c @@ -1,6 +1,11 @@ #include "master.h" +extern int main(); + const char *vm_executable_path(void) { - return NULL; + static Dl_info info = {0}; + if (!info.dli_fname) + dladdr(main, &info); + return info.dli_fname; } From 71358d3c4aef7bc4946d5655889de2b895152dea Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 17:43:44 -0600 Subject: [PATCH 062/317] first commit of db stuff --- extra/db/db.factor | 96 ++++++ extra/db/postgresql/authors.txt | 1 + extra/db/postgresql/ffi/ffi.factor | 360 ++++++++++++++++++++ extra/db/postgresql/lib/lib.factor | 72 ++++ extra/db/postgresql/postgresql-tests.factor | 54 +++ extra/db/postgresql/postgresql.factor | 87 +++++ extra/db/sqlite/authors.txt | 2 + extra/db/sqlite/ffi/ffi.factor | 131 +++++++ extra/db/sqlite/lib/lib.factor | 103 ++++++ extra/db/sqlite/sqlite-tests.factor | 99 ++++++ extra/db/sqlite/sqlite.factor | 70 ++++ extra/db/sqlite/test.txt | 3 + 12 files changed, 1078 insertions(+) create mode 100644 extra/db/db.factor create mode 100644 extra/db/postgresql/authors.txt create mode 100644 extra/db/postgresql/ffi/ffi.factor create mode 100644 extra/db/postgresql/lib/lib.factor create mode 100644 extra/db/postgresql/postgresql-tests.factor create mode 100644 extra/db/postgresql/postgresql.factor create mode 100644 extra/db/sqlite/authors.txt create mode 100644 extra/db/sqlite/ffi/ffi.factor create mode 100644 extra/db/sqlite/lib/lib.factor create mode 100644 extra/db/sqlite/sqlite-tests.factor create mode 100644 extra/db/sqlite/sqlite.factor create mode 100644 extra/db/sqlite/test.txt diff --git a/extra/db/db.factor b/extra/db/db.factor new file mode 100644 index 0000000000..597ac1f0f3 --- /dev/null +++ b/extra/db/db.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays assocs classes continuations kernel math +namespaces sequences sequences.lib tuples words ; +IN: db + +TUPLE: db handle ; +C: db ( handle -- obj ) + +! HOOK: db-create db ( str -- ) +! HOOK: db-drop db ( str -- ) +GENERIC: db-open ( db -- ) +GENERIC: db-close ( db -- ) + +TUPLE: statement sql params handle bound? n max ; + +TUPLE: simple-statement ; +TUPLE: bound-statement ; +TUPLE: prepared-statement ; +TUPLE: prepared-bound-statement ; + +HOOK: db ( str -- statement ) +HOOK: db ( str obj -- statement ) +HOOK: db ( str -- statement ) +HOOK: db ( str obj -- statement ) + +! TUPLE: result sql params handle n max ; + +GENERIC: #rows ( statement -- n ) +GENERIC: #columns ( statement -- n ) +GENERIC# row-column 1 ( statement n -- obj ) +GENERIC: advance-row ( statement -- ? ) + +GENERIC: prepare-statement ( statement -- ) +GENERIC: reset-statement ( statement -- ) +GENERIC: bind-statement* ( obj statement -- ) +GENERIC: rebind-statement ( obj statement -- ) + +: bind-statement ( obj statement -- ) + 2dup dup statement-bound? [ + rebind-statement + ] [ + bind-statement* + ] if + tuck set-statement-params + t swap set-statement-bound? ; + +: sql-row ( statement -- seq ) + dup #columns [ row-column ] with map ; + +: query-each ( statement quot -- ) + over advance-row [ + 2drop + ] [ + [ call ] 2keep query-each + ] if ; inline + +: query-map ( statement quot -- seq ) + accumulator >r query-each r> { } like ; inline + +: with-db ( db quot -- ) + [ + over db-open + [ db swap with-variable ] curry with-disposal + ] with-scope ; + +: do-statement ( statement -- ) + [ advance-row drop ] with-disposal ; + +: do-query ( query -- rows ) + [ [ sql-row ] query-map ] with-disposal ; + +: do-simple-query ( sql -- rows ) + do-query ; + +: do-bound-query ( sql obj -- rows ) + do-query ; + +: do-simple-command ( sql -- ) + do-statement ; + +: do-bound-command ( sql obj -- ) + do-statement ; + +SYMBOL: in-transaction +HOOK: begin-transaction db ( -- ) +HOOK: commit-transaction db ( -- ) +HOOK: rollback-transaction db ( -- ) + +: in-transaction? ( -- ? ) in-transaction get ; + +: with-transaction ( quot -- ) + t in-transaction [ + begin-transaction + [ ] [ rollback-transaction ] cleanup commit-transaction + ] with-variable ; diff --git a/extra/db/postgresql/authors.txt b/extra/db/postgresql/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/db/postgresql/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor new file mode 100644 index 0000000000..6d3cdfc468 --- /dev/null +++ b/extra/db/postgresql/ffi/ffi.factor @@ -0,0 +1,360 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. + +! adapted from libpq-fe.h version 7.4.7 +! tested on debian linux with postgresql 7.4.7 +! Updated to 8.1 + +USING: alien alien.syntax combinators system ; +IN: db.postgresql.ffi + +<< +"postgresql" { + { [ win32? ] [ "libpq.dll" ] } + { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] } + { [ unix? ] [ "libpq.so" ] } +} cond "cdecl" add-library +>> + +! ConnSatusType +: CONNECTION_OK HEX: 0 ; inline +: CONNECTION_BAD HEX: 1 ; inline +: CONNECTION_STARTED HEX: 2 ; inline +: CONNECTION_MADE HEX: 3 ; inline +: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline +: CONNECTION_AUTH_OK HEX: 5 ; inline +: CONNECTION_SETENV HEX: 6 ; inline +: CONNECTION_SSL_STARTUP HEX: 7 ; inline +: CONNECTION_NEEDED HEX: 8 ; inline + +! PostgresPollingStatusType +: PGRES_POLLING_FAILED HEX: 0 ; inline +: PGRES_POLLING_READING HEX: 1 ; inline +: PGRES_POLLING_WRITING HEX: 2 ; inline +: PGRES_POLLING_OK HEX: 3 ; inline +: PGRES_POLLING_ACTIVE HEX: 4 ; inline + +! ExecStatusType; +: PGRES_EMPTY_QUERY HEX: 0 ; inline +: PGRES_COMMAND_OK HEX: 1 ; inline +: PGRES_TUPLES_OK HEX: 2 ; inline +: PGRES_COPY_OUT HEX: 3 ; inline +: PGRES_COPY_IN HEX: 4 ; inline +: PGRES_BAD_RESPONSE HEX: 5 ; inline +: PGRES_NONFATAL_ERROR HEX: 6 ; inline +: PGRES_FATAL_ERROR HEX: 7 ; inline + +! PGTransactionStatusType; +: PQTRANS_IDLE HEX: 0 ; inline +: PQTRANS_ACTIVE HEX: 1 ; inline +: PQTRANS_INTRANS HEX: 2 ; inline +: PQTRANS_INERROR HEX: 3 ; inline +: PQTRANS_UNKNOWN HEX: 4 ; inline + +! PGVerbosity; +: PQERRORS_TERSE HEX: 0 ; inline +: PQERRORS_DEFAULT HEX: 1 ; inline +: PQERRORS_VERBOSE HEX: 2 ; inline + + +TYPEDEF: int size_t +TYPEDEF: int ConnStatusType +TYPEDEF: int ExecStatusType +TYPEDEF: int PostgresPollingStatusType +TYPEDEF: int PGTransactionStatusType +TYPEDEF: int PGVerbosity + +TYPEDEF: void* PGconn* +TYPEDEF: void* PGresult* +TYPEDEF: void* PGcancel* +TYPEDEF: uint Oid +TYPEDEF: uint* Oid* +TYPEDEF: char pqbool +TYPEDEF: void* PQconninfoOption* +TYPEDEF: void* PGnotify* +TYPEDEF: void* PQArgBlock* +TYPEDEF: void* PQprintOpt* +TYPEDEF: void* FILE* +TYPEDEF: void* SSL* + +LIBRARY: postgresql + + +! Exported functions of libpq +! === in fe-connect.c === + +! make a new client connection to the backend +! Asynchronous (non-blocking) +FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ; +FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ; + +! Synchronous (blocking) +FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ; +FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport, + char* pgoptions, char* pgtty, + char* dbName, + char* login, char* pwd ) ; + +: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* ) + f f PQsetdbLogin ; + +! close the current connection and free the PGconn data structure +FUNCTION: void PQfinish ( PGconn* conn ) ; + +! get info about connection options known to PQconnectdb +FUNCTION: PQconninfoOption* PQconndefaults ( ) ; + +! free the data structure returned by PQconndefaults() +FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ; + +! +! close the current connection and restablish a new one with the same +! parameters +! +! Asynchronous (non-blocking) +FUNCTION: int PQresetStart ( PGconn* conn ) ; +FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ; + +! Synchronous (blocking) +FUNCTION: void PQreset ( PGconn* conn ) ; + +! request a cancel structure +FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ; + +! free a cancel structure +FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ; + +! issue a cancel request +FUNCTION: int PQrequestCancel ( PGconn* conn ) ; + +! Accessor functions for PGconn objects +FUNCTION: char* PQdb ( PGconn* conn ) ; +FUNCTION: char* PQuser ( PGconn* conn ) ; +FUNCTION: char* PQpass ( PGconn* conn ) ; +FUNCTION: char* PQhost ( PGconn* conn ) ; +FUNCTION: char* PQport ( PGconn* conn ) ; +FUNCTION: char* PQtty ( PGconn* conn ) ; +FUNCTION: char* PQoptions ( PGconn* conn ) ; +FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ; +FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ; +FUNCTION: char* PQparameterStatus ( PGconn* conn, + char* paramName ) ; +FUNCTION: int PQprotocolVersion ( PGconn* conn ) ; +! FUNCTION: int PQServerVersion ( PGconn* conn ) ; +FUNCTION: char* PQerrorMessage ( PGconn* conn ) ; +FUNCTION: int PQsocket ( PGconn* conn ) ; +FUNCTION: int PQbackendPID ( PGconn* conn ) ; +FUNCTION: int PQclientEncoding ( PGconn* conn ) ; +FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ; + +! May not be compiled into libpq +! Get the SSL structure associated with a connection +FUNCTION: SSL* PQgetssl ( PGconn* conn ) ; + +! Tell libpq whether it needs to initialize OpenSSL +FUNCTION: void PQinitSSL ( int do_init ) ; + +! Set verbosity for PQerrorMessage and PQresultErrorMessage +FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn, + PGVerbosity verbosity ) ; + +! Enable/disable tracing +FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ; +FUNCTION: void PQuntrace ( PGconn* conn ) ; + +! BROKEN +! Function types for notice-handling callbacks +! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res); +! typedef void (*PQnoticeProcessor) (void *arg, char* message); +! ALIAS: void* PQnoticeReceiver +! ALIAS: void* PQnoticeProcessor + +! Override default notice handling routines +! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn, + ! PQnoticeReceiver proc, + ! void* arg ) ; +! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn, + ! PQnoticeProcessor proc, + ! void* arg ) ; +! END BROKEN + +! === in fe-exec.c === + +! Simple synchronous query +FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ; +FUNCTION: PGresult* PQexecParams ( PGconn* conn, + char* command, + int nParams, + Oid* paramTypes, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; +FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName, + char* query, int nParams, + Oid* paramTypes ) ; +FUNCTION: PGresult* PQexecPrepared ( PGconn* conn, + char* stmtName, + int nParams, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; + +! Interface for multiple-result or asynchronous queries +FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ; +FUNCTION: int PQsendQueryParams ( PGconn* conn, + char* command, + int nParams, + Oid* paramTypes, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; +FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName, + char* query, int nParams, + Oid* paramTypes ) ; +FUNCTION: int PQsendQueryPrepared ( PGconn* conn, + char* stmtName, + int nParams, + char** paramValues, + int *paramLengths, + int *paramFormats, + int resultFormat ) ; +FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ; + +! Routines for managing an asynchronous query +FUNCTION: int PQisBusy ( PGconn* conn ) ; +FUNCTION: int PQconsumeInput ( PGconn* conn ) ; + +! LISTEN/NOTIFY support +FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ; + +! Routines for copy in/out +FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ; +FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ; +FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ; + +! Deprecated routines for copy in/out +FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ; +FUNCTION: int PQputline ( PGconn* conn, char* string ) ; +FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ; +FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ; +FUNCTION: int PQendcopy ( PGconn* conn ) ; + +! Set blocking/nonblocking connection to the backend +FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ; +FUNCTION: int PQisnonblocking ( PGconn* conn ) ; + +! Force the write buffer to be written (or at least try) +FUNCTION: int PQflush ( PGconn* conn ) ; + +! +! * "Fast path" interface --- not really recommended for application +! * use +! +FUNCTION: PGresult* PQfn ( PGconn* conn, + int fnid, + int* result_buf, + int* result_len, + int result_is_int, + PQArgBlock* args, + int nargs ) ; + +! Accessor functions for PGresult objects +FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ; +FUNCTION: char* PQresStatus ( ExecStatusType status ) ; +FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ; +FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ; +FUNCTION: int PQntuples ( PGresult* res ) ; +FUNCTION: int PQnfields ( PGresult* res ) ; +FUNCTION: int PQbinaryTuples ( PGresult* res ) ; +FUNCTION: char* PQfname ( PGresult* res, int field_num ) ; +FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ; +FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ; +FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ; +FUNCTION: int PQfformat ( PGresult* res, int field_num ) ; +FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ; +FUNCTION: int PQfsize ( PGresult* res, int field_num ) ; +FUNCTION: int PQfmod ( PGresult* res, int field_num ) ; +FUNCTION: char* PQcmdStatus ( PGresult* res ) ; +FUNCTION: char* PQoidStatus ( PGresult* res ) ; +FUNCTION: Oid PQoidValue ( PGresult* res ) ; +FUNCTION: char* PQcmdTuples ( PGresult* res ) ; +FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; + +! Delete a PGresult +FUNCTION: void PQclear ( PGresult* res ) ; + +! For freeing other alloc'd results, such as PGnotify structs +FUNCTION: void PQfreemem ( void* ptr ) ; + +! Exists for backward compatibility. +: PQfreeNotify PQfreemem ; + +! +! Make an empty PGresult with given status (some apps find this +! useful). If conn is not NULL and status indicates an error, the +! conn's errorMessage is copied. +! +FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ; + +! Quoting strings before inclusion in queries. +FUNCTION: size_t PQescapeStringConn ( PGconn* conn, + char* to, char* from, size_t length, + int* error ) ; +FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn, + char* from, size_t length, + size_t* to_length ) ; +FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, + size_t* retbuflen ) ; +! These forms are deprecated! +FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ; +FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen, + size_t* bytealen ) ; + +! === in fe-print.c === + +FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ; + +! really old printing routines +FUNCTION: void PQdisplayTuples ( PGresult* res, + FILE* fp, + int fillAlign, + char* fieldSep, + int printHeader, + int quiet ) ; + +FUNCTION: void PQprintTuples ( PGresult* res, + FILE* fout, + int printAttName, + int terseOutput, + int width ) ; + +! === in fe-lobj.c === + +! Large-object access routines +FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ; +FUNCTION: int lo_close ( PGconn* conn, int fd ) ; +FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ; +FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ; +FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ; +FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ; +! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ; +FUNCTION: int lo_tell ( PGconn* conn, int fd ) ; +FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ; +FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ; +FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ; + +! === in fe-misc.c === + +! Determine length of multibyte encoded char at *s +FUNCTION: int PQmblen ( uchar* s, int encoding ) ; + +! Determine display length of multibyte encoded char at *s +FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; + +! Get encoding id from environment variable PGCLIENTENCODING +FUNCTION: int PQenv2encoding ( ) ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor new file mode 100644 index 0000000000..4b362f9931 --- /dev/null +++ b/extra/db/postgresql/lib/lib.factor @@ -0,0 +1,72 @@ +USING: arrays continuations db io kernel math namespaces +quotations sequences db.postgresql.ffi ; +IN: db.postgresql.lib + +SYMBOL: query-res + +: connect-postgres ( host port pgopts pgtty db user pass -- conn ) + PQsetdbLogin + dup PQstatus zero? [ "couldn't connect to database" throw ] unless ; + +: postgresql-result-error-message ( res -- str/f ) + dup zero? [ + drop f + ] [ + PQresultErrorMessage [ CHAR: \n = ] right-trim + ] if ; + +: postgres-result-error ( res -- ) + postgresql-result-error-message [ throw ] when* ; + +: postgresql-error-message ( -- str ) + db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ; + +: postgresql-error ( res -- res ) + dup [ postgresql-error-message throw ] unless ; + +: postgresql-result-ok? ( n -- ? ) + PQresultStatus + PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; + +: do-postgresql-statement ( statement -- res ) + db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ + dup postgresql-result-error-message swap PQclear throw + ] unless ; + +! : do-command ( str -- ) + ! 1quotation \ (do-command) add db get swap call ; + +! : prepare ( str quot word -- conn quot ) + ! rot 1quotation swap append swap append db get swap ; + +! : do-query ( str quot -- ) + ! [ (do-query) query-res set ] prepare catch + ! [ rethrow ] [ query-res get PQclear ] if* ; + +! : result>seq ( -- seq ) + ! query-res get [ PQnfields ] keep PQntuples + ! [ swap [ query-res get -rot PQgetvalue ] with map ] with map ; +! +! : print-table ( seq -- ) + ! [ [ write bl ] each "\n" write ] each ; + + + +! select * from animal where name = 'Simba' +! select * from animal where name = $1 + +! : (do-query) ( PGconn query -- PGresult* ) + ! ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK + ! ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK + ! PQexec dup postgresql-result-ok? [ + ! dup postgresql-error-message swap PQclear throw + ! ] unless ; + +! : (do-command) ( PGconn query -- PGresult* ) + ! [ (do-query) ] catch + ! [ + ! swap + ! "non-fatal error: " print + ! "\tQuery: " write "'" write write "'" print + ! "\t" write print + ! ] when* drop ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor new file mode 100644 index 0000000000..438a80e2d8 --- /dev/null +++ b/extra/db/postgresql/postgresql-tests.factor @@ -0,0 +1,54 @@ +! You will need to run 'createdb factor-test' to create the database. +! Set username and password in the 'connect' word. + +USING: kernel db.postgresql alien continuations io prettyprint +sequences namespaces tools.test ; +IN: temporary + +: test-connection ( host port pgopts pgtty db user pass -- bool ) + [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ; + +[ ] [ "localhost" "" "" "" "factor-test" "postgres" "" test-connection ] unit-test + +[ ] [ "localhost" "postgres" "" "factor-test" [ ] with-db ] unit-test + +! just a basic demo + +"localhost" "postgres" "" "factor-test" [ + [ ] [ "drop table animal" do-command ] unit-test + + [ ] [ "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command ] unit-test + + [ ] [ "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" + do-command ] unit-test + + [ ] [ "select * from animal where name = 'Mufasa'" [ ] do-query ] unit-test + [ ] [ "select * from animal where name = 'Mufasa'" [ + result>seq length 1 = [ + "...there can only be one Mufasa..." throw + ] unless + ] do-query + ] unit-test + + [ ] [ "insert into animal (species, name, age) values ('lion', 'Simba', 1)" + do-command ] unit-test + + [ ] [ + "select * from animal" + [ + "Animal table:" print + result>seq print-table + ] do-query + ] unit-test + + ! intentional errors + ! [ "select asdf from animal" + ! [ ] do-query ] catch [ "caught: " write print ] when* + ! "select asdf from animal" [ ] do-query + ! "aofijweafew" do-command +] with-db + + +"localhost" "postgres" "" "factor-test" [ + [ ] [ "drop table animal" do-command ] unit-test +] with-db diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor new file mode 100644 index 0000000000..cd2c34682e --- /dev/null +++ b/extra/db/postgresql/postgresql.factor @@ -0,0 +1,87 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! adapted from libpq-fe.h version 7.4.7 +! tested on debian linux with postgresql 7.4.7 + +USING: arrays assocs alien alien.syntax continuations io +kernel math namespaces prettyprint quotations +sequences debugger db db.postgresql.lib db.postgresql.ffi ; +IN: db.postgresql + +TUPLE: postgresql-db host port pgopts pgtty db user pass ; +TUPLE: postgresql-statement ; +: ( statement -- postgresql-statement ) + postgresql-statement construct-delegate ; + +: ( host user pass db -- obj ) + { + set-postgresql-db-host + set-postgresql-db-user + set-postgresql-db-pass + set-postgresql-db-db + } postgresql-db construct ; + +M: postgresql-db db-open ( db -- ) + dup { + postgresql-db-host + postgresql-db-port + postgresql-db-pgopts + postgresql-db-pgtty + postgresql-db-db + postgresql-db-user + postgresql-db-pass + } get-slots connect-postgres swap set-delegate ; + +M: postgresql-db dispose ( db -- ) + db-handle PQfinish ; + +: with-postgresql ( host ust pass db quot -- ) + >r r> with-disposal ; + +M: postgresql-statement #rows ( statement -- n ) + statement-handle PQntuples ; + +M: postgresql-statement #columns ( statement -- n ) + statement-handle PQnfields ; + +M: postgresql-statement row-column ( statement n -- obj ) + >r dup statement-handle swap statement-n r> PQgetvalue ; + +: init-statement ( statement -- ) + dup statement-max [ + dup do-postgresql-statement over set-statement-handle + dup #rows over set-statement-max + -1 over set-statement-n + ] unless drop ; + +: increment-n ( statement -- n ) + dup statement-n 1+ dup rot set-statement-n ; + +M: postgresql-statement advance-row ( statement -- ? ) + dup init-statement + dup increment-n swap statement-max >= ; + +M: postgresql-statement dispose ( query -- ) + dup statement-handle PQclear + 0 0 rot { set-statement-n set-statement-max } set-slots ; + +M: postgresql-statement prepare-statement ( statement -- ) + [ + >r db get db-handle "" r> + dup statement-sql swap statement-params + dup assoc-size swap PQprepare postgresql-error + ] keep set-statement-handle ; + +M: postgresql-db ( sql -- statement ) + { set-statement-sql } statement construct + ; + +M: postgresql-db ( sql array -- statement ) + { set-statement-sql set-statement-params } statement construct + ; + +M: postgresql-db ( sql -- statement ) + ; + +M: postgresql-db ( sql seq -- statement ) + ; diff --git a/extra/db/sqlite/authors.txt b/extra/db/sqlite/authors.txt new file mode 100644 index 0000000000..26093b451b --- /dev/null +++ b/extra/db/sqlite/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Doug Coleman diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor new file mode 100644 index 0000000000..77a86a8a2d --- /dev/null +++ b/extra/db/sqlite/ffi/ffi.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2005 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! +! An interface to the sqlite database. Tested against sqlite v3.1.3. + +! Not all functions have been wrapped yet. Only those directly involving +! executing SQL calls and obtaining results. + +USING: alien compiler kernel math namespaces sequences strings alien.syntax + system combinators ; +IN: db.sqlite.ffi + +<< + "sqlite" { + { [ winnt? ] [ "sqlite3.dll" ] } + { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } + { [ unix? ] [ "libsqlite3.so" ] } + } cond "cdecl" add-library >> + +! Return values from sqlite functions +: SQLITE_OK 0 ; inline ! Successful result +: SQLITE_ERROR 1 ; inline ! SQL error or missing database +: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite +: SQLITE_PERM 3 ; inline ! Access permission denied +: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort +: SQLITE_BUSY 5 ; inline ! The database file is locked +: SQLITE_LOCKED 6 ; inline ! A table in the database is locked +: SQLITE_NOMEM 7 ; inline ! A malloc() failed +: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database +: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() +: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred +: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed +: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found +: SQLITE_FULL 13 ; inline ! Insertion failed because database is full +: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file +: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error +: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty +: SQLITE_SCHEMA 17 ; inline ! The database schema changed +: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table +: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation +: SQLITE_MISMATCH 20 ; inline ! Data type mismatch +: SQLITE_MISUSE 21 ; inline ! Library used incorrectly +: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host +: SQLITE_AUTH 23 ; inline ! Authorization denied +: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error +: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range +: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file + +: sqlite-error-messages ( -- seq ) { + "Successful result" + "SQL error or missing database" + "An internal logic error in SQLite" + "Access permission denied" + "Callback routine requested an abort" + "The database file is locked" + "A table in the database is locked" + "A malloc() failed" + "Attempt to write a readonly database" + "Operation terminated by sqlite_interrupt()" + "Some kind of disk I/O error occurred" + "The database disk image is malformed" + "(Internal Only) Table or record not found" + "Insertion failed because database is full" + "Unable to open the database file" + "Database lock protocol error" + "(Internal Only) Database table is empty" + "The database schema changed" + "Too much data for one row of a table" + "Abort due to contraint violation" + "Data type mismatch" + "Library used incorrectly" + "Uses OS features not supported on host" + "Authorization denied" + "Auxiliary database format error" + "2nd parameter to sqlite3_bind out of range" + "File opened that is not a database file" +} ; + +: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready +: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing + +! Return values from the sqlite3_column_type function +: SQLITE_INTEGER 1 ; inline +: SQLITE_FLOAT 2 ; inline +: SQLITE_TEXT 3 ; inline +: SQLITE_BLOB 4 ; inline +: SQLITE_NULL 5 ; inline + +! Values for the 'destructor' parameter of the 'bind' routines. +: SQLITE_STATIC 0 ; inline +: SQLITE_TRANSIENT -1 ; inline + +: SQLITE_OPEN_READONLY HEX: 00000001 ; inline +: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline +: SQLITE_OPEN_CREATE HEX: 00000004 ; inline +: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline +: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline +: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline +: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline +: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline +: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline +: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline +: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline +: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline + + +TYPEDEF: void sqlite3 +TYPEDEF: void sqlite3_stmt + +LIBRARY: sqlite +FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; +FUNCTION: int sqlite3_open_v2 ( char* filename, void* ppDb, int flags, char* zVfs ) ; +FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; +FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; +FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; +FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; +FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; +FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; +FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; +FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; +FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; +FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; +FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor new file mode 100644 index 0000000000..99cd9c1b9f --- /dev/null +++ b/extra/db/sqlite/lib/lib.factor @@ -0,0 +1,103 @@ +USING: alien.c-types assocs kernel math math.parser sequences +db.sqlite.ffi ; +IN: db.sqlite.lib + +TUPLE: sqlite-error n message ; + +: sqlite-check-result ( result -- ) + dup SQLITE_OK = [ + drop + ] [ + dup sqlite-error-messages nth + sqlite-error construct-boa throw + ] if ; + +: sqlite-open ( filename -- db ) + "void*" + [ sqlite3_open sqlite-check-result ] keep *void* ; + +: sqlite-close ( db -- ) + sqlite3_close sqlite-check-result ; + +: sqlite-last-insert-rowid ( db -- rowid ) + sqlite3_last_insert_rowid ; + +: sqlite-prepare ( db sql -- statement ) + #! TODO: Support multiple statements in the SQL string. + dup length "void*" "void*" + [ sqlite3_prepare sqlite-check-result ] 2keep + drop *void* ; + +: sqlite-bind-text ( statement index text -- ) + dup number? [ number>string ] when + dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; + +: sqlite-bind-parameter-index ( statement name -- index ) + sqlite3_bind_parameter_index ; + +: sqlite-bind-text-by-name ( statement name text -- ) + >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; + +: sqlite-bind-assoc ( statement assoc -- ) + swap [ + -rot sqlite-bind-text-by-name + ] curry assoc-each ; + +: sqlite-finalize ( statement -- ) + sqlite3_finalize sqlite-check-result ; + +: sqlite-reset ( statement -- ) + sqlite3_reset sqlite-check-result ; + +: sqlite-#columns ( query -- int ) + sqlite3_column_count ; + +: sqlite-column ( statement index -- string ) + sqlite3_column_text ; + +: sqlite-row ( statement -- seq ) + dup sqlite-#columns [ sqlite-column ] with map ; + +! 2dup sqlite3_column_type . +! SQLITE_INTEGER 1 +! SQLITE_FLOAT 2 +! SQLITE_TEXT 3 +! SQLITE_BLOB 4 +! SQLITE_NULL 5 + + +: step-complete? ( step-result -- bool ) + dup SQLITE_ROW = [ + drop f + ] [ + dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if + ] if ; + +: sqlite-step ( prepared -- ) + dup sqlite3_step step-complete? [ + drop + ] [ + sqlite-step + ] if ; + +: sqlite-next ( prepared -- ) + sqlite3_step step-complete? ; + +: sqlite-each ( statement quot -- ) + over sqlite3_step step-complete? [ + 2drop + ] [ + [ call ] 2keep sqlite-each + ] if ; inline + +DEFER: (sqlite-map) + +: (sqlite-map) ( statement quot seq -- ) + pick sqlite3_step step-complete? [ + 2nip + ] [ + >r 2dup call r> swap add (sqlite-map) + ] if ; + +: sqlite-map ( statement quot -- seq ) + { } (sqlite-map) ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor new file mode 100644 index 0000000000..79e967de24 --- /dev/null +++ b/extra/db/sqlite/sqlite-tests.factor @@ -0,0 +1,99 @@ +USING: io io.files io.launcher kernel namespaces +prettyprint tools.test db.sqlite db db.sql sequences +continuations ; +IN: temporary + +! "sqlite3 -init test.txt test.db" + +: test.db "extra/db/sqlite/test.db" resource-path ; + +: (create-db) ( -- str ) + [ + "sqlite3 -init " % + "extra/db/sqlite/test.txt" resource-path % + " " % + test.db % + ] "" make ; + +: create-db ( -- ) (create-db) run-process drop ; + +[ ] [ test.db delete-file ] unit-test + +[ ] [ create-db ] unit-test + +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + } +] [ test.db [ "select * from person" do-simple-query ] with-sqlite ] unit-test + +[ + { { "John" "America" } } +] [ + test.db [ + "select * from person where name = :name and country = :country" + { { ":name" "Jane" } { ":country" "New Zealand" } } + dup [ sql-row ] query-map + + { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless + { { ":name" "John" } { ":country" "America" } } over bind-statement + + dup [ sql-row ] query-map swap dispose + ] with-sqlite +] unit-test + +[ + { + { "1" "John" "America" } + { "2" "Jane" "New Zealand" } + } +] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test + +[ +] [ + "extra/db/sqlite/test.db" resource-path [ + "insert into person(name, country) values('Jimmy', 'Canada')" + do-simple-command + ] with-sqlite +] unit-test + +[ + { + { "1" "John" "America" } + { "2" "Jane" "New Zealand" } + { "3" "Jimmy" "Canada" } + } +] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test + +[ + "extra/db/sqlite/test.db" resource-path [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + "oops" throw + ] with-transaction + ] with-sqlite +] unit-test-fails + +[ 3 ] [ + "extra/db/sqlite/test.db" resource-path [ + "select * from person" do-simple-query length + ] with-sqlite +] unit-test + +[ +] [ + "extra/db/sqlite/test.db" resource-path [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + ] with-transaction + ] with-sqlite +] unit-test + +[ 5 ] [ + "extra/db/sqlite/test.db" resource-path [ + "select * from person" do-simple-query length + ] with-sqlite +] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor new file mode 100644 index 0000000000..c5964ed599 --- /dev/null +++ b/extra/db/sqlite/sqlite.factor @@ -0,0 +1,70 @@ +! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien arrays assocs classes compiler db db.sql hashtables +io.files kernel math math.parser namespaces prettyprint sequences +strings sqlite.lib tuples alien.c-types continuations +db.sqlite.lib db.sqlite.ffi ; +IN: db.sqlite + +TUPLE: sqlite-db path ; +C: sqlite-db + +M: sqlite-db db-open ( db -- ) + dup sqlite-db-path sqlite-open + swap set-delegate ; + +M: sqlite-db dispose ( obj -- ) + dup db-handle sqlite-close + f over set-db-handle + f swap set-delegate ; + +: with-sqlite ( path quot -- ) + >r r> with-db ; inline + +TUPLE: sqlite-statement ; +C: sqlite-statement + +M: sqlite-db ( str -- obj ) + ; + +M: sqlite-db ( str -- obj ) + ; + +M: sqlite-db ( str -- obj ) + db get db-handle over sqlite-prepare + { set-statement-sql set-statement-handle } statement construct + [ set-delegate ] keep ; + +M: sqlite-db ( str assoc -- obj ) + swap tuck bind-statement ; + +M: sqlite-statement dispose ( statement -- ) + statement-handle sqlite-finalize ; + +M: sqlite-statement bind-statement* ( assoc statement -- ) + statement-handle swap sqlite-bind-assoc ; + +M: sqlite-statement rebind-statement ( assoc statement -- ) + dup reset-statement + statement-handle swap sqlite-bind-assoc ; + +M: sqlite-statement #columns ( statement -- n ) + statement-handle sqlite-#columns ; + +M: sqlite-statement row-column ( statement n -- obj ) + >r statement-handle r> sqlite-column ; + +M: sqlite-statement advance-row ( statement -- ? ) + statement-handle sqlite-next ; + +M: sqlite-statement reset-statement ( statement -- ) + statement-handle sqlite-reset ; + +M: sqlite-db begin-transaction ( -- ) + "BEGIN" do-simple-command ; + +M: sqlite-db commit-transaction ( -- ) + "COMMIT" do-simple-command ; + +M: sqlite-db rollback-transaction ( -- ) + "ROLLBACK" do-simple-command ; diff --git a/extra/db/sqlite/test.txt b/extra/db/sqlite/test.txt new file mode 100644 index 0000000000..e4487d30f9 --- /dev/null +++ b/extra/db/sqlite/test.txt @@ -0,0 +1,3 @@ +create table person (name varchar(30), country varchar(30)); +insert into person values('John', 'America'); +insert into person values('Jane', 'New Zealand'); From 822e859f9430cd5bc63263fe9630e156ed88b884 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 17:44:15 -0600 Subject: [PATCH 063/317] remove old postgresql --- extra/postgresql/authors.txt | 1 - extra/postgresql/libpq/libpq.factor | 361 ----------------------- extra/postgresql/postgresql-tests.factor | 42 --- extra/postgresql/postgresql.factor | 61 ---- 4 files changed, 465 deletions(-) delete mode 100644 extra/postgresql/authors.txt delete mode 100644 extra/postgresql/libpq/libpq.factor delete mode 100644 extra/postgresql/postgresql-tests.factor delete mode 100644 extra/postgresql/postgresql.factor diff --git a/extra/postgresql/authors.txt b/extra/postgresql/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/extra/postgresql/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/extra/postgresql/libpq/libpq.factor b/extra/postgresql/libpq/libpq.factor deleted file mode 100644 index 3b21fd8203..0000000000 --- a/extra/postgresql/libpq/libpq.factor +++ /dev/null @@ -1,361 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. - -! adapted from libpq-fe.h version 7.4.7 -! tested on debian linux with postgresql 7.4.7 -! Updated to 8.1 - -USING: alien alien.syntax combinators system ; -IN: postgresql.libpq - -<< -"postgresql" { - { [ win32? ] [ "libpq.dll" ] } - { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] } - { [ unix? ] [ "libpq.so" ] } -} cond "cdecl" add-library ->> - -! ConnSatusType -: CONNECTION_OK HEX: 0 ; inline -: CONNECTION_BAD HEX: 1 ; inline -: CONNECTION_STARTED HEX: 2 ; inline -: CONNECTION_MADE HEX: 3 ; inline -: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline -: CONNECTION_AUTH_OK HEX: 5 ; inline -: CONNECTION_SETENV HEX: 6 ; inline -: CONNECTION_SSL_STARTUP HEX: 7 ; inline -: CONNECTION_NEEDED HEX: 8 ; inline - -! PostgresPollingStatusType -: PGRES_POLLING_FAILED HEX: 0 ; inline -: PGRES_POLLING_READING HEX: 1 ; inline -: PGRES_POLLING_WRITING HEX: 2 ; inline -: PGRES_POLLING_OK HEX: 3 ; inline -: PGRES_POLLING_ACTIVE HEX: 4 ; inline - -! ExecStatusType; -: PGRES_EMPTY_QUERY HEX: 0 ; inline -: PGRES_COMMAND_OK HEX: 1 ; inline -: PGRES_TUPLES_OK HEX: 2 ; inline -: PGRES_COPY_OUT HEX: 3 ; inline -: PGRES_COPY_IN HEX: 4 ; inline -: PGRES_BAD_RESPONSE HEX: 5 ; inline -: PGRES_NONFATAL_ERROR HEX: 6 ; inline -: PGRES_FATAL_ERROR HEX: 7 ; inline - -! PGTransactionStatusType; -: PQTRANS_IDLE HEX: 0 ; inline -: PQTRANS_ACTIVE HEX: 1 ; inline -: PQTRANS_INTRANS HEX: 2 ; inline -: PQTRANS_INERROR HEX: 3 ; inline -: PQTRANS_UNKNOWN HEX: 4 ; inline - -! PGVerbosity; -: PQERRORS_TERSE HEX: 0 ; inline -: PQERRORS_DEFAULT HEX: 1 ; inline -: PQERRORS_VERBOSE HEX: 2 ; inline - - -TYPEDEF: int size_t -TYPEDEF: int ConnStatusType -TYPEDEF: int ExecStatusType -TYPEDEF: int PostgresPollingStatusType -TYPEDEF: int PGTransactionStatusType -TYPEDEF: int PGVerbosity - -TYPEDEF: void* PGconn* -TYPEDEF: void* PGresult* -TYPEDEF: void* PGcancel* -TYPEDEF: uint Oid -TYPEDEF: uint* Oid* -TYPEDEF: char pqbool -TYPEDEF: void* PQconninfoOption* -TYPEDEF: void* PGnotify* -TYPEDEF: void* PQArgBlock* -TYPEDEF: void* PQprintOpt* -TYPEDEF: void* FILE* -TYPEDEF: void* SSL* - -LIBRARY: postgresql - - -! Exported functions of libpq -! === in fe-connect.c === - -! make a new client connection to the backend -! Asynchronous (non-blocking) -FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ; -FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ; - -! Synchronous (blocking) -FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ; -FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport, - char* pgoptions, char* pgtty, - char* dbName, - char* login, char* pwd ) ; - -: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* ) - f f PQsetdbLogin ; - -! close the current connection and free the PGconn data structure -FUNCTION: void PQfinish ( PGconn* conn ) ; - -! get info about connection options known to PQconnectdb -FUNCTION: PQconninfoOption* PQconndefaults ( ) ; - -! free the data structure returned by PQconndefaults() -FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ; - -! -! close the current connection and restablish a new one with the same -! parameters -! -! Asynchronous (non-blocking) -FUNCTION: int PQresetStart ( PGconn* conn ) ; -FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ; - -! Synchronous (blocking) -FUNCTION: void PQreset ( PGconn* conn ) ; - -! request a cancel structure -FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ; - -! free a cancel structure -FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ; - -! issue a cancel request -FUNCTION: int PQrequestCancel ( PGconn* conn ) ; - -! Accessor functions for PGconn objects -FUNCTION: char* PQdb ( PGconn* conn ) ; -FUNCTION: char* PQuser ( PGconn* conn ) ; -FUNCTION: char* PQpass ( PGconn* conn ) ; -FUNCTION: char* PQhost ( PGconn* conn ) ; -FUNCTION: char* PQport ( PGconn* conn ) ; -FUNCTION: char* PQtty ( PGconn* conn ) ; -FUNCTION: char* PQoptions ( PGconn* conn ) ; -FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ; -FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ; -FUNCTION: char* PQparameterStatus ( PGconn* conn, - char* paramName ) ; -FUNCTION: int PQprotocolVersion ( PGconn* conn ) ; -FUNCTION: int PQServerVersion ( PGconn* conn ) ; -FUNCTION: char* PQerrorMessage ( PGconn* conn ) ; -FUNCTION: int PQsocket ( PGconn* conn ) ; -FUNCTION: int PQbackendPID ( PGconn* conn ) ; -FUNCTION: int PQclientEncoding ( PGconn* conn ) ; -FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ; - -! May not be compiled into libpq -! Get the SSL structure associated with a connection -FUNCTION: SSL* PQgetssl ( PGconn* conn ) ; - -! Tell libpq whether it needs to initialize OpenSSL -FUNCTION: void PQinitSSL ( int do_init ) ; - -! Set verbosity for PQerrorMessage and PQresultErrorMessage -FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn, - PGVerbosity verbosity ) ; - -! Enable/disable tracing -FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ; -FUNCTION: void PQuntrace ( PGconn* conn ) ; - -! BROKEN -! Function types for notice-handling callbacks -! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res); -! typedef void (*PQnoticeProcessor) (void *arg, char* message); -! ALIAS: void* PQnoticeReceiver -! ALIAS: void* PQnoticeProcessor - -! Override default notice handling routines -! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn, - ! PQnoticeReceiver proc, - ! void* arg ) ; -! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn, - ! PQnoticeProcessor proc, - ! void* arg ) ; -! END BROKEN - -! === in fe-exec.c === - -! Simple synchronous query -FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ; -FUNCTION: PGresult* PQexecParams ( PGconn* conn, - char* command, - int nParams, - Oid* paramTypes, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; -FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName, - char* query, int nParams, - Oid* paramTypes ) ; -FUNCTION: PGresult* PQexecPrepared ( PGconn* conn, - char* stmtName, - int nParams, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; - -! Interface for multiple-result or asynchronous queries -FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ; -FUNCTION: int PQsendQueryParams ( PGconn* conn, - char* command, - int nParams, - Oid* paramTypes, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; -FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName, - char* query, int nParams, - Oid* paramTypes ) ; -FUNCTION: int PQsendQueryPrepared ( PGconn* conn, - char* stmtName, - int nParams, - char** paramValues, - int *paramLengths, - int *paramFormats, - int resultFormat ) ; -FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ; - -! Routines for managing an asynchronous query -FUNCTION: int PQisBusy ( PGconn* conn ) ; -FUNCTION: int PQconsumeInput ( PGconn* conn ) ; - -! LISTEN/NOTIFY support -FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ; - -! Routines for copy in/out -FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ; -FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ; -FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ; - -! Deprecated routines for copy in/out -FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ; -FUNCTION: int PQputline ( PGconn* conn, char* string ) ; -FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ; -FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ; -FUNCTION: int PQendcopy ( PGconn* conn ) ; - -! Set blocking/nonblocking connection to the backend -FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ; -FUNCTION: int PQisnonblocking ( PGconn* conn ) ; - -! Force the write buffer to be written (or at least try) -FUNCTION: int PQflush ( PGconn* conn ) ; - -! -! * "Fast path" interface --- not really recommended for application -! * use -! -FUNCTION: PGresult* PQfn ( PGconn* conn, - int fnid, - int* result_buf, - int* result_len, - int result_is_int, - PQArgBlock* args, - int nargs ) ; - -! Accessor functions for PGresult objects -FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ; -FUNCTION: char* PQresStatus ( ExecStatusType status ) ; -FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ; -FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ; -FUNCTION: int PQntuples ( PGresult* res ) ; -FUNCTION: int PQnfields ( PGresult* res ) ; -FUNCTION: int PQbinaryTuples ( PGresult* res ) ; -FUNCTION: char* PQfname ( PGresult* res, int field_num ) ; -FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ; -FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ; -FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ; -FUNCTION: int PQfformat ( PGresult* res, int field_num ) ; -FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ; -FUNCTION: int PQfsize ( PGresult* res, int field_num ) ; -FUNCTION: int PQfmod ( PGresult* res, int field_num ) ; -FUNCTION: char* PQcmdStatus ( PGresult* res ) ; -FUNCTION: char* PQoidStatus ( PGresult* res ) ; -FUNCTION: Oid PQoidValue ( PGresult* res ) ; -FUNCTION: char* PQcmdTuples ( PGresult* res ) ; -FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; -FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; -FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; - -! Delete a PGresult -FUNCTION: void PQclear ( PGresult* res ) ; - -! For freeing other alloc'd results, such as PGnotify structs -FUNCTION: void PQfreemem ( void* ptr ) ; - -! Exists for backward compatibility. -: PQfreeNotify PQfreemem ; - -! -! Make an empty PGresult with given status (some apps find this -! useful). If conn is not NULL and status indicates an error, the -! conn's errorMessage is copied. -! -FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ; - -! Quoting strings before inclusion in queries. -FUNCTION: size_t PQescapeStringConn ( PGconn* conn, - char* to, char* from, size_t length, - int* error ) ; -FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn, - char* from, size_t length, - size_t* to_length ) ; -FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, - size_t* retbuflen ) ; -! These forms are deprecated! -FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ; -FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen, - size_t* bytealen ) ; - -! === in fe-print.c === - -FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ; - -! really old printing routines -FUNCTION: void PQdisplayTuples ( PGresult* res, - FILE* fp, - int fillAlign, - char* fieldSep, - int printHeader, - int quiet ) ; - -FUNCTION: void PQprintTuples ( PGresult* res, - FILE* fout, - int printAttName, - int terseOutput, - int width ) ; - -! === in fe-lobj.c === - -! Large-object access routines -FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ; -FUNCTION: int lo_close ( PGconn* conn, int fd ) ; -FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ; -FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ; -FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ; -FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ; -! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ; -FUNCTION: int lo_tell ( PGconn* conn, int fd ) ; -FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ; -FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ; -FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ; - -! === in fe-misc.c === - -! Determine length of multibyte encoded char at *s -FUNCTION: int PQmblen ( uchar* s, int encoding ) ; - -! Determine display length of multibyte encoded char at *s -FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; - -! Get encoding id from environment variable PGCLIENTENCODING -FUNCTION: int PQenv2encoding ( ) ; - diff --git a/extra/postgresql/postgresql-tests.factor b/extra/postgresql/postgresql-tests.factor deleted file mode 100644 index c725882b67..0000000000 --- a/extra/postgresql/postgresql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -! You will need to run 'createdb factor-test' to create the database. -! Set username and password in the 'connect' word. - -IN: postgresql-test -USING: kernel postgresql alien continuations io prettyprint -sequences namespaces ; - - -: test-connection ( host port pgopts pgtty db user pass -- bool ) - [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ; - -! just a basic demo - -"localhost" "" "" "" "test" "postgres" "" [ - "drop table animal" do-command - - "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command - "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" - do-command - - "select * from animal where name = 'Mufasa'" [ ] do-query - "select * from animal where name = 'Mufasa'" - [ - result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless - ] do-query - - "insert into animal (species, name, age) values ('lion', 'Simba', 1)" - do-command - - "select * from animal" - [ - "Animal table:" print - result>seq print-table - ] do-query - - ! intentional errors - ! [ "select asdf from animal" - ! [ ] do-query ] catch [ "caught: " write print ] when* - ! "select asdf from animal" [ ] do-query - ! "aofijweafew" do-command -] with-postgres - diff --git a/extra/postgresql/postgresql.factor b/extra/postgresql/postgresql.factor deleted file mode 100644 index 9d85b6a77e..0000000000 --- a/extra/postgresql/postgresql.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. - -! adapted from libpq-fe.h version 7.4.7 -! tested on debian linux with postgresql 7.4.7 - -USING: arrays alien alien.syntax continuations io -kernel math namespaces postgresql.libpq prettyprint -quotations sequences debugger ; -IN: postgresql - -SYMBOL: db -SYMBOL: query-res - -: connect-postgres ( host port pgopts pgtty db user pass -- conn ) - PQsetdbLogin - dup PQstatus zero? [ "couldn't connect to database" throw ] unless ; - -: with-postgres ( host port pgopts pgtty db user pass quot -- ) - [ >r connect-postgres db set r> - [ db get PQfinish ] [ ] cleanup ] with-scope ; inline - -: postgres-error ( ret -- ret ) - dup zero? [ PQresultErrorMessage throw ] when ; - -: (do-query) ( PGconn query -- PGresult* ) - ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK - ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK - PQexec - dup PQresultStatus PGRES_COMMAND_OK = - over PQresultStatus PGRES_TUPLES_OK = - or [ - [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw - ] unless ; - -: (do-command) ( PGconn query -- PGresult* ) - [ (do-query) ] catch - [ - swap - "non-fatal error: " print - "\tQuery: " write "'" write write "'" print - "\t" write print - ] when* drop ; - -: do-command ( str -- ) - 1quotation \ (do-command) add db get swap call ; - -: prepare ( str quot word -- conn quot ) - rot 1quotation swap append swap append db get swap ; - -: do-query ( str quot -- ) - [ (do-query) query-res set ] prepare catch - [ rethrow ] [ query-res get PQclear ] if* ; - -: result>seq ( -- seq ) - query-res get [ PQnfields ] keep PQntuples - [ swap [ query-res get -rot PQgetvalue ] with map ] with map ; - -: print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - From 161c3ec1560dbcc32f3006bac38b49a8a62a0338 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 17:45:34 -0600 Subject: [PATCH 064/317] remove sqlite and tupledb for now --- extra/sqlite/authors.txt | 1 - extra/sqlite/lib/authors.txt | 1 - extra/sqlite/lib/lib.factor | 120 --------- extra/sqlite/sqlite-docs.factor | 87 ------- extra/sqlite/sqlite-tests.factor | 69 ----- extra/sqlite/sqlite.factor | 127 --------- extra/sqlite/test.txt | 3 - extra/sqlite/tuple-db/authors.txt | 1 - extra/sqlite/tuple-db/tuple-db-docs.factor | 131 ---------- extra/sqlite/tuple-db/tuple-db-tests.factor | 39 --- extra/sqlite/tuple-db/tuple-db.factor | 270 -------------------- 11 files changed, 849 deletions(-) delete mode 100755 extra/sqlite/authors.txt delete mode 100755 extra/sqlite/lib/authors.txt delete mode 100644 extra/sqlite/lib/lib.factor delete mode 100644 extra/sqlite/sqlite-docs.factor delete mode 100644 extra/sqlite/sqlite-tests.factor delete mode 100644 extra/sqlite/sqlite.factor delete mode 100644 extra/sqlite/test.txt delete mode 100755 extra/sqlite/tuple-db/authors.txt delete mode 100644 extra/sqlite/tuple-db/tuple-db-docs.factor delete mode 100644 extra/sqlite/tuple-db/tuple-db-tests.factor delete mode 100644 extra/sqlite/tuple-db/tuple-db.factor diff --git a/extra/sqlite/authors.txt b/extra/sqlite/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/lib/authors.txt b/extra/sqlite/lib/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/lib/lib.factor b/extra/sqlite/lib/lib.factor deleted file mode 100644 index 438f22a80f..0000000000 --- a/extra/sqlite/lib/lib.factor +++ /dev/null @@ -1,120 +0,0 @@ -! Copyright (C) 2005 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -! -! An interface to the sqlite database. Tested against sqlite v3.1.3. -! Remeber to pass the following to factor: -! -libraries:sqlite=libsqlite3.so -! -! Not all functions have been wrapped yet. Only those directly involving -! executing SQL calls and obtaining results. -! -IN: sqlite.lib -USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; - -<< -"sqlite" { - { [ win32? ] [ "sqlite3.dll" ] } - { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ unix? ] [ "libsqlite3.so" ] } -} cond "cdecl" add-library ->> - -! Return values from sqlite functions -: SQLITE_OK 0 ; inline ! Successful result -: SQLITE_ERROR 1 ; inline ! SQL error or missing database -: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite -: SQLITE_PERM 3 ; inline ! Access permission denied -: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort -: SQLITE_BUSY 5 ; inline ! The database file is locked -: SQLITE_LOCKED 6 ; inline ! A table in the database is locked -: SQLITE_NOMEM 7 ; inline ! A malloc() failed -: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database -: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() -: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred -: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed -: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found -: SQLITE_FULL 13 ; inline ! Insertion failed because database is full -: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file -: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error -: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty -: SQLITE_SCHEMA 17 ; inline ! The database schema changed -: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table -: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation -: SQLITE_MISMATCH 20 ; inline ! Data type mismatch -: SQLITE_MISUSE 21 ; inline ! Library used incorrectly -: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host -: SQLITE_AUTH 23 ; inline ! Authorization denied -: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error -: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range -: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file - -: sqlite-error-messages ( -- seq ) { - "Successful result" - "SQL error or missing database" - "An internal logic error in SQLite" - "Access permission denied" - "Callback routine requested an abort" - "The database file is locked" - "A table in the database is locked" - "A malloc() failed" - "Attempt to write a readonly database" - "Operation terminated by sqlite_interrupt()" - "Some kind of disk I/O error occurred" - "The database disk image is malformed" - "(Internal Only) Table or record not found" - "Insertion failed because database is full" - "Unable to open the database file" - "Database lock protocol error" - "(Internal Only) Database table is empty" - "The database schema changed" - "Too much data for one row of a table" - "Abort due to contraint violation" - "Data type mismatch" - "Library used incorrectly" - "Uses OS features not supported on host" - "Authorization denied" - "Auxiliary database format error" - "2nd parameter to sqlite3_bind out of range" - "File opened that is not a database file" -} ; - -: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready -: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing - -! Return values from the sqlite3_column_type function -: SQLITE_INTEGER 1 ; inline -: SQLITE_FLOAT 2 ; inline -: SQLITE_TEXT 3 ; inline -: SQLITE_BLOB 4 ; inline -: SQLITE_NULL 5 ; inline - -! Values for the 'destructor' parameter of the 'bind' routines. -: SQLITE_STATIC 0 ; inline -: SQLITE_TRANSIENT -1 ; inline - -TYPEDEF: void sqlite3 -TYPEDEF: void sqlite3_stmt - -LIBRARY: sqlite -FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; -FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; -FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; -FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; -FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; -FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; -FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; - diff --git a/extra/sqlite/sqlite-docs.factor b/extra/sqlite/sqlite-docs.factor deleted file mode 100644 index d58b553f11..0000000000 --- a/extra/sqlite/sqlite-docs.factor +++ /dev/null @@ -1,87 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help help.syntax help.markup ; -IN: sqlite - -HELP: sqlite-open -{ $values { "filename" "path to sqlite database" } - { "db" "the database object" } -} -{ $description "Opens the sqlite3 database." } -{ $see-also sqlite-close sqlite-last-insert-rowid } ; - -HELP: sqlite-close -{ $values { "db" "the database object" } -} -{ $description "Closes the sqlite3 database." } -{ $see-also sqlite-open sqlite-last-insert-rowid } ; - -HELP: sqlite-last-insert-rowid -{ $values { "db" "the database object" } - { "rowid" "the row number of the last insert" } -} -{ $description "Returns the number of the row of the last statement inserted into the database." } -{ $see-also sqlite-open sqlite-close } ; - -HELP: sqlite-prepare -{ $values { "db" "the database object" } - { "sql" "the SQL statement as a string" } - { "statement" "the prepared SQL statement" } -} -{ $description "Internally compiles the SQL statement ready to be run by sqlite. The statement is executed and the results iterated over using " { $link sqlite-each } " and " { $link sqlite-map } ". The SQL statement can use named parameters which are later bound to values using " { $link sqlite-bind-text } " and " { $link sqlite-bind-text-by-name } "." } -{ $see-also sqlite-open sqlite-close } ; - -HELP: sqlite-bind-text -{ $values { "statement" "a prepared SQL statement" } - { "index" "the index of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - -} -{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the index given and the indexes start from one." } -{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=?\" sqlite-prepare\n1 \"chris\" sqlite-bind-text" } } -{ $see-also sqlite-bind-text-by-name } ; - -HELP: sqlite-bind-text-by-name -{ $values { "statement" "a prepared SQL statement" } - { "name" "the name of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - -} -{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the given name." } -{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=:name\" sqlite-prepare\n\"name\" \"chris\" sqlite-bind-text" } } -{ $see-also sqlite-bind-text } ; - -HELP: sqlite-finalize -{ $values { "statement" "a prepared SQL statement" } -} -{ $description "Clean up all resources related to a statement. Once called the statement cannot be used again. All statements must be finalized before closing the database." } -{ $see-also sqlite-close sqlite-prepare } ; - -HELP: sqlite-reset -{ $values { "statement" "a prepared SQL statement" } -} -{ $description "Reset a statement so it can be called again, possibly with different bound parameters." } -{ $see-also sqlite-bind-text sqlite-bind-text-by-name } ; - -HELP: column-count -{ $values { "statement" "a prepared SQL statement" } { "int" "the number of columns" } } -{ $description "Return the number of columns in each row of the result set of the given statement." } -{ $see-also column-text sqlite-each sqlite-map } ; - -HELP: column-text -{ $values { "statement" "a prepared SQL statement" } { "index" "column number indexed from zero" } { "string" "column value" } -} -{ $description "Return the value of the given column, indexed from zero, as a string." } -{ $see-also column-count sqlite-each sqlite-map } ; - -HELP: sqlite-each -{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- )" } -} -{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row." } -{ $see-also column-count column-text sqlite-map } ; - -HELP: sqlite-map -{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- value )" } { "seq" "a new sequence" } -} -{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row. The quotation should leave a value on the stack which gets collected and returned in the resulting sequence." } -{ $see-also column-count column-text sqlite-each } ; diff --git a/extra/sqlite/sqlite-tests.factor b/extra/sqlite/sqlite-tests.factor deleted file mode 100644 index 5eecbec369..0000000000 --- a/extra/sqlite/sqlite-tests.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! Test the sqlite interface -! -! Create a test database like follows: -! -! sqlite3 test.db < test.txt -! -! Then run this file. -USE: sqlite -USE: kernel -USE: io -USE: io.files -USE: prettyprint - -: test.db "libs/sqlite/test.db" resource-path ; - -: show-people ( statement -- ) - dup 0 column-text write " from " write 1 column-text . ; - -: run-test ( -- ) - test.db sqlite-open - dup "select * from test" sqlite-prepare - dup [ show-people ] sqlite-each - sqlite-finalize - sqlite-close ; - -: find-person ( name -- ) - test.db sqlite-open ! name db - dup "select * from test where name=?" sqlite-prepare ! name db stmt - [ rot 1 swap sqlite-bind-text ] keep ! db stmt - [ [ 1 column-text . ] sqlite-each ] keep - sqlite-finalize - sqlite-close ; - -: find-all ( -- ) - test.db sqlite-open ! db - dup "select * from test" sqlite-prepare ! db stmt - [ [ [ 0 column-text ] keep 1 column-text curry ] sqlite-map ] keep - sqlite-finalize - swap sqlite-close ; - -: run-test2 ( -- ) - test.db sqlite-open - dup "select * from test" sqlite-prepare - dup [ show-people ] ; - -run-test diff --git a/extra/sqlite/sqlite.factor b/extra/sqlite/sqlite.factor deleted file mode 100644 index d651ad916c..0000000000 --- a/extra/sqlite/sqlite.factor +++ /dev/null @@ -1,127 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! An interface to the sqlite database. Tested against sqlite v3.0.8. -! -! Not all functions have been wrapped yet. Only those directly involving -! executing SQL calls and obtaining results. -! -IN: sqlite -USING: alien compiler kernel namespaces sequences strings sqlite.lib - alien.c-types continuations ; - -TUPLE: sqlite-error n message ; -SYMBOL: db - -! High level sqlite routines -: sqlite-check-result ( result -- ) - #! Check the result from a sqlite call is ok. If it is - #! return, otherwise throw an error. - dup SQLITE_OK = [ - drop - ] [ - dup sqlite-error-messages nth - \ sqlite-error construct-boa throw - ] if ; - -: sqlite-open ( filename -- db ) - #! Open the database referenced by the filename and return - #! a handle to that database. An error is thrown if the database - #! failed to open. - "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; - -: sqlite-close ( db -- ) - #! Close the given database - sqlite3_close sqlite-check-result ; - -: sqlite-last-insert-rowid ( db -- rowid ) - #! Return the rowid of the last insert - sqlite3_last_insert_rowid ; - -: sqlite-prepare ( db sql -- statement ) - #! Prepare a SQL statement. Returns the statement which - #! can have values bound to parameters or simply executed. - #! TODO: Support multiple statements in the SQL string. - dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep - drop *void* ; - -: sqlite-bind-text ( statement index text -- ) - #! Bind the text to the parameterized value in the statement. - dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; - -: sqlite-bind-parameter-index ( statement name -- index ) - sqlite3_bind_parameter_index ; - -: sqlite-bind-text-by-name ( statement name text -- ) - >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; - -: sqlite-finalize ( statement -- ) - #! Clean up all resources related to a statement. Once called - #! the statement cannot be used. All statements must be finalized - #! before closing the database. - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( statement -- ) - #! Reset a statement so it can be called again, possibly with - #! different parameters. - sqlite3_reset sqlite-check-result ; - -: column-count ( statement -- int ) - #! Given a prepared statement, return the number of - #! columns in each row of the result set of that statement. - sqlite3_column_count ; - -: column-text ( statement index -- string ) - #! Return the value of the given column, indexed - #! from zero, as a string. - sqlite3_column_text ; - -: step-complete? ( step-result -- bool ) - #! Return true if the result of a sqlite3_step is - #! such that the iteration has completed (ie. it is - #! SQLITE_DONE). Throw an error if an error occurs. - dup SQLITE_ROW = [ - drop f - ] [ - dup SQLITE_DONE = [ - drop t - ] [ - sqlite-check-result t - ] if - ] if ; - -: sqlite-each ( statement quot -- ) - #! Execute the SQL statement, and call the quotation for - #! each row returned from executing the statement with the - #! statement on the top of the stack. - over sqlite3_step step-complete? [ - 2drop - ] [ - [ call ] 2keep sqlite-each - ] if ; inline - -! For comparison, here is the linrec implementation of sqlite-each -! [ drop sqlite3_step step-complete? ] -! [ 2drop ] -! [ 2dup 2slip ] -! [ ] linrec ; - -DEFER: (sqlite-map) - -: (sqlite-map) ( statement quot seq -- ) - pick sqlite3_step step-complete? [ - 2nip - ] [ - >r 2dup call r> swap add (sqlite-map) - ] if ; - -: sqlite-map ( statement quot -- seq ) - { } (sqlite-map) ; - -: with-sqlite ( path quot -- ) - [ - >r sqlite-open db set r> - [ db get sqlite-close ] [ ] cleanup - ] with-scope ; - diff --git a/extra/sqlite/test.txt b/extra/sqlite/test.txt deleted file mode 100644 index 5c7ae2b52a..0000000000 --- a/extra/sqlite/test.txt +++ /dev/null @@ -1,3 +0,0 @@ -create table test (name varchar(30), address varchar(30)); -insert into test values('John', 'America'); -insert into test values('Jane', 'New Zealand'); diff --git a/extra/sqlite/tuple-db/authors.txt b/extra/sqlite/tuple-db/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/tuple-db/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/tuple-db/tuple-db-docs.factor b/extra/sqlite/tuple-db/tuple-db-docs.factor deleted file mode 100644 index 3c6df0eaa6..0000000000 --- a/extra/sqlite/tuple-db/tuple-db-docs.factor +++ /dev/null @@ -1,131 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help sqlite help.syntax help.markup ; -IN: sqlite.tuple-db - -ARTICLE: { "sqlite" "tuple-db-loading" } "Loading" -"The quickest way to get up and running with this library is to use the vocabulary:" -{ $code "USING: sqlite sqlite.tuple-db ;\n" } -"Some simple tests can be run to check that everything is working ok:" -{ $code "\"libs/sqlite\" test-module" } ; - -ARTICLE: { "sqlite" "tuple-db-usage" } "Basic Usage" -"This library can be used for storing simple Factor tuples in a sqlite database. In its current form the tuples must not contain references to other tuples and should not have a delegate set." -$nl -"This document will use the following tuple for demonstration purposes:" -{ $code "TUPLE: person name surname phone ;" } -"The sqlite database to store tuples must be created, or an existing one opened. This is done using the " { $link sqlite-open } " word. If the database does not exist then it is created. The examples in this document store the database pointer in a variable called 'db':" -{ $code "SYMBOL: db\n\"example.db\" sqlite-open db set-global" } ; - -ARTICLE: { "sqlite" "tuple-db-mappings" } "Tuple Mappings" -"Each tuple has a 'mapping' tuple associated with it. The 'mapping' stores information about what table the tuple will be stored in, the datatypes of the tuple slots, etc. A mapping must be created before a tuple can be stored in a database. A default mapping is easily created using " { $link default-mapping } ". Given the tuple class, this will use reflection to get the slots of it, assume that all slots are of database type 'text', and store the tuple objects in a table with the same name as the tuple." -$nl -"The following shows how to create the default mapping for the 'person' tuple, and how to register that mapping so the 'tuple-db' system can know how to handle 'person' instances:" -{ $code "person default-mapping set-mapping" } ; - -ARTICLE: { "sqlite" "tuple-db-create" } "Creating the table" -"The table used to store tuple instances may need to be created. This can be done manually using the external sqlite program or via " { $link create-tuple-table } ":" -{ $code "db get person create-tuple-table" } -"The SQL used to create the table is produced internally by " { $link create-sql } ". This is a generic word dispatched on the mapping object, and could be specialised if needed. If you wish to see the SQL used to create the table, use the following code:" -{ $code "person get-mapping create-sql .\n => \"create table person (name text,surname text,phone text);\"" } ; - -ARTICLE: { "sqlite" "tuple-db-insert" } "Inserting instances" -"The " { $link insert-tuple } " word will store instances of a tuple into the database table defined by its mapping object:" -{ $code "db get \"John\" \"Smith\" \"123-456-789\" insert-tuple" } -{ $link insert-tuple } " internally uses the " { $link insert-sql } " word to produce the SQL used to store the tuple. Like " { $link create-sql } ", it is a generic word specialized on the mapping object. You can call it directly to see what SQL is generated:" -{ $code "person get-mapping insert-sql .\n => \"insert into person values(:name,:surname,:phone);\"" } -"Notice that the SQL uses named parameters. These parameters are bound to the values stored in the tuple object when the SQL is compiled. This helps prevent SQL injection techniques." -$nl -"When " { $link insert-sql } " is run, it adds a delegate to the tuple being stored. The delegate is of type 'persistent' and holds the row id of the tuple in its 'key' slot. This way the exact record can be updated or retrieved later. The following demonstates this fact:" -{ $code "\"Mandy\" \"Jones\" \"987-654-321\" dup .\n => T{ person f \"Mandy\" \"Jones\" \"987-654-321\" }\ndb get over insert-tuple .\n => T{ person T{ persistent ... 2 } \"Mandy\" \"Jones\" \"987-654-321\" }" } -"The '2' in the above example is the row id of the record inserted. We can go into the 'sqlite' command and view this record:" -{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|123-456-789\n 2|Mandy|Jones|987-654-321\n sqlite>" } ; - -ARTICLE: { "sqlite" "tuple-db-finding" } "Finding instances" -"The " { $link find-tuples } " word is used to return tuples populated with data already existing in the database. As well as the database objcet, it takes a tuple that should be populated only with the fields that should be matched in the database. All fields you do not wish to match against should be set to 'f':" -{ $code "db get f \"Smith\" f find-tuples .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\ndb get \"Mandy\" f f find-tuples .\n => { T{ person # \"Mandy\" \"Jones\" \"987-654-321\" } }\ndb get \"Joe\" f f find-tuples .\n => { }" } -"Notice that if no matching tuples are found then an empty sequence is returned. The returned tuples also have their delegate set to 'persistent' with the correct row id set as the key. This can be used to later update the tuples with new information and store them in the database." ; - -ARTICLE: { "sqlite" "tuple-db-updating" } "Updating instances" -"Given a tuple that has the 'persistent' delegate with the row id set as the key, you can update this specific record using " { $link update-tuple } ":" -{ $code "db get f \"Smith\" f find-tuples dup .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\nfirst { \"999-999-999\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"1\" } \"John\" \"Smith\" \"999-999-999\" ...\n db get swap update-tuple" } -"Using the 'sqlite' command from the system shell you can see the record was updated:" -{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|999-999-999\n 2|Mandy|Jones|987-654-321\n sqlite>" } ; - -ARTICLE: { "sqlite" "tuple-db-inserting-or-updating" } "Inserting or Updating instances" -"The " { $link save-tuple } " word can be used to insert a tuple if it has not already been stored in the database, or update it if it already exists. Whether to insert or update is decided by the existance of the 'persistent' delegate:" -{ $code "\"Mary\" \"Smith\" \"111-111-111\" dup .\n => T{ person f \"Mary\" \"Smith\" \"111-111-111\" }\n! This will insert the tuple\ndb get over save-tuple dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"111-111-111\" ...\n[ \"222-222-222\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ...\n! This will update the tuple\ndb get over save-tuple .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ..." } ; - -ARTICLE: { "sqlite" "tuple-db-deleting" } "Deleting instances" -"Given a tuple with the delegate set to 'persistent' (ie. One already stored in the database) you can delete it from the database with " { $link delete-tuple } ":" -{ $code "db get f \"Smith\" f find-tuples [ db get swap delete-tuple ] each" } ; - -ARTICLE: { "sqlite" "tuple-db-closing" } "Closing the database" -"It's important to close the sqlite database when you've finished using it. The word for this is " { $link sqlite-close } ":" -{ $code "db get sqlite-close" } ; - -ARTICLE: { "sqlite" "tuple-db" } "Tuple Database Library" -"The version of sqlite required by this library is version 3 or greater. This library allows storing Factor tuples in a sqlite database. It provides words to create, read update and delete these entries as well as simple searching." -$nl -"The library is in a very early state and is likely to change quite a bit in the near future. Its most notable omission is it cannot currently handle relationships between tuples." -{ $subsection { "sqlite" "tuple-db-loading" } } -{ $subsection { "sqlite" "tuple-db-usage" } } -{ $subsection { "sqlite" "tuple-db-mappings" } } -{ $subsection { "sqlite" "tuple-db-create" } } -{ $subsection { "sqlite" "tuple-db-insert" } } -{ $subsection { "sqlite" "tuple-db-finding" } } -{ $subsection { "sqlite" "tuple-db-updating" } } -{ $subsection { "sqlite" "tuple-db-inserting-or-updating" } } -{ $subsection { "sqlite" "tuple-db-deleting" } } -{ $subsection { "sqlite" "tuple-db-closing" } } -; - -HELP: default-mapping -{ $values { "class" "symbol for the tuple class" } - { "mapping" "a mapping object" } -} -{ $description "Given a tuple class, create a default mappings object. This is used to associate field names in the tuple with SQL statement field names, etc." } -{ $see-also { "sqlite" "tuple-db" } set-mapping } ; - -HELP: set-mapping -{ $values { "mapping" "a mapping object" } -} -{ $description "Store a database mapping so that the tuple-db system knows how to store instances of the tuple in the database." } -{ $see-also { "sqlite" "tuple-db" } default-mapping } ; - -HELP: create-tuple-table -{ $values { "db" "a database object" } { "class" "symbol for the tuple class" } -} -{ $description "Create the database table to store intances of the given tuple." } -{ $see-also { "sqlite" "tuple-db" } default-mapping get-mapping } ; - -HELP: insert-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Insert the tuple instance into the database. It is assumed that this tuple does not currently exist in the database." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: find-tuples -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } { "seq" "a sequence of tuples" } } -{ $description "Return a sequence of all tuples in the database that match the tuple provided as a template. All fields in the tuple must match the entries in the database, except for those set to 'f'." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: update-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Update the database record for this tuple instance. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: save-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Insert or Update the tuple instance depending on whether it has a persistent delegate." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: delete-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -ABOUT: { "sqlite" "tuple-db" } \ No newline at end of file diff --git a/extra/sqlite/tuple-db/tuple-db-tests.factor b/extra/sqlite/tuple-db/tuple-db-tests.factor deleted file mode 100644 index 8ed2631b45..0000000000 --- a/extra/sqlite/tuple-db/tuple-db-tests.factor +++ /dev/null @@ -1,39 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -IN: temporary -USING: io io.files kernel sequences namespaces -hashtables sqlite sqlite.tuple-db math words tools.test ; - -TUPLE: testdata one two ; - -C: testdata - -testdata default-mapping set-mapping - -"libs/sqlite/test.db" resource-path [ - - db get testdata create-tuple-table - - [ "two" { } ] [ - db get "one" "two" insert-tuple - db get "one" f find-tuples - first [ testdata-two ] keep - db get swap delete-tuple - db get "one" f find-tuples - ] unit-test - - [ "junk" ] [ - db get "one" "two" insert-tuple - db get "one" f find-tuples - first - "junk" over set-testdata-two - db get swap update-tuple - db get "one" f find-tuples - first [ testdata-two ] keep - db get swap delete-tuple - ] unit-test - - db get testdata drop-tuple-table -] with-sqlite - diff --git a/extra/sqlite/tuple-db/tuple-db.factor b/extra/sqlite/tuple-db/tuple-db.factor deleted file mode 100644 index c37a49d2b6..0000000000 --- a/extra/sqlite/tuple-db/tuple-db.factor +++ /dev/null @@ -1,270 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! -! A tuple that is persistent has its delegate set as 'persistent'. -! 'persistent' holds the numeric rowid for that tuple in its table. -IN: sqlite.tuple-db -USING: io kernel sequences namespaces slots classes slots.private -assocs math words generic sqlite math.parser ; - -! Each slot in a tuple that is storable in the database has -! an instance of a db-field object the gives the name of the -! database table and slot number in the tuple object of that field. -TUPLE: db-field name bind-name slot type ; - -C: db-field - -! The mapping tuple holds information on how the slots of -! a tuple are mapped to the fields of a sqlite database. -TUPLE: mapping tuple table fields one-to-one one-to-many ; - -C: mapping - -: sanitize ( string -- string ) - #! Convert a string so it can be used as a table or field name. - clone - H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } } - over substitute ; - -: tuple-fields ( class -- seq ) - #! Given a tuple class return a list of the fields - #! within that tuple. Ignores the delegate field. - "slots" word-prop 1 tail [ - [ slot-spec-name sanitize dup ":" swap append ] keep - slot-spec-offset - "text" - - ] map ; - -: default-mapping ( class -- mapping ) - #! Given a tuple class, create a default mappings object. It assumes - #! there are no one-to-one or one-to-many relationships. - dup [ word-name sanitize ] keep tuple-fields f f ; - -! The mappings variable holds a hashtable mapping the tuple symbol -! to the mapping object, describing how that tuple is stored -! in the database. -SYMBOL: mappings - -: init-mappings ( -- ) - H{ } mappings set-global ; - -: get-mappings ( -- hashtable ) - mappings get-global ; - -: set-mapping ( mapping -- ) - #! Store a database mapping so that the persistence system - #! knows how to store instances of the relevant tuple in the database. - dup mapping-tuple get-mappings set-at ; - -: get-mapping ( class -- mapping ) - #! Return the database mapping for the given tuple class. - get-mappings at ; - -! The 'persistent' tuple will be set to the delegate of any tuple -! instance stored in the database. It contains the database key -! of the row in the database table for the instance or 'f' if it has -! not yet been stored in the database. It also contains the 'mapping' -! object used to translate the fields of the tuple to the database fields. -TUPLE: persistent mapping key ; -: ( tuple -- persistent ) - persistent construct-empty - >r class get-mapping r> - [ set-persistent-mapping ] keep ; - -: make-persistent ( tuple -- tuple ) - #! Convert the tuple into something that can be stored - #! into a database by setting its delegate to 'persistent'. - [ ] keep - [ set-delegate ] keep ; - - -: comma-fields ( mapping quot -- string ) - #! Given a mapping, call quot on each field in - #! the mapping. The contents of quot should call ',' or '%' - #! to generate output. The output of each quot call - #! seperated by commas is returned as a string. 'quot' should be - #! stack effect ( field -- ). - >r mapping-fields r> [ "" make ] curry map "," join ; inline - -GENERIC: create-sql ( mapping -- string ) -M: mapping create-sql ( mapping -- string ) - #! Return the SQL used to create a table for storing this type of tuple. - [ - "create table " % dup mapping-table % - " (" % - [ dup db-field-name % " " % db-field-type % ] comma-fields % - ");" % - ] "" make ; - -GENERIC: drop-sql ( mapping -- string ) -M: mapping drop-sql ( mapping -- string ) - #! Return the SQL used to drop the table for storing this type of tuple. - [ - "drop table " % mapping-table % ";" % - ] "" make ; - -GENERIC: insert-sql ( mapping -- string ) -M: mapping insert-sql ( mapping -- string ) - #! Return the SQL used to insert a tuple into a table - [ - "insert into " % dup mapping-table % - " values(" % - [ db-field-bind-name % ] comma-fields % - ");" % - ] "" make ; - -GENERIC: delete-sql ( mapping -- string ) -M: mapping delete-sql ( mapping -- string ) - #! Return the SQL used to delete a tuple from a table - [ - "delete from " % mapping-table % - " where ROWID=:rowid;" % - ] "" make ; - -GENERIC: update-sql ( mapping -- string ) -M: mapping update-sql ( mapping -- string ) - #! Return the SQL used to update the tuple - [ - "update " % dup mapping-table % - " set " % - [ dup db-field-name % "=" % db-field-bind-name % ] comma-fields % - " where ROWID=:rowid;" % - ] "" make ; - -GENERIC: select-sql ( tuple mapping -- select ) -M: mapping select-sql ( tuple mapping -- select ) - #! Return the SQL used to select a series of tuples from the database. It - #! will select based on only the filled in fields of the tuple (ie. all non-f). - [ - "select ROWID,* from " % dup mapping-table % - mapping-fields [ ! tuple field - swap over db-field-slot slot ! field value - [ - [ dup db-field-name % "=" % db-field-bind-name % ] "" make - ] [ - drop f - ] if - ] with map [ ] subset dup length 0 > [ - " where " % - " and " join % - ] [ - drop - ] if - ";" % - ] "" make ; - -: execute-update-sql ( db string -- ) - #! Execute the SQL, which should contain a database update - #! statement (update, insert, create, etc). Ignore the result. - sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ; - -: create-tuple-table ( db class -- ) - #! Create the table for the tuple class. - get-mapping create-sql execute-update-sql ; - -: drop-tuple-table ( db class -- ) - #! Create the table for the tuple class. - get-mapping drop-sql execute-update-sql ; - -: bind-for-insert ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared insert statement. - dup class get-mapping mapping-fields [ ! statement tuple field - [ db-field-slot slot ] keep ! statement value field - db-field-bind-name swap ! statement name value - >r dupd r> sqlite-bind-text-by-name - ] with each drop ; - -: bind-for-select ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared select statement. - dup class get-mapping mapping-fields [ ! statement tuple field - [ db-field-slot slot ] keep ! statement value field - over [ - db-field-bind-name swap ! statement name value - >r dupd r> sqlite-bind-text-by-name - ] [ - 2drop - ] if - ] with each drop ; - -: bind-for-update ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared update statement. - 2dup bind-for-insert - >r ":rowid" r> persistent-key sqlite-bind-text-by-name ; - -: bind-for-delete ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared delete statement. - >r ":rowid" r> persistent-key sqlite-bind-text-by-name ; - -: (insert-tuple) ( db tuple -- ) - #! Insert this tuple instance into the database. Note that - #! it inserts only this instance, and not any one-to-one or - #! one-to-many fields. - dup class get-mapping insert-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-insert ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: insert-tuple ( db tuple -- ) - #! Insert this tuple instance into the database and - #! update the rowid of the insert in the tuple. - [ (insert-tuple) ] 2keep - >r sqlite-last-insert-rowid number>string r> make-persistent set-persistent-key ; - -: update-tuple ( db tuple -- ) - #! Update this tuple instance in the database. The tuple should have - #! a delegate of 'persistent' with the key field set. - dup class get-mapping update-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-update ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: save-tuple ( db tuple -- ) - #! Insert or Update the tuple instance depending on whether it - #! has a persistent delegate. - dup delegate [ update-tuple ] [ insert-tuple ] if ; - -: delete-tuple ( db tuple -- ) - #! Delete this tuple instance from the database. The tuple should have - #! a delegate of 'persistent' with the key field set. - dup class get-mapping delete-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-delete ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: restore-tuple ( statement tuple -- tuple ) - #! Using 'tuple' as a template, clone it and - #! return the clone with fields set to the values from the - #! database. - clone dup class get-mapping mapping-fields 1 swap - [ ! statement tuple index field ) - over 1+ >r ! statement tuple index field r: index+1 - db-field-slot >r ! statement tuple index r: index+1 slot - pick swap column-text ! statement tuple value r: index+1 slot - over r> set-slot r> ! statement tuple index+1 - ] each ! statement tuple index - drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ; - -: find-tuples ( db tuple -- seq ) - #! Return a sequence of all tuples in the database that - #! match the tuple provided as a template. All fields in the - #! tuple must match the entries in the database, except for - #! those set to 'f'. - dup class get-mapping dupd select-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - 2dup bind-for-select ! statement tuple - [ - over [ ! tuple statement - over restore-tuple , - ] sqlite-each - ] { } make nip ! statement tuple accum - swap sqlite-finalize ; - - -get-mappings [ init-mappings ] unless From c66b264af57cf61a2d37e34eb93a91d2e10f80b1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 17:45:35 -0600 Subject: [PATCH 065/317] Incomplete update of UTF decoder --- core/io/encodings/encodings.factor | 7 +++++-- core/io/utf8/utf8.factor | 18 +++++++++--------- 2 files changed, 14 insertions(+), 11 deletions(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 5bc679cd27..956c512780 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math kernel sequences sbufs vectors -namespaces ; +namespaces unicode.syntax ; IN: io.encodings TUPLE: encode-error ; @@ -10,13 +10,16 @@ TUPLE: encode-error ; TUPLE: decode-error ; -: decode-error ( -- * ) \ decode-error construct-empty throw ; +: decode-error ( -- * ) \ encode-error construct-empty throw ; SYMBOL: begin : decoded ( buf ch -- buf ch state ) over push 0 begin ; +: push-replacement ( buf -- buf ch state ) + UNICHAR: replacement-character decoded ; + : finish-decoding ( buf ch state -- str ) begin eq? [ decode-error ] unless drop "" like ; diff --git a/core/io/utf8/utf8.factor b/core/io/utf8/utf8.factor index 0269e20e93..321469378d 100644 --- a/core/io/utf8/utf8.factor +++ b/core/io/utf8/utf8.factor @@ -14,10 +14,10 @@ SYMBOL: quad3 : starts-2? ( char -- ? ) -6 shift BIN: 10 number= ; -: append-nums ( bottom top -- num ) - over starts-2? - [ 6 shift swap BIN: 111111 bitand bitor ] - [ decode-error ] if ; +: append-nums ( buf bottom top state-out -- buf num state ) + >r over starts-2? + [ 6 shift swap BIN: 111111 bitand bitor r> ] + [ r> 3drop push-replacement ] if ; : begin-utf8 ( buf byte -- buf ch state ) { @@ -25,20 +25,20 @@ SYMBOL: quad3 { [ dup -5 shift BIN: 110 number= ] [ BIN: 11111 bitand double ] } { [ dup -4 shift BIN: 1110 number= ] [ BIN: 1111 bitand triple ] } { [ dup -3 shift BIN: 11110 number= ] [ BIN: 111 bitand quad ] } - { [ t ] [ decode-error ] } + { [ t ] [ drop push-replacement ] } } cond ; : end-multibyte ( buf byte ch -- buf ch state ) - append-nums decoded ; + begin append-nums decoded ; : (decode-utf8) ( buf byte ch state -- buf ch state ) { { begin [ drop begin-utf8 ] } { double [ end-multibyte ] } - { triple [ append-nums triple2 ] } + { triple [ triple2 append-nums ] } { triple2 [ end-multibyte ] } - { quad [ append-nums quad2 ] } - { quad2 [ append-nums quad3 ] } + { quad [ quad2 append-nums ] } + { quad2 [ quad3 append-nums ] } { quad3 [ end-multibyte ] } } case ; From 4b7034384c10f437090775b44a3b40bcb7f036af Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 17:48:29 -0600 Subject: [PATCH 066/317] Eliminate core ascii dependency --- core/parser/parser.factor | 15 +++++++------- core/prettyprint/backend/backend.factor | 25 +++++++++--------------- {core => extra}/ascii/ascii-docs.factor | 0 {core => extra}/ascii/ascii-tests.factor | 0 {core => extra}/ascii/ascii.factor | 2 -- {core => extra}/ascii/authors.txt | 0 {core => extra}/ascii/summary.txt | 0 {core => extra}/ascii/tags.txt | 0 8 files changed, 16 insertions(+), 26 deletions(-) rename {core => extra}/ascii/ascii-docs.factor (100%) rename {core => extra}/ascii/ascii-tests.factor (100%) rename {core => extra}/ascii/ascii.factor (96%) rename {core => extra}/ascii/authors.txt (100%) rename {core => extra}/ascii/summary.txt (100%) rename {core => extra}/ascii/tags.txt (100%) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 862b266d05..8b6ea57833 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -1,12 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic assocs kernel math namespaces prettyprint sequences strings vectors words quotations inspector io.styles io combinators sorting splitting math.parser effects continuations debugger io.files io.streams.string io.streams.lines vocabs -source-files classes hashtables compiler.errors compiler.units -ascii ; +source-files classes hashtables compiler.errors compiler.units ; IN: parser TUPLE: lexer text line column ; @@ -55,8 +54,9 @@ t parser-notes set-global 0 over set-lexer-column dup lexer-line 1+ swap set-lexer-line ; -: skip ( i seq quot -- n ) - over >r find* drop +: skip ( i seq ? -- n ) + over >r + [ swap CHAR: \s eq? xor ] curry find* drop [ r> drop ] [ r> length ] if* ; inline : change-column ( lexer quot -- ) @@ -67,14 +67,13 @@ t parser-notes set-global GENERIC: skip-blank ( lexer -- ) M: lexer skip-blank ( lexer -- ) - [ [ blank? not ] skip ] change-column ; + [ t skip ] change-column ; GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = - [ drop 1+ ] [ [ blank? ] skip ] if + 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index a5d0cee6c5..e64295cc0c 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays byte-arrays byte-vectors bit-arrays bit-vectors generic hashtables io assocs kernel math namespaces sequences strings sbufs io.styles vectors words prettyprint.config prettyprint.sections quotations io io.files math.parser effects -tuples classes float-arrays float-vectors ascii ; +tuples classes float-arrays float-vectors ; IN: prettyprint.backend GENERIC: pprint* ( obj -- ) @@ -58,24 +58,17 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ - { CHAR: \e "\\e" } - { CHAR: \n "\\n" } - { CHAR: \r "\\r" } - { CHAR: \t "\\t" } - { CHAR: \0 "\\0" } - { CHAR: \\ "\\\\" } - { CHAR: \" "\\\"" } + { CHAR: \e CHAR: \\e } + { CHAR: \n CHAR: \\n } + { CHAR: \r CHAR: \\r } + { CHAR: \t CHAR: \\t } + { CHAR: \0 CHAR: \\0 } + { CHAR: \\ CHAR: \\\\ } + { CHAR: \" CHAR: \\\" } } at ; -: ch>unicode-escape ( ch -- str ) - >hex 6 CHAR: 0 pad-left "\\u" swap append ; - : unparse-ch ( ch -- ) - dup quotable? [ - , - ] [ - dup ch>ascii-escape [ ] [ ch>unicode-escape ] ?if % - ] if ; + dup ch>ascii-escape [ ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) string-limit get [ diff --git a/core/ascii/ascii-docs.factor b/extra/ascii/ascii-docs.factor similarity index 100% rename from core/ascii/ascii-docs.factor rename to extra/ascii/ascii-docs.factor diff --git a/core/ascii/ascii-tests.factor b/extra/ascii/ascii-tests.factor similarity index 100% rename from core/ascii/ascii-tests.factor rename to extra/ascii/ascii-tests.factor diff --git a/core/ascii/ascii.factor b/extra/ascii/ascii.factor similarity index 96% rename from core/ascii/ascii.factor rename to extra/ascii/ascii.factor index 019db5f3b2..e4a365cd1b 100755 --- a/core/ascii/ascii.factor +++ b/extra/ascii/ascii.factor @@ -24,5 +24,3 @@ IN: ascii : alpha? ( ch -- ? ) dup Letter? [ drop t ] [ digit? ] if ; inline - - diff --git a/core/ascii/authors.txt b/extra/ascii/authors.txt similarity index 100% rename from core/ascii/authors.txt rename to extra/ascii/authors.txt diff --git a/core/ascii/summary.txt b/extra/ascii/summary.txt similarity index 100% rename from core/ascii/summary.txt rename to extra/ascii/summary.txt diff --git a/core/ascii/tags.txt b/extra/ascii/tags.txt similarity index 100% rename from core/ascii/tags.txt rename to extra/ascii/tags.txt From bff385269c6eb9ce50f2188cf8ecc424b37a3346 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 1 Feb 2008 18:26:32 -0600 Subject: [PATCH 067/317] Lot's of USING: fixes for ascii or unicode --- core/parser/parser.factor | 76 ++++++++++--------- .../benchmark/knucleotide/knucleotide.factor | 2 +- .../reverse-complement.factor | 2 +- extra/cryptlib/cryptlib.factor | 2 +- extra/fjsc/fjsc.factor | 2 +- extra/globs/globs.factor | 2 +- extra/hexdump/hexdump.factor | 4 +- extra/id3/id3.factor | 2 +- extra/irc/irc.factor | 2 +- extra/json/reader/reader.factor | 2 +- extra/lint/lint.factor | 5 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/peg/ebnf/ebnf.factor | 3 +- extra/peg/peg.factor | 3 +- extra/project-euler/017/017.factor | 3 +- extra/project-euler/022/022.factor | 2 +- extra/prolog/prolog.factor | 2 +- extra/regexp/regexp.factor | 2 +- extra/roman/roman.factor | 2 +- extra/rot13/rot13.factor | 2 +- extra/sequences/lib/lib.factor | 4 +- extra/state-parser/state-parser.factor | 2 +- extra/strings/lib/lib.factor | 16 ++-- extra/xml/tokenize/tokenize.factor | 2 +- extra/xml/xml.factor | 2 +- extra/xmode/keyword-map/keyword-map.factor | 3 +- extra/xmode/marker/marker.factor | 2 +- extra/xmode/rules/rules.factor | 2 +- 28 files changed, 81 insertions(+), 74 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 862b266d05..6825029a8e 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -348,45 +348,49 @@ SYMBOL: bootstrap-syntax call ] with-scope ; inline +SYMBOL: interactive-vocabs + +{ + "arrays" + "assocs" + "combinators" + "compiler.errors" + "continuations" + "debugger" + "definitions" + "editors" + "generic" + "help" + "inspector" + "io" + "io.files" + "kernel" + "listener" + "math" + "memory" + "namespaces" + "prettyprint" + "sequences" + "slicing" + "sorting" + "strings" + "syntax" + "tools.annotations" + "tools.crossref" + "tools.memory" + "tools.profiler" + "tools.test" + "tools.time" + "vocabs" + "vocabs.loader" + "words" + "scratchpad" +} interactive-vocabs set-global + : with-interactive-vocabs ( quot -- ) [ "scratchpad" in set - { - "arrays" - "assocs" - "combinators" - "compiler.errors" - "continuations" - "debugger" - "definitions" - "editors" - "generic" - "help" - "inspector" - "io" - "io.files" - "kernel" - "listener" - "math" - "memory" - "namespaces" - "prettyprint" - "sequences" - "slicing" - "sorting" - "strings" - "syntax" - "tools.annotations" - "tools.crossref" - "tools.memory" - "tools.profiler" - "tools.test" - "tools.time" - "vocabs" - "vocabs.loader" - "words" - "scratchpad" - } set-use + interactive-vocabs get set-use call ] with-scope ; inline diff --git a/extra/benchmark/knucleotide/knucleotide.factor b/extra/benchmark/knucleotide/knucleotide.factor index f036a644ae..ad1ffc1c50 100644 --- a/extra/benchmark/knucleotide/knucleotide.factor +++ b/extra/benchmark/knucleotide/knucleotide.factor @@ -1,6 +1,6 @@ USING: kernel io io.files splitting strings hashtables sequences assocs math namespaces prettyprint - math.parser combinators arrays sorting ; + math.parser combinators arrays sorting unicode.case ; IN: benchmark.knucleotide diff --git a/extra/benchmark/reverse-complement/reverse-complement.factor b/extra/benchmark/reverse-complement/reverse-complement.factor index 332489abed..7b09b586f4 100644 --- a/extra/benchmark/reverse-complement/reverse-complement.factor +++ b/extra/benchmark/reverse-complement/reverse-complement.factor @@ -1,6 +1,6 @@ USING: io io.files io.streams.duplex kernel sequences sequences.private strings vectors words memoize splitting -hints ; +hints unicode.case ; IN: benchmark.reverse-complement MEMO: trans-map ( -- str ) diff --git a/extra/cryptlib/cryptlib.factor b/extra/cryptlib/cryptlib.factor index 65d2ffe48f..2ba81ef15a 100644 --- a/extra/cryptlib/cryptlib.factor +++ b/extra/cryptlib/cryptlib.factor @@ -6,7 +6,7 @@ ! Adapted from cryptlib.h ! Tested with cryptlib 3.3.1.0 USING: cryptlib.libcl kernel hashtables alien math -namespaces sequences assocs libc alien.c-types continuations ; +namespaces sequences assocs libc alien.c-types alien.accessors continuations ; IN: cryptlib diff --git a/extra/fjsc/fjsc.factor b/extra/fjsc/fjsc.factor index fdeed339d8..6beb48e05e 100755 --- a/extra/fjsc/fjsc.factor +++ b/extra/fjsc/fjsc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel peg strings promises sequences math math.parser namespaces words quotations arrays hashtables io - io.streams.string assocs memoize ; + io.streams.string assocs memoize ascii ; IN: fjsc TUPLE: ast-number value ; diff --git a/extra/globs/globs.factor b/extra/globs/globs.factor index 901191b51e..7204693016 100755 --- a/extra/globs/globs.factor +++ b/extra/globs/globs.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators regexp lazy-lists sequences kernel -promises strings ; +promises strings unicode.case ; IN: globs digit ( c -- i ) 48 - ; +! : char>digit ( c -- i ) 48 - ; -: string>digits ( s -- seq ) [ char>digit ] { } map-as ; +! : string>digits ( s -- seq ) [ char>digit ] { } map-as ; -: >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string swap append - ] unless ; +! : >Upper ( str -- str ) +! dup empty? [ +! unclip ch>upper 1string swap append +! ] unless ; -: >Upper-dashes ( str -- str ) - "-" split [ >Upper ] map "-" join ; +! : >Upper-dashes ( str -- str ) +! "-" split [ >Upper ] map "-" join ; diff --git a/extra/xml/tokenize/tokenize.factor b/extra/xml/tokenize/tokenize.factor index 85a473f503..d99c306b2b 100644 --- a/extra/xml/tokenize/tokenize.factor +++ b/extra/xml/tokenize/tokenize.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: xml.errors xml.data xml.utilities xml.char-classes xml.entities kernel state-parser kernel namespaces strings math -math.parser sequences assocs arrays splitting combinators ; +math.parser sequences assocs arrays splitting combinators unicode.case ; IN: xml.tokenize ! XML namespace processing: ns = namespace diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 826b16b213..65a8e28dea 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs ; +xml.utilities state-parser assocs unicode.categories ; IN: xml ! -- Overall parser with data tree diff --git a/extra/xmode/keyword-map/keyword-map.factor b/extra/xmode/keyword-map/keyword-map.factor index 350d8572a0..4e97e597b2 100644 --- a/extra/xmode/keyword-map/keyword-map.factor +++ b/extra/xmode/keyword-map/keyword-map.factor @@ -1,4 +1,5 @@ -USING: kernel strings assocs sequences hashtables sorting ; +USING: kernel strings assocs sequences hashtables sorting + unicode.case unicode.categories ; IN: xmode.keyword-map ! Based on org.gjt.sp.jedit.syntax.KeywordMap diff --git a/extra/xmode/marker/marker.factor b/extra/xmode/marker/marker.factor index b8331fe6b6..91ccd43907 100755 --- a/extra/xmode/marker/marker.factor +++ b/extra/xmode/marker/marker.factor @@ -2,7 +2,7 @@ IN: xmode.marker USING: kernel namespaces xmode.rules xmode.tokens xmode.marker.state xmode.marker.context xmode.utilities xmode.catalog sequences math assocs combinators combinators.lib -strings regexp splitting parser-combinators ; +strings regexp splitting parser-combinators ascii unicode.case ; ! Based on org.gjt.sp.jedit.syntax.TokenMarker diff --git a/extra/xmode/rules/rules.factor b/extra/xmode/rules/rules.factor index acc6308c6f..28237a7b2c 100755 --- a/extra/xmode/rules/rules.factor +++ b/extra/xmode/rules/rules.factor @@ -1,5 +1,5 @@ USING: xmode.tokens xmode.keyword-map kernel -sequences vectors assocs strings memoize regexp ; +sequences vectors assocs strings memoize regexp unicode.case ; IN: xmode.rules TUPLE: string-matcher string ignore-case? ; From c75b51bd58a32ffea6b020840fd097c37421cda8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 18:28:10 -0600 Subject: [PATCH 068/317] URL encoding uses ascii --- extra/http/http.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/http/http.factor b/extra/http/http.factor index 9e5d34fa36..7beb3b9da0 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ; +sequences strings splitting ascii ; IN: http : header-line ( line -- ) @@ -20,7 +20,7 @@ IN: http dup letter? over LETTER? or over digit? or - swap "/_-?." member? or ; foldable + swap "/_-." member? or ; foldable : url-encode ( str -- str ) [ From 9f1bcc5d224c80c66315ddd4989eeec8ccb19914 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 18:36:13 -0600 Subject: [PATCH 069/317] Fix resize-string --- core/strings/strings-tests.factor | 5 +++++ vm/data_gc.c | 3 ++- vm/types.c | 26 ++++++++++++++++++++++++-- vm/types.h | 4 ++-- 4 files changed, 33 insertions(+), 5 deletions(-) diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 5ab7f1dffe..459ec7b153 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -51,6 +51,9 @@ unit-test [ "ab" ] [ 2 "abc" resize-string ] unit-test [ "abc\0\0\0" ] [ 6 "abc" resize-string ] unit-test +[ "\u001234b" ] [ 2 "\u001234bc" resize-string ] unit-test +[ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test + ! Random tester found this [ { "kernel-error" 3 12 -7 } ] [ [ 2 -7 resize-string ] catch ] unit-test @@ -88,3 +91,5 @@ unit-test "\udeadbe" clone CHAR: \u123456 over clone set-first ] unit-test + + diff --git a/vm/data_gc.c b/vm/data_gc.c index 3ca41d602c..601a677920 100755 --- a/vm/data_gc.c +++ b/vm/data_gc.c @@ -505,7 +505,6 @@ CELL binary_payload_start(CELL pointer) switch(untag_header(get(pointer))) { /* these objects do not refer to other objects at all */ - case STRING_TYPE: case FLOAT_TYPE: case BYTE_ARRAY_TYPE: case BIT_ARRAY_TYPE: @@ -522,6 +521,8 @@ CELL binary_payload_start(CELL pointer) return CELLS * 2; case QUOTATION_TYPE: return sizeof(F_QUOTATION) - CELLS * 2; + case STRING_TYPE: + return sizeof(F_STRING); /* everything else consists entirely of pointers */ default: return unaligned_object_size(pointer); diff --git a/vm/types.c b/vm/types.c index 1f0287b1f0..24b5e7ff07 100755 --- a/vm/types.c +++ b/vm/types.c @@ -480,7 +480,16 @@ F_STRING* allot_string_internal(CELL capacity) void fill_string(F_STRING *string, CELL start, CELL capacity, CELL fill) { if(fill == 0) - memset((void*)SREF(string,start),'\0',capacity - start); + { + memset((void *)SREF(string,start),'\0',capacity - start); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + memset((void *)BREF(aux,start * sizeof(u16)),'\0', + (capacity - start) * sizeof(u16)); + } + } else { CELL i; @@ -523,6 +532,19 @@ F_STRING* reallot_string(F_STRING* string, CELL capacity, CELL fill) memcpy(new_string + 1,string + 1,to_copy); + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + new_string->aux = tag_object(new_aux); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + REGISTER_UNTAGGED(string); fill_string(new_string,to_copy,capacity,fill); UNREGISTER_UNTAGGED(string); @@ -573,7 +595,7 @@ DEFINE_PRIMITIVE(resize_string) MEMORY_TO_STRING(char,u8) MEMORY_TO_STRING(u16,u16) -// MEMORY_TO_STRING(u32,u32) +MEMORY_TO_STRING(u32,u32) bool check_string(F_STRING *s, CELL max) { diff --git a/vm/types.h b/vm/types.h index 6f4234af34..e5003ea069 100755 --- a/vm/types.h +++ b/vm/types.h @@ -83,8 +83,8 @@ INLINE CELL array_capacity(F_ARRAY* array) return array->capacity >> TAG_BITS; } -#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + index) -#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index) +#define BREF(byte_array,index) ((CELL)byte_array + sizeof(F_BYTE_ARRAY) + (index)) +#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + (index)) INLINE F_STRING* untag_string(CELL tagged) { From 6851b16b3932a0ee057e0423c3a587279726a082 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 18:36:20 -0600 Subject: [PATCH 070/317] Remove dan's make* --- extra/unicode/case/case.factor | 15 ++++++++------- extra/unicode/normalize/normalize.factor | 11 ----------- 2 files changed, 8 insertions(+), 18 deletions(-) diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index 96ae9a790b..ee9e2a0381 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -1,5 +1,6 @@ -USING: kernel unicode.data sequences sequences.next namespaces assocs.lib -unicode.normalize math unicode.categories combinators assocs ; +USING: kernel unicode.data sequences sequences.next namespaces +assocs.lib unicode.normalize math unicode.categories combinators +assocs ; IN: unicode.case : ch>lower ( ch -- lower ) simple-lower at-default ; @@ -20,7 +21,7 @@ SYMBOL: locale ! Just casing locale, or overall? [ swap dot-over = over "ij" member? and swap , ] if ; : lithuanian>upper ( string -- lower ) - [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make* ; + [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ; : mark-above? ( ch -- ? ) combining-class 230 = ; @@ -32,14 +33,14 @@ SYMBOL: locale ! Just casing locale, or overall? dup , "IJ" member? swap mark-above? and [ dot-over , ] when ; : lithuanian>lower ( string -- lower ) - [ [ lithuanian-ch>lower ] each-next ] "" make* ; + [ [ lithuanian-ch>lower ] each-next ] "" make ; : turk-ch>upper ( ch -- ) dup CHAR: i = [ drop CHAR: I , dot-over , ] [ , ] if ; : turk>upper ( string -- upper-i ) - [ [ turk-ch>upper ] each ] "" make* ; + [ [ turk-ch>upper ] each ] "" make ; : turk-ch>lower ( ? next ch -- ? ) { @@ -52,7 +53,7 @@ SYMBOL: locale ! Just casing locale, or overall? } cond ; : turk>lower ( string -- lower-i ) - [ f swap [ turk-ch>lower ] each-next drop ] "" make* ; + [ f swap [ turk-ch>lower ] each-next drop ] "" make ; : word-boundary ( prev char -- new ? ) dup non-starter? [ drop dup ] when @@ -76,7 +77,7 @@ SYMBOL: locale ! Just casing locale, or overall? [ -rot nip call , ] ?if ] 2keep ] each 2drop - ] "" make* ; inline + ] "" make ; inline : >lower ( string -- lower ) i-dot? [ turk>lower ] when diff --git a/extra/unicode/normalize/normalize.factor b/extra/unicode/normalize/normalize.factor index b018d115f8..47637e8330 100644 --- a/extra/unicode/normalize/normalize.factor +++ b/extra/unicode/normalize/normalize.factor @@ -2,17 +2,6 @@ USING: sequences namespaces unicode.data kernel combinators.lib math arrays ; IN: unicode.normalize -! Utility word--probably unnecessary -: make* ( seq quot exemplar -- newseq ) - ! quot has access to original seq on stack - ! this just makes the new-resizable the same length as seq - [ - [ - pick length swap new-resizable - [ building set call ] keep - ] keep like - ] with-scope ; inline - ! Conjoining Jamo behavior : hangul-base HEX: ac00 ; inline From 1e477cfc4af593088b2feb259264cf1f7addefda Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 18:38:29 -0600 Subject: [PATCH 071/317] URL encoding/decoding uses UTF-8 now --- extra/http/http-tests.factor | 2 ++ extra/http/http.factor | 19 ++++++++----------- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/extra/http/http-tests.factor b/extra/http/http-tests.factor index 853ac28f72..5146502644 100644 --- a/extra/http/http-tests.factor +++ b/extra/http/http-tests.factor @@ -14,3 +14,5 @@ IN: temporary [ "hello world" ] [ "hello world%x" url-decode ] unit-test [ "hello%20world" ] [ "hello world" url-encode ] unit-test [ "%20%21%20" ] [ " ! " url-encode ] unit-test + +[ "\u001234hi\u002045" ] [ "\u001234hi\u002045" url-encode url-decode ] unit-test diff --git a/extra/http/http.factor b/extra/http/http.factor index 7beb3b9da0..1bd9e18d98 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii ; +sequences strings splitting ascii io.utf8 ; IN: http : header-line ( line -- ) @@ -22,16 +22,13 @@ IN: http over digit? or swap "/_-." member? or ; foldable +: push-utf8 ( string -- ) + 1string encode-utf8 [ CHAR: % , >hex 2 CHAR: 0 pad-left % ] each ; + : url-encode ( str -- str ) - [ - [ - dup url-quotable? [ - , - ] [ - CHAR: % , >hex 2 CHAR: 0 pad-left % - ] if - ] each - ] "" make ; + [ [ + dup url-quotable? [ , ] [ push-utf8 ] if + ] each ] "" make ; : url-decode-hex ( index str -- ) 2dup length 2 - >= [ @@ -58,7 +55,7 @@ IN: http ] if ; : url-decode ( str -- str ) - [ 0 swap url-decode-iter ] "" make ; + [ 0 swap url-decode-iter ] "" make decode-utf8 ; : hash>query ( hash -- str ) [ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map From 6f2b91d4a4a9acdd83161a0d1ae884b423c59ae4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 1 Feb 2008 18:10:32 -0800 Subject: [PATCH 072/317] Move byte-length generic and methods into alien.c-types --- core/alien/alien-docs.factor | 4 ---- core/alien/alien.factor | 2 -- core/alien/c-types/c-types-docs.factor | 4 ++++ core/alien/c-types/c-types.factor | 8 +++++++- core/byte-arrays/byte-arrays.factor | 2 -- core/float-arrays/float-arrays.factor | 3 +-- 6 files changed, 12 insertions(+), 11 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 8ae89ed5b1..8fee0e8c3e 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -34,10 +34,6 @@ HELP: { $description "Creates an alien object, wrapping a raw memory address." } { $notes "Alien objects are invalidated between image saves and loads." } ; -HELP: byte-length -{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } -{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; - HELP: c-ptr { $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ; diff --git a/core/alien/alien.factor b/core/alien/alien.factor index 4b899a15e4..1c8163e2fa 100755 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -28,8 +28,6 @@ PREDICATE: alien pinned-alien UNION: pinned-c-ptr pinned-alien POSTPONE: f ; -GENERIC: byte-length ( seq -- n ) flushable - M: f expired? drop t ; : ( address -- alien ) diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index f6418295f7..f4aa297a3a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -34,6 +34,10 @@ HELP: stack-size { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; +HELP: byte-length +{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } +{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; + HELP: c-getter { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 1ecfa37ee6..47f9fd0326 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays arrays generator.registers assocs +USING: byte-arrays float-arrays arrays generator.registers assocs kernel kernel.private libc math namespaces parser sequences strings words assocs splitting math.parser cpu.architecture alien quotations system compiler.units ; @@ -107,6 +107,12 @@ M: string stack-size c-type stack-size ; M: c-type stack-size c-type-size ; +GENERIC: byte-length ( seq -- n ) flushable + +M: float-array byte-length length "float" heap-size * ; + +M: byte-array byte-length length ; + : c-getter ( name -- quot ) c-type c-type-getter [ [ "Cannot read struct fields with type" throw ] diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index 295c6c4384..401b151ad0 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -15,8 +15,6 @@ M: byte-array new drop ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; -M: byte-array byte-length - length ; M: byte-array resize resize-byte-array ; diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index 948e41ef7a..445edd550a 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel kernel.private alien alien.c-types sequences +USING: kernel kernel.private alien sequences sequences.private math math.private ; IN: float-arrays @@ -12,7 +12,6 @@ PRIVATE> M: float-array clone (clone) ; M: float-array length array-capacity ; -M: float-array byte-length array-capacity "float" heap-size * ; M: float-array nth-unsafe float-array@ alien-double ; From db3ac4d75ff5835d49bd9821cd303d724f330a6d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 22:46:03 -0600 Subject: [PATCH 073/317] intermediate work on cookies --- extra/http/http.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/http/http.factor b/extra/http/http.factor index 9e5d34fa36..a71e003433 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,18 +1,18 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ; +sequences strings splitting assocs.lib ; IN: http : header-line ( line -- ) - ": " split1 dup [ swap set ] [ 2drop ] if ; + ": " split1 dup [ swap >lower set ] [ 2drop ] if ; : (read-header) ( -- ) readln dup empty? [ drop ] [ header-line (read-header) ] if ; : read-header ( -- hash ) - [ (read-header) ] H{ } make-assoc ; + [ (read-header) ] VH{ } make-assoc ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without @@ -74,4 +74,3 @@ IN: http hash>query % ] if ] "" make ; - From 004dd0dc5e97f60bf917b2af99673c3fa2bbe754 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 22:46:32 -0600 Subject: [PATCH 074/317] add accumulator --- extra/sequences/lib/lib.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index e46ce3b107..9aac0a50bd 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -140,3 +140,6 @@ PRIVATE> : ?second ( seq -- second/f ) 1 swap ?nth ; inline : ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline + +: accumulator ( quot -- quot vec ) + V{ } clone [ [ push ] curry compose ] keep ; From 2d381ed84e2845a1174480bcc79eb54ebf02a3d6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 22:47:01 -0600 Subject: [PATCH 075/317] Fix http server --- extra/http/server/templating/templating.factor | 2 +- extra/io/server/server.factor | 6 +++--- extra/webapps/cgi/cgi.factor | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index 69f8b4e7fd..f5de4664a1 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -25,7 +25,7 @@ M: template-lexer skip-word { { [ 2dup nth CHAR: " = ] [ drop 1+ ] } { [ 2dup swap tail-slice "%>" head? ] [ drop 2 + ] } - { [ t ] [ [ blank? ] skip ] } + { [ t ] [ f skip ] } } cond ] change-column ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 6e7cd5a940..408fd29714 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -29,7 +29,7 @@ SYMBOL: log-stream : with-log-file ( file quot -- ) >r r> - [ with-log-stream ] with-disposal ; inline + [ with-log-stream ] curry with-disposal ; inline : with-log-stdio ( quot -- ) stdio get swap with-log-stream ; @@ -47,11 +47,11 @@ SYMBOL: log-stream dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline -: accept-loop ( server quot -- server quot ) +: accept-loop ( server quot -- ) [ swap accept with-client ] 2keep accept-loop ; inline : server-loop ( server quot -- ) - [ accept-loop ] compose with-disposal ; inline + [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) "Waiting for connections on " pick unparse append diff --git a/extra/webapps/cgi/cgi.factor b/extra/webapps/cgi/cgi.factor index 9dd9dca39c..967036a797 100644 --- a/extra/webapps/cgi/cgi.factor +++ b/extra/webapps/cgi/cgi.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs io.files combinators arrays io.launcher io http.server.responders webapps.file -sequences strings math.parser ; +sequences strings math.parser unicode.case ; IN: webapps.cgi SYMBOL: cgi-root @@ -31,7 +31,7 @@ SYMBOL: cgi-root "method" get >upper "REQUEST_METHOD" set "raw-query" get "QUERY_STRING" set - "Cookie" header-param "HTTP_COOKIE" set + "Cookie" header-param "HTTP_COOKIE" set "User-Agent" header-param "HTTP_USER_AGENT" set "Accept" header-param "HTTP_ACCEPT" set From 64650d8500e99b88fcbb19570537a2232fab77da Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 22:50:30 -0600 Subject: [PATCH 076/317] Fixing UTF-8 to put the replacement character for malformed stuff --- core/io/utf8/utf8-tests.factor | 12 ++++++------ core/io/utf8/utf8.factor | 2 +- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/core/io/utf8/utf8-tests.factor b/core/io/utf8/utf8-tests.factor index d120b6243d..3576471586 100644 --- a/core/io/utf8/utf8-tests.factor +++ b/core/io/utf8/utf8-tests.factor @@ -1,16 +1,16 @@ -USING: io.utf8 tools.test strings ; +USING: io.utf8 tools.test strings arrays unicode.syntax ; -[ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 ] unit-test-fails +[ { UNICHAR: replacement-character } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 11111111 } decode-utf8 >array ] unit-test -[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 ] unit-test +[ { BIN: 101111111000000111111 } ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test [ "x" ] [ "x" decode-utf8 >string ] unit-test -[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 ] unit-test +[ { BIN: 11111000000 } ] [ { BIN: 11011111 BIN: 10000000 } decode-utf8 >array ] unit-test -[ { BIN: 10000000 } decode-utf8 ] unit-test-fails +[ { UNICHAR: replacement-character } ] [ { BIN: 10000000 } decode-utf8 >array ] unit-test -[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 ] unit-test +[ { BIN: 1111000000111111 } ] [ { BIN: 11101111 BIN: 10000000 BIN: 10111111 } decode-utf8 >array ] unit-test [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ] [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } encode-utf8 ] unit-test diff --git a/core/io/utf8/utf8.factor b/core/io/utf8/utf8.factor index 321469378d..213afb6eae 100644 --- a/core/io/utf8/utf8.factor +++ b/core/io/utf8/utf8.factor @@ -29,7 +29,7 @@ SYMBOL: quad3 } cond ; : end-multibyte ( buf byte ch -- buf ch state ) - begin append-nums decoded ; + f append-nums [ decoded ] unless* ; : (decode-utf8) ( buf byte ch state -- buf ch state ) { From 68b3d8e1d96800a47d2a78ffaa16d565e27e7ba6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 1 Feb 2008 23:07:19 -0600 Subject: [PATCH 077/317] Tabs are banned --- core/bootstrap/primitives.factor | 14 +++++++------- core/prettyprint/backend/backend.factor | 16 ++++++++-------- core/strings/strings.factor | 2 +- 3 files changed, 16 insertions(+), 16 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index fef93e163f..545d904c9c 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -15,12 +15,12 @@ crossref off "resource:core/bootstrap/syntax.factor" parse-file "resource:core/cpu/" architecture get { - { "x86.32" "x86/32" } - { "x86.64" "x86/64" } - { "linux-ppc" "ppc/linux" } - { "macosx-ppc" "ppc/macosx" } - { "arm" "arm" } - } at "/bootstrap.factor" 3append parse-file + { "x86.32" "x86/32" } + { "x86.64" "x86/64" } + { "linux-ppc" "ppc/linux" } + { "macosx-ppc" "ppc/macosx" } + { "arm" "arm" } +} at "/bootstrap.factor" 3append parse-file "resource:core/bootstrap/layouts/layouts.factor" parse-file @@ -626,7 +626,7 @@ builtins get num-tags get tail f union-class define-class { "" "float-arrays" } { "curry" "kernel" } { "" "tuples.private" } - { "class-hash" "kernel.private" } + { "class-hash" "kernel.private" } { "callstack>array" "kernel" } { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index e64295cc0c..a85e23100d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -58,17 +58,17 @@ M: f pprint* drop \ f pprint-word ; ! Strings : ch>ascii-escape ( ch -- str ) H{ - { CHAR: \e CHAR: \\e } - { CHAR: \n CHAR: \\n } - { CHAR: \r CHAR: \\r } - { CHAR: \t CHAR: \\t } - { CHAR: \0 CHAR: \\0 } - { CHAR: \\ CHAR: \\\\ } - { CHAR: \" CHAR: \\\" } + { CHAR: \e CHAR: e } + { CHAR: \n CHAR: n } + { CHAR: \r CHAR: r } + { CHAR: \t CHAR: t } + { CHAR: \0 CHAR: 0 } + { CHAR: \\ CHAR: \\ } + { CHAR: \" CHAR: \" } } at ; : unparse-ch ( ch -- ) - dup ch>ascii-escape [ ] [ ] ?if , ; + dup ch>ascii-escape [ "\\" % ] [ ] ?if , ; : do-string-limit ( str -- trimmed ) string-limit get [ diff --git a/core/strings/strings.factor b/core/strings/strings.factor index 50c75d784e..bb3c94ce97 100755 --- a/core/strings/strings.factor +++ b/core/strings/strings.factor @@ -38,7 +38,7 @@ M: string set-nth-unsafe >r >fixnum >r >fixnum r> r> set-string-nth ; M: string clone - (clone) dup string-aux clone over set-string-aux ; + (clone) dup string-aux clone over set-string-aux ; M: string resize resize-string ; From 9e9c71b6d0925d5929bbb10a20807fd3d75cfb6c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 23:46:44 -0600 Subject: [PATCH 078/317] make multi-assocs work for http headers --- extra/http/client/client.factor | 4 +-- extra/http/http.factor | 7 +++-- .../http/server/responders/responders.factor | 28 +++++++++++-------- 3 files changed, 22 insertions(+), 17 deletions(-) diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 7eb84fba4c..8e6d8257a4 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files strings splitting -continuations ; +continuations assocs.lib ; IN: http.client : parse-host ( url -- host port ) @@ -44,7 +44,7 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - dispose "location" swap header-single nip http-get-stream + dispose "location" swap peek-at nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 4999559324..755f36a538 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -1,18 +1,19 @@ ! Copyright (C) 2003, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: hashtables io kernel math namespaces math.parser assocs -sequences strings splitting ascii io.utf8 assocs.lib ; +sequences strings splitting ascii io.utf8 assocs.lib +namespaces unicode.case ; IN: http : header-line ( line -- ) - ": " split1 dup [ swap >lower set ] [ 2drop ] if ; + ": " split1 dup [ swap >lower insert ] [ 2drop ] if ; : (read-header) ( -- ) readln dup empty? [ drop ] [ header-line (read-header) ] if ; : read-header ( -- hash ) - [ (read-header) ] VH{ } make-assoc ; + [ (read-header) ] H{ } make-assoc ; : url-quotable? ( ch -- ? ) #! In a URL, can this character be used without diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 8dcaa7223d..a507a95a14 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server ; +strings io.server vectors vector-hash strings.lib ; IN: http.server.responders @@ -10,8 +10,11 @@ IN: http.server.responders SYMBOL: vhosts SYMBOL: responders +: >header ( value key -- vector-hash ) + VH{ } clone [ set-at ] keep ; + : print-header ( alist -- ) - [ swap write ": " write print ] assoc-each nl ; + [ swap >Upper-dashes write ": " write print ] vector-hash-each nl ; : response ( msg -- ) "HTTP/1.0 " write print ; @@ -20,7 +23,7 @@ SYMBOL: responders : error-head ( error -- ) dup log-error response - H{ { "Content-Type" "text/html" } } print-header nl ; + VH{ { "Content-Type" "text/html" } } print-header nl ; : httpd-error ( error -- ) #! This must be run from handle-request @@ -36,7 +39,7 @@ SYMBOL: responders : serving-content ( mime -- ) "200 Document follows" response - "Content-Type" associate print-header ; + "Content-Type" >header print-header ; : serving-html "text/html" serving-content ; @@ -46,7 +49,7 @@ SYMBOL: responders : serving-text "text/plain" serving-content ; : redirect ( to response -- ) - response "Location" associate print-header ; + response "Location" >header print-header ; : permanent-redirect ( to -- ) "301 Moved Permanently" redirect ; @@ -84,14 +87,14 @@ SYMBOL: max-post-request : log-headers ( hash -- ) [ drop { - "User-Agent" - "Referer" - "X-Forwarded-For" - "Host" + "user-agent" + "referer" + "x-forwarded-for" + "host" } member? ] assoc-subset [ ": " swap 3append log-message - ] assoc-each ; + ] vector-hash-each ; : prepare-url ( url -- url ) #! This is executed in the with-request namespace. @@ -122,7 +125,8 @@ SYMBOL: max-post-request : query-param ( key -- value ) "query" get at ; -: header-param ( key -- value ) "header" get at ; +: header-param ( key -- value ) + "header" get peek-at ; : host ( -- string ) #! The host the current responder was called from. @@ -130,7 +134,7 @@ SYMBOL: max-post-request : add-responder ( responder -- ) #! Add a responder object to the list. - "responder" over at responders get set-at ; + "responder" over at responders get set-at ; : make-responder ( quot -- ) #! quot has stack effect ( url -- ) From 22eb97778e04197530130d280959832db727111d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 23:47:37 -0600 Subject: [PATCH 079/317] add multi-assocs --- extra/assocs/lib/lib.factor | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 849f88023f..182f04a367 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,9 +1,6 @@ -USING: assocs kernel vectors sequences ; +USING: assocs kernel vectors sequences namespaces ; IN: assocs.lib -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : >set ( seq -- hash ) [ dup ] H{ } map>assoc ; @@ -19,5 +16,19 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; -: at-peek ( key assoc -- value ? ) - at* dup >r [ peek ] when r> ; +: insert-at ( value key assoc -- ) + [ ?push ] change-at ; + +: peek-at* ( key assoc -- obj ? ) + at* dup [ >r peek r> ] when ; + +: peek-at ( key assoc -- obj ) + peek-at* drop ; + +: >multi-assoc ( assoc -- new-assoc ) + [ 1vector ] assoc-map ; + +: multi-assoc-each ( assoc quot -- ) + [ with each ] curry assoc-each ; inline + +: insert ( value variable -- ) namespace insert-at ; From 698f4180bbd580c73f1cf3204cc83626a6245a7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 1 Feb 2008 23:47:54 -0600 Subject: [PATCH 080/317] add a wget-bootstrap option --- misc/factor.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index 39a15f93dc..032b0b3184 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -289,7 +289,7 @@ install_libraries() { } usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" + echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap" } case "$1" in @@ -299,5 +299,6 @@ case "$1" in quick-update) update; refresh_image ;; update) update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; + wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; esac From fce471f7ff0ba52c5989dd9cd8d301e1176f3527 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Sat, 2 Feb 2008 18:55:42 +1300 Subject: [PATCH 081/317] Remove dead code --- extra/sqlite/authors.txt | 1 - extra/sqlite/lib/authors.txt | 1 - extra/sqlite/lib/lib.factor | 120 -- extra/sqlite/sqlite-docs.factor | 87 - extra/sqlite/sqlite-tests.factor | 69 - extra/sqlite/sqlite.factor | 127 -- extra/sqlite/test.txt | 3 - extra/sqlite/tuple-db/authors.txt | 1 - extra/sqlite/tuple-db/tuple-db-docs.factor | 131 -- extra/sqlite/tuple-db/tuple-db-tests.factor | 39 - extra/sqlite/tuple-db/tuple-db.factor | 270 --- .../article-manager-docs.factor | 33 - .../article-manager/article-manager.factor | 165 -- extra/webapps/article-manager/authors.txt | 1 - .../article-manager/database/authors.txt | 1 - .../article-manager/database/database.factor | 118 -- .../article-manager/furnace/article.furnace | 13 - .../furnace/edit-article.furnace | 41 - .../article-manager/furnace/edit-head.furnace | 12 - .../article-manager/furnace/head.furnace | 4 - .../article-manager/furnace/index.furnace | 32 - .../furnace/navigation.furnace | 9 - .../furnace/setup-site.furnace | 33 - .../article-manager/furnace/tag.furnace | 16 - .../article-manager/furnace/tags.furnace | 6 - extra/webapps/article-manager/load.factor | 18 - .../article-manager/resources/jquery.js | 1 - .../jscalendar-1.0/calendar-blue.css | 232 --- .../jscalendar-1.0/calendar-blue2.css | 236 --- .../jscalendar-1.0/calendar-brown.css | 225 -- .../jscalendar-1.0/calendar-green.css | 229 --- .../jscalendar-1.0/calendar-setup.js | 200 -- .../jscalendar-1.0/calendar-setup_stripped.js | 21 - .../jscalendar-1.0/calendar-system.css | 251 --- .../resources/jscalendar-1.0/calendar-tas.css | 239 --- .../jscalendar-1.0/calendar-win2k-1.css | 271 --- .../jscalendar-1.0/calendar-win2k-2.css | 271 --- .../jscalendar-1.0/calendar-win2k-cold-1.css | 265 --- .../jscalendar-1.0/calendar-win2k-cold-2.css | 271 --- .../resources/jscalendar-1.0/calendar.js | 1806 ----------------- .../jscalendar-1.0/calendar_stripped.js | 14 - .../jscalendar-1.0/lang/calendar-af.js | 39 - .../jscalendar-1.0/lang/calendar-al.js | 101 - .../jscalendar-1.0/lang/calendar-bg.js | 124 -- .../jscalendar-1.0/lang/calendar-big5-utf8.js | 123 -- .../jscalendar-1.0/lang/calendar-big5.js | 123 -- .../jscalendar-1.0/lang/calendar-br.js | 108 - .../jscalendar-1.0/lang/calendar-ca.js | 123 -- .../jscalendar-1.0/lang/calendar-cs-utf8.js | 65 - .../jscalendar-1.0/lang/calendar-cs-win.js | 65 - .../jscalendar-1.0/lang/calendar-da.js | 123 -- .../jscalendar-1.0/lang/calendar-de.js | 124 -- .../jscalendar-1.0/lang/calendar-du.js | 45 - .../jscalendar-1.0/lang/calendar-el.js | 89 - .../jscalendar-1.0/lang/calendar-en.js | 127 -- .../jscalendar-1.0/lang/calendar-es.js | 129 -- .../jscalendar-1.0/lang/calendar-fi.js | 98 - .../jscalendar-1.0/lang/calendar-fr.js | 125 -- .../jscalendar-1.0/lang/calendar-he-utf8.js | 123 -- .../jscalendar-1.0/lang/calendar-hr-utf8.js | 49 - .../jscalendar-1.0/lang/calendar-hr.js | Bin 3088 -> 0 bytes .../jscalendar-1.0/lang/calendar-hu.js | 124 -- .../jscalendar-1.0/lang/calendar-it.js | 124 -- .../jscalendar-1.0/lang/calendar-jp.js | 45 - .../jscalendar-1.0/lang/calendar-ko-utf8.js | 120 -- .../jscalendar-1.0/lang/calendar-ko.js | 120 -- .../jscalendar-1.0/lang/calendar-lt-utf8.js | 114 -- .../jscalendar-1.0/lang/calendar-lt.js | 114 -- .../jscalendar-1.0/lang/calendar-lv.js | 123 -- .../jscalendar-1.0/lang/calendar-nl.js | 73 - .../jscalendar-1.0/lang/calendar-no.js | 114 -- .../jscalendar-1.0/lang/calendar-pl-utf8.js | 93 - .../jscalendar-1.0/lang/calendar-pl.js | 56 - .../jscalendar-1.0/lang/calendar-pt.js | 123 -- .../jscalendar-1.0/lang/calendar-ro.js | 66 - .../jscalendar-1.0/lang/calendar-ru.js | 123 -- .../jscalendar-1.0/lang/calendar-ru_win_.js | 123 -- .../jscalendar-1.0/lang/calendar-si.js | 94 - .../jscalendar-1.0/lang/calendar-sk.js | 99 - .../jscalendar-1.0/lang/calendar-sp.js | 110 - .../jscalendar-1.0/lang/calendar-sv.js | 93 - .../jscalendar-1.0/lang/calendar-tr.js | 58 - .../jscalendar-1.0/lang/calendar-zh.js | 119 -- .../resources/jscalendar-1.0/lang/cn_utf8.js | 123 -- .../article-manager/resources/style.css | 65 - .../article-manager/resources/wiky.css | 15 - .../webapps/article-manager/resources/wiky.js | 373 ---- .../article-manager/resources/wiky.lang.css | 9 - .../article-manager/resources/wiky.lang.js | 40 - .../article-manager/resources/wiky.math.css | 88 - .../article-manager/resources/wiky.math.js | 374 ---- extra/webapps/article-manager/summary.txt | 1 - extra/webapps/article-manager/tags.txt | 1 - unmaintained/jni/jni-internals.factor | 357 ---- unmaintained/jni/jni.factor | 22 - unmaintained/jni/load.factor | 4 - unmaintained/reader/reader.factor | 133 -- unmaintained/usb/load.factor | 13 - unmaintained/usb/usb-common.factor | 3 - unmaintained/usb/usb-macosx.factor | 61 - unmaintained/usb/usb-unix.factor | 61 - unmaintained/usb/usb-win32.factor | 61 - unmaintained/usb/usb.factor | 88 - unmaintained/usb/usb.facts | 44 - 104 files changed, 11950 deletions(-) delete mode 100755 extra/sqlite/authors.txt delete mode 100755 extra/sqlite/lib/authors.txt delete mode 100644 extra/sqlite/lib/lib.factor delete mode 100644 extra/sqlite/sqlite-docs.factor delete mode 100644 extra/sqlite/sqlite-tests.factor delete mode 100644 extra/sqlite/sqlite.factor delete mode 100644 extra/sqlite/test.txt delete mode 100755 extra/sqlite/tuple-db/authors.txt delete mode 100644 extra/sqlite/tuple-db/tuple-db-docs.factor delete mode 100644 extra/sqlite/tuple-db/tuple-db-tests.factor delete mode 100644 extra/sqlite/tuple-db/tuple-db.factor delete mode 100644 extra/webapps/article-manager/article-manager-docs.factor delete mode 100644 extra/webapps/article-manager/article-manager.factor delete mode 100644 extra/webapps/article-manager/authors.txt delete mode 100755 extra/webapps/article-manager/database/authors.txt delete mode 100644 extra/webapps/article-manager/database/database.factor delete mode 100644 extra/webapps/article-manager/furnace/article.furnace delete mode 100644 extra/webapps/article-manager/furnace/edit-article.furnace delete mode 100644 extra/webapps/article-manager/furnace/edit-head.furnace delete mode 100644 extra/webapps/article-manager/furnace/head.furnace delete mode 100644 extra/webapps/article-manager/furnace/index.furnace delete mode 100644 extra/webapps/article-manager/furnace/navigation.furnace delete mode 100644 extra/webapps/article-manager/furnace/setup-site.furnace delete mode 100644 extra/webapps/article-manager/furnace/tag.furnace delete mode 100644 extra/webapps/article-manager/furnace/tags.furnace delete mode 100644 extra/webapps/article-manager/load.factor delete mode 100644 extra/webapps/article-manager/resources/jquery.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-blue.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-blue2.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-brown.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-green.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup_stripped.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-system.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-tas.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-1.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-2.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-1.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-2.css delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/calendar_stripped.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-af.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-al.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-bg.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-br.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ca.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-win.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-da.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-de.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-du.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-el.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-en.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-es.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fi.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fr.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-he-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hu.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-it.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-jp.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lv.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-nl.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-no.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl-utf8.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pt.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ro.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru_win_.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-si.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sk.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sp.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sv.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-tr.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-zh.js delete mode 100644 extra/webapps/article-manager/resources/jscalendar-1.0/lang/cn_utf8.js delete mode 100644 extra/webapps/article-manager/resources/style.css delete mode 100644 extra/webapps/article-manager/resources/wiky.css delete mode 100644 extra/webapps/article-manager/resources/wiky.js delete mode 100644 extra/webapps/article-manager/resources/wiky.lang.css delete mode 100644 extra/webapps/article-manager/resources/wiky.lang.js delete mode 100644 extra/webapps/article-manager/resources/wiky.math.css delete mode 100644 extra/webapps/article-manager/resources/wiky.math.js delete mode 100644 extra/webapps/article-manager/summary.txt delete mode 100644 extra/webapps/article-manager/tags.txt delete mode 100644 unmaintained/jni/jni-internals.factor delete mode 100644 unmaintained/jni/jni.factor delete mode 100644 unmaintained/jni/load.factor delete mode 100644 unmaintained/reader/reader.factor delete mode 100644 unmaintained/usb/load.factor delete mode 100644 unmaintained/usb/usb-common.factor delete mode 100644 unmaintained/usb/usb-macosx.factor delete mode 100644 unmaintained/usb/usb-unix.factor delete mode 100644 unmaintained/usb/usb-win32.factor delete mode 100644 unmaintained/usb/usb.factor delete mode 100644 unmaintained/usb/usb.facts diff --git a/extra/sqlite/authors.txt b/extra/sqlite/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/lib/authors.txt b/extra/sqlite/lib/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/lib/lib.factor b/extra/sqlite/lib/lib.factor deleted file mode 100644 index 438f22a80f..0000000000 --- a/extra/sqlite/lib/lib.factor +++ /dev/null @@ -1,120 +0,0 @@ -! Copyright (C) 2005 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -! -! An interface to the sqlite database. Tested against sqlite v3.1.3. -! Remeber to pass the following to factor: -! -libraries:sqlite=libsqlite3.so -! -! Not all functions have been wrapped yet. Only those directly involving -! executing SQL calls and obtaining results. -! -IN: sqlite.lib -USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; - -<< -"sqlite" { - { [ win32? ] [ "sqlite3.dll" ] } - { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] } - { [ unix? ] [ "libsqlite3.so" ] } -} cond "cdecl" add-library ->> - -! Return values from sqlite functions -: SQLITE_OK 0 ; inline ! Successful result -: SQLITE_ERROR 1 ; inline ! SQL error or missing database -: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite -: SQLITE_PERM 3 ; inline ! Access permission denied -: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort -: SQLITE_BUSY 5 ; inline ! The database file is locked -: SQLITE_LOCKED 6 ; inline ! A table in the database is locked -: SQLITE_NOMEM 7 ; inline ! A malloc() failed -: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database -: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() -: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred -: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed -: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found -: SQLITE_FULL 13 ; inline ! Insertion failed because database is full -: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file -: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error -: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty -: SQLITE_SCHEMA 17 ; inline ! The database schema changed -: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table -: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation -: SQLITE_MISMATCH 20 ; inline ! Data type mismatch -: SQLITE_MISUSE 21 ; inline ! Library used incorrectly -: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host -: SQLITE_AUTH 23 ; inline ! Authorization denied -: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error -: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range -: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file - -: sqlite-error-messages ( -- seq ) { - "Successful result" - "SQL error or missing database" - "An internal logic error in SQLite" - "Access permission denied" - "Callback routine requested an abort" - "The database file is locked" - "A table in the database is locked" - "A malloc() failed" - "Attempt to write a readonly database" - "Operation terminated by sqlite_interrupt()" - "Some kind of disk I/O error occurred" - "The database disk image is malformed" - "(Internal Only) Table or record not found" - "Insertion failed because database is full" - "Unable to open the database file" - "Database lock protocol error" - "(Internal Only) Database table is empty" - "The database schema changed" - "Too much data for one row of a table" - "Abort due to contraint violation" - "Data type mismatch" - "Library used incorrectly" - "Uses OS features not supported on host" - "Authorization denied" - "Auxiliary database format error" - "2nd parameter to sqlite3_bind out of range" - "File opened that is not a database file" -} ; - -: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready -: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing - -! Return values from the sqlite3_column_type function -: SQLITE_INTEGER 1 ; inline -: SQLITE_FLOAT 2 ; inline -: SQLITE_TEXT 3 ; inline -: SQLITE_BLOB 4 ; inline -: SQLITE_NULL 5 ; inline - -! Values for the 'destructor' parameter of the 'bind' routines. -: SQLITE_STATIC 0 ; inline -: SQLITE_TRANSIENT -1 ; inline - -TYPEDEF: void sqlite3 -TYPEDEF: void sqlite3_stmt - -LIBRARY: sqlite -FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; -FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; -FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; -FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; -FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; -FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; -FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; -FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; -FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ; -FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; -FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ; - diff --git a/extra/sqlite/sqlite-docs.factor b/extra/sqlite/sqlite-docs.factor deleted file mode 100644 index d58b553f11..0000000000 --- a/extra/sqlite/sqlite-docs.factor +++ /dev/null @@ -1,87 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help help.syntax help.markup ; -IN: sqlite - -HELP: sqlite-open -{ $values { "filename" "path to sqlite database" } - { "db" "the database object" } -} -{ $description "Opens the sqlite3 database." } -{ $see-also sqlite-close sqlite-last-insert-rowid } ; - -HELP: sqlite-close -{ $values { "db" "the database object" } -} -{ $description "Closes the sqlite3 database." } -{ $see-also sqlite-open sqlite-last-insert-rowid } ; - -HELP: sqlite-last-insert-rowid -{ $values { "db" "the database object" } - { "rowid" "the row number of the last insert" } -} -{ $description "Returns the number of the row of the last statement inserted into the database." } -{ $see-also sqlite-open sqlite-close } ; - -HELP: sqlite-prepare -{ $values { "db" "the database object" } - { "sql" "the SQL statement as a string" } - { "statement" "the prepared SQL statement" } -} -{ $description "Internally compiles the SQL statement ready to be run by sqlite. The statement is executed and the results iterated over using " { $link sqlite-each } " and " { $link sqlite-map } ". The SQL statement can use named parameters which are later bound to values using " { $link sqlite-bind-text } " and " { $link sqlite-bind-text-by-name } "." } -{ $see-also sqlite-open sqlite-close } ; - -HELP: sqlite-bind-text -{ $values { "statement" "a prepared SQL statement" } - { "index" "the index of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - -} -{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the index given and the indexes start from one." } -{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=?\" sqlite-prepare\n1 \"chris\" sqlite-bind-text" } } -{ $see-also sqlite-bind-text-by-name } ; - -HELP: sqlite-bind-text-by-name -{ $values { "statement" "a prepared SQL statement" } - { "name" "the name of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - -} -{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the given name." } -{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=:name\" sqlite-prepare\n\"name\" \"chris\" sqlite-bind-text" } } -{ $see-also sqlite-bind-text } ; - -HELP: sqlite-finalize -{ $values { "statement" "a prepared SQL statement" } -} -{ $description "Clean up all resources related to a statement. Once called the statement cannot be used again. All statements must be finalized before closing the database." } -{ $see-also sqlite-close sqlite-prepare } ; - -HELP: sqlite-reset -{ $values { "statement" "a prepared SQL statement" } -} -{ $description "Reset a statement so it can be called again, possibly with different bound parameters." } -{ $see-also sqlite-bind-text sqlite-bind-text-by-name } ; - -HELP: column-count -{ $values { "statement" "a prepared SQL statement" } { "int" "the number of columns" } } -{ $description "Return the number of columns in each row of the result set of the given statement." } -{ $see-also column-text sqlite-each sqlite-map } ; - -HELP: column-text -{ $values { "statement" "a prepared SQL statement" } { "index" "column number indexed from zero" } { "string" "column value" } -} -{ $description "Return the value of the given column, indexed from zero, as a string." } -{ $see-also column-count sqlite-each sqlite-map } ; - -HELP: sqlite-each -{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- )" } -} -{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row." } -{ $see-also column-count column-text sqlite-map } ; - -HELP: sqlite-map -{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- value )" } { "seq" "a new sequence" } -} -{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row. The quotation should leave a value on the stack which gets collected and returned in the resulting sequence." } -{ $see-also column-count column-text sqlite-each } ; diff --git a/extra/sqlite/sqlite-tests.factor b/extra/sqlite/sqlite-tests.factor deleted file mode 100644 index 5eecbec369..0000000000 --- a/extra/sqlite/sqlite-tests.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! -! Redistribution and use in source and binary forms, with or without -! modification, are permitted provided that the following conditions are met: -! -! 1. Redistributions of source code must retain the above copyright notice, -! this list of conditions and the following disclaimer. -! -! 2. Redistributions in binary form must reproduce the above copyright notice, -! this list of conditions and the following disclaimer in the documentation -! and/or other materials provided with the distribution. -! -! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, -! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! Test the sqlite interface -! -! Create a test database like follows: -! -! sqlite3 test.db < test.txt -! -! Then run this file. -USE: sqlite -USE: kernel -USE: io -USE: io.files -USE: prettyprint - -: test.db "libs/sqlite/test.db" resource-path ; - -: show-people ( statement -- ) - dup 0 column-text write " from " write 1 column-text . ; - -: run-test ( -- ) - test.db sqlite-open - dup "select * from test" sqlite-prepare - dup [ show-people ] sqlite-each - sqlite-finalize - sqlite-close ; - -: find-person ( name -- ) - test.db sqlite-open ! name db - dup "select * from test where name=?" sqlite-prepare ! name db stmt - [ rot 1 swap sqlite-bind-text ] keep ! db stmt - [ [ 1 column-text . ] sqlite-each ] keep - sqlite-finalize - sqlite-close ; - -: find-all ( -- ) - test.db sqlite-open ! db - dup "select * from test" sqlite-prepare ! db stmt - [ [ [ 0 column-text ] keep 1 column-text curry ] sqlite-map ] keep - sqlite-finalize - swap sqlite-close ; - -: run-test2 ( -- ) - test.db sqlite-open - dup "select * from test" sqlite-prepare - dup [ show-people ] ; - -run-test diff --git a/extra/sqlite/sqlite.factor b/extra/sqlite/sqlite.factor deleted file mode 100644 index d651ad916c..0000000000 --- a/extra/sqlite/sqlite.factor +++ /dev/null @@ -1,127 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! An interface to the sqlite database. Tested against sqlite v3.0.8. -! -! Not all functions have been wrapped yet. Only those directly involving -! executing SQL calls and obtaining results. -! -IN: sqlite -USING: alien compiler kernel namespaces sequences strings sqlite.lib - alien.c-types continuations ; - -TUPLE: sqlite-error n message ; -SYMBOL: db - -! High level sqlite routines -: sqlite-check-result ( result -- ) - #! Check the result from a sqlite call is ok. If it is - #! return, otherwise throw an error. - dup SQLITE_OK = [ - drop - ] [ - dup sqlite-error-messages nth - \ sqlite-error construct-boa throw - ] if ; - -: sqlite-open ( filename -- db ) - #! Open the database referenced by the filename and return - #! a handle to that database. An error is thrown if the database - #! failed to open. - "void*" [ sqlite3_open sqlite-check-result ] keep *void* ; - -: sqlite-close ( db -- ) - #! Close the given database - sqlite3_close sqlite-check-result ; - -: sqlite-last-insert-rowid ( db -- rowid ) - #! Return the rowid of the last insert - sqlite3_last_insert_rowid ; - -: sqlite-prepare ( db sql -- statement ) - #! Prepare a SQL statement. Returns the statement which - #! can have values bound to parameters or simply executed. - #! TODO: Support multiple statements in the SQL string. - dup length "void*" "void*" - [ sqlite3_prepare sqlite-check-result ] 2keep - drop *void* ; - -: sqlite-bind-text ( statement index text -- ) - #! Bind the text to the parameterized value in the statement. - dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ; - -: sqlite-bind-parameter-index ( statement name -- index ) - sqlite3_bind_parameter_index ; - -: sqlite-bind-text-by-name ( statement name text -- ) - >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ; - -: sqlite-finalize ( statement -- ) - #! Clean up all resources related to a statement. Once called - #! the statement cannot be used. All statements must be finalized - #! before closing the database. - sqlite3_finalize sqlite-check-result ; - -: sqlite-reset ( statement -- ) - #! Reset a statement so it can be called again, possibly with - #! different parameters. - sqlite3_reset sqlite-check-result ; - -: column-count ( statement -- int ) - #! Given a prepared statement, return the number of - #! columns in each row of the result set of that statement. - sqlite3_column_count ; - -: column-text ( statement index -- string ) - #! Return the value of the given column, indexed - #! from zero, as a string. - sqlite3_column_text ; - -: step-complete? ( step-result -- bool ) - #! Return true if the result of a sqlite3_step is - #! such that the iteration has completed (ie. it is - #! SQLITE_DONE). Throw an error if an error occurs. - dup SQLITE_ROW = [ - drop f - ] [ - dup SQLITE_DONE = [ - drop t - ] [ - sqlite-check-result t - ] if - ] if ; - -: sqlite-each ( statement quot -- ) - #! Execute the SQL statement, and call the quotation for - #! each row returned from executing the statement with the - #! statement on the top of the stack. - over sqlite3_step step-complete? [ - 2drop - ] [ - [ call ] 2keep sqlite-each - ] if ; inline - -! For comparison, here is the linrec implementation of sqlite-each -! [ drop sqlite3_step step-complete? ] -! [ 2drop ] -! [ 2dup 2slip ] -! [ ] linrec ; - -DEFER: (sqlite-map) - -: (sqlite-map) ( statement quot seq -- ) - pick sqlite3_step step-complete? [ - 2nip - ] [ - >r 2dup call r> swap add (sqlite-map) - ] if ; - -: sqlite-map ( statement quot -- seq ) - { } (sqlite-map) ; - -: with-sqlite ( path quot -- ) - [ - >r sqlite-open db set r> - [ db get sqlite-close ] [ ] cleanup - ] with-scope ; - diff --git a/extra/sqlite/test.txt b/extra/sqlite/test.txt deleted file mode 100644 index 5c7ae2b52a..0000000000 --- a/extra/sqlite/test.txt +++ /dev/null @@ -1,3 +0,0 @@ -create table test (name varchar(30), address varchar(30)); -insert into test values('John', 'America'); -insert into test values('Jane', 'New Zealand'); diff --git a/extra/sqlite/tuple-db/authors.txt b/extra/sqlite/tuple-db/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/sqlite/tuple-db/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/sqlite/tuple-db/tuple-db-docs.factor b/extra/sqlite/tuple-db/tuple-db-docs.factor deleted file mode 100644 index 3c6df0eaa6..0000000000 --- a/extra/sqlite/tuple-db/tuple-db-docs.factor +++ /dev/null @@ -1,131 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help sqlite help.syntax help.markup ; -IN: sqlite.tuple-db - -ARTICLE: { "sqlite" "tuple-db-loading" } "Loading" -"The quickest way to get up and running with this library is to use the vocabulary:" -{ $code "USING: sqlite sqlite.tuple-db ;\n" } -"Some simple tests can be run to check that everything is working ok:" -{ $code "\"libs/sqlite\" test-module" } ; - -ARTICLE: { "sqlite" "tuple-db-usage" } "Basic Usage" -"This library can be used for storing simple Factor tuples in a sqlite database. In its current form the tuples must not contain references to other tuples and should not have a delegate set." -$nl -"This document will use the following tuple for demonstration purposes:" -{ $code "TUPLE: person name surname phone ;" } -"The sqlite database to store tuples must be created, or an existing one opened. This is done using the " { $link sqlite-open } " word. If the database does not exist then it is created. The examples in this document store the database pointer in a variable called 'db':" -{ $code "SYMBOL: db\n\"example.db\" sqlite-open db set-global" } ; - -ARTICLE: { "sqlite" "tuple-db-mappings" } "Tuple Mappings" -"Each tuple has a 'mapping' tuple associated with it. The 'mapping' stores information about what table the tuple will be stored in, the datatypes of the tuple slots, etc. A mapping must be created before a tuple can be stored in a database. A default mapping is easily created using " { $link default-mapping } ". Given the tuple class, this will use reflection to get the slots of it, assume that all slots are of database type 'text', and store the tuple objects in a table with the same name as the tuple." -$nl -"The following shows how to create the default mapping for the 'person' tuple, and how to register that mapping so the 'tuple-db' system can know how to handle 'person' instances:" -{ $code "person default-mapping set-mapping" } ; - -ARTICLE: { "sqlite" "tuple-db-create" } "Creating the table" -"The table used to store tuple instances may need to be created. This can be done manually using the external sqlite program or via " { $link create-tuple-table } ":" -{ $code "db get person create-tuple-table" } -"The SQL used to create the table is produced internally by " { $link create-sql } ". This is a generic word dispatched on the mapping object, and could be specialised if needed. If you wish to see the SQL used to create the table, use the following code:" -{ $code "person get-mapping create-sql .\n => \"create table person (name text,surname text,phone text);\"" } ; - -ARTICLE: { "sqlite" "tuple-db-insert" } "Inserting instances" -"The " { $link insert-tuple } " word will store instances of a tuple into the database table defined by its mapping object:" -{ $code "db get \"John\" \"Smith\" \"123-456-789\" insert-tuple" } -{ $link insert-tuple } " internally uses the " { $link insert-sql } " word to produce the SQL used to store the tuple. Like " { $link create-sql } ", it is a generic word specialized on the mapping object. You can call it directly to see what SQL is generated:" -{ $code "person get-mapping insert-sql .\n => \"insert into person values(:name,:surname,:phone);\"" } -"Notice that the SQL uses named parameters. These parameters are bound to the values stored in the tuple object when the SQL is compiled. This helps prevent SQL injection techniques." -$nl -"When " { $link insert-sql } " is run, it adds a delegate to the tuple being stored. The delegate is of type 'persistent' and holds the row id of the tuple in its 'key' slot. This way the exact record can be updated or retrieved later. The following demonstates this fact:" -{ $code "\"Mandy\" \"Jones\" \"987-654-321\" dup .\n => T{ person f \"Mandy\" \"Jones\" \"987-654-321\" }\ndb get over insert-tuple .\n => T{ person T{ persistent ... 2 } \"Mandy\" \"Jones\" \"987-654-321\" }" } -"The '2' in the above example is the row id of the record inserted. We can go into the 'sqlite' command and view this record:" -{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|123-456-789\n 2|Mandy|Jones|987-654-321\n sqlite>" } ; - -ARTICLE: { "sqlite" "tuple-db-finding" } "Finding instances" -"The " { $link find-tuples } " word is used to return tuples populated with data already existing in the database. As well as the database objcet, it takes a tuple that should be populated only with the fields that should be matched in the database. All fields you do not wish to match against should be set to 'f':" -{ $code "db get f \"Smith\" f find-tuples .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\ndb get \"Mandy\" f f find-tuples .\n => { T{ person # \"Mandy\" \"Jones\" \"987-654-321\" } }\ndb get \"Joe\" f f find-tuples .\n => { }" } -"Notice that if no matching tuples are found then an empty sequence is returned. The returned tuples also have their delegate set to 'persistent' with the correct row id set as the key. This can be used to later update the tuples with new information and store them in the database." ; - -ARTICLE: { "sqlite" "tuple-db-updating" } "Updating instances" -"Given a tuple that has the 'persistent' delegate with the row id set as the key, you can update this specific record using " { $link update-tuple } ":" -{ $code "db get f \"Smith\" f find-tuples dup .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\nfirst { \"999-999-999\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"1\" } \"John\" \"Smith\" \"999-999-999\" ...\n db get swap update-tuple" } -"Using the 'sqlite' command from the system shell you can see the record was updated:" -{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|999-999-999\n 2|Mandy|Jones|987-654-321\n sqlite>" } ; - -ARTICLE: { "sqlite" "tuple-db-inserting-or-updating" } "Inserting or Updating instances" -"The " { $link save-tuple } " word can be used to insert a tuple if it has not already been stored in the database, or update it if it already exists. Whether to insert or update is decided by the existance of the 'persistent' delegate:" -{ $code "\"Mary\" \"Smith\" \"111-111-111\" dup .\n => T{ person f \"Mary\" \"Smith\" \"111-111-111\" }\n! This will insert the tuple\ndb get over save-tuple dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"111-111-111\" ...\n[ \"222-222-222\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ...\n! This will update the tuple\ndb get over save-tuple .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ..." } ; - -ARTICLE: { "sqlite" "tuple-db-deleting" } "Deleting instances" -"Given a tuple with the delegate set to 'persistent' (ie. One already stored in the database) you can delete it from the database with " { $link delete-tuple } ":" -{ $code "db get f \"Smith\" f find-tuples [ db get swap delete-tuple ] each" } ; - -ARTICLE: { "sqlite" "tuple-db-closing" } "Closing the database" -"It's important to close the sqlite database when you've finished using it. The word for this is " { $link sqlite-close } ":" -{ $code "db get sqlite-close" } ; - -ARTICLE: { "sqlite" "tuple-db" } "Tuple Database Library" -"The version of sqlite required by this library is version 3 or greater. This library allows storing Factor tuples in a sqlite database. It provides words to create, read update and delete these entries as well as simple searching." -$nl -"The library is in a very early state and is likely to change quite a bit in the near future. Its most notable omission is it cannot currently handle relationships between tuples." -{ $subsection { "sqlite" "tuple-db-loading" } } -{ $subsection { "sqlite" "tuple-db-usage" } } -{ $subsection { "sqlite" "tuple-db-mappings" } } -{ $subsection { "sqlite" "tuple-db-create" } } -{ $subsection { "sqlite" "tuple-db-insert" } } -{ $subsection { "sqlite" "tuple-db-finding" } } -{ $subsection { "sqlite" "tuple-db-updating" } } -{ $subsection { "sqlite" "tuple-db-inserting-or-updating" } } -{ $subsection { "sqlite" "tuple-db-deleting" } } -{ $subsection { "sqlite" "tuple-db-closing" } } -; - -HELP: default-mapping -{ $values { "class" "symbol for the tuple class" } - { "mapping" "a mapping object" } -} -{ $description "Given a tuple class, create a default mappings object. This is used to associate field names in the tuple with SQL statement field names, etc." } -{ $see-also { "sqlite" "tuple-db" } set-mapping } ; - -HELP: set-mapping -{ $values { "mapping" "a mapping object" } -} -{ $description "Store a database mapping so that the tuple-db system knows how to store instances of the tuple in the database." } -{ $see-also { "sqlite" "tuple-db" } default-mapping } ; - -HELP: create-tuple-table -{ $values { "db" "a database object" } { "class" "symbol for the tuple class" } -} -{ $description "Create the database table to store intances of the given tuple." } -{ $see-also { "sqlite" "tuple-db" } default-mapping get-mapping } ; - -HELP: insert-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Insert the tuple instance into the database. It is assumed that this tuple does not currently exist in the database." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: find-tuples -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } { "seq" "a sequence of tuples" } } -{ $description "Return a sequence of all tuples in the database that match the tuple provided as a template. All fields in the tuple must match the entries in the database, except for those set to 'f'." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: update-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Update the database record for this tuple instance. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: save-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Insert or Update the tuple instance depending on whether it has a persistent delegate." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -HELP: delete-tuple -{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } -} -{ $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." } -{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ; - -ABOUT: { "sqlite" "tuple-db" } \ No newline at end of file diff --git a/extra/sqlite/tuple-db/tuple-db-tests.factor b/extra/sqlite/tuple-db/tuple-db-tests.factor deleted file mode 100644 index 8ed2631b45..0000000000 --- a/extra/sqlite/tuple-db/tuple-db-tests.factor +++ /dev/null @@ -1,39 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -IN: temporary -USING: io io.files kernel sequences namespaces -hashtables sqlite sqlite.tuple-db math words tools.test ; - -TUPLE: testdata one two ; - -C: testdata - -testdata default-mapping set-mapping - -"libs/sqlite/test.db" resource-path [ - - db get testdata create-tuple-table - - [ "two" { } ] [ - db get "one" "two" insert-tuple - db get "one" f find-tuples - first [ testdata-two ] keep - db get swap delete-tuple - db get "one" f find-tuples - ] unit-test - - [ "junk" ] [ - db get "one" "two" insert-tuple - db get "one" f find-tuples - first - "junk" over set-testdata-two - db get swap update-tuple - db get "one" f find-tuples - first [ testdata-two ] keep - db get swap delete-tuple - ] unit-test - - db get testdata drop-tuple-table -] with-sqlite - diff --git a/extra/sqlite/tuple-db/tuple-db.factor b/extra/sqlite/tuple-db/tuple-db.factor deleted file mode 100644 index c37a49d2b6..0000000000 --- a/extra/sqlite/tuple-db/tuple-db.factor +++ /dev/null @@ -1,270 +0,0 @@ -! Copyright (C) 2005 Chris Double. -! -! A tuple that is persistent has its delegate set as 'persistent'. -! 'persistent' holds the numeric rowid for that tuple in its table. -IN: sqlite.tuple-db -USING: io kernel sequences namespaces slots classes slots.private -assocs math words generic sqlite math.parser ; - -! Each slot in a tuple that is storable in the database has -! an instance of a db-field object the gives the name of the -! database table and slot number in the tuple object of that field. -TUPLE: db-field name bind-name slot type ; - -C: db-field - -! The mapping tuple holds information on how the slots of -! a tuple are mapped to the fields of a sqlite database. -TUPLE: mapping tuple table fields one-to-one one-to-many ; - -C: mapping - -: sanitize ( string -- string ) - #! Convert a string so it can be used as a table or field name. - clone - H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } } - over substitute ; - -: tuple-fields ( class -- seq ) - #! Given a tuple class return a list of the fields - #! within that tuple. Ignores the delegate field. - "slots" word-prop 1 tail [ - [ slot-spec-name sanitize dup ":" swap append ] keep - slot-spec-offset - "text" - - ] map ; - -: default-mapping ( class -- mapping ) - #! Given a tuple class, create a default mappings object. It assumes - #! there are no one-to-one or one-to-many relationships. - dup [ word-name sanitize ] keep tuple-fields f f ; - -! The mappings variable holds a hashtable mapping the tuple symbol -! to the mapping object, describing how that tuple is stored -! in the database. -SYMBOL: mappings - -: init-mappings ( -- ) - H{ } mappings set-global ; - -: get-mappings ( -- hashtable ) - mappings get-global ; - -: set-mapping ( mapping -- ) - #! Store a database mapping so that the persistence system - #! knows how to store instances of the relevant tuple in the database. - dup mapping-tuple get-mappings set-at ; - -: get-mapping ( class -- mapping ) - #! Return the database mapping for the given tuple class. - get-mappings at ; - -! The 'persistent' tuple will be set to the delegate of any tuple -! instance stored in the database. It contains the database key -! of the row in the database table for the instance or 'f' if it has -! not yet been stored in the database. It also contains the 'mapping' -! object used to translate the fields of the tuple to the database fields. -TUPLE: persistent mapping key ; -: ( tuple -- persistent ) - persistent construct-empty - >r class get-mapping r> - [ set-persistent-mapping ] keep ; - -: make-persistent ( tuple -- tuple ) - #! Convert the tuple into something that can be stored - #! into a database by setting its delegate to 'persistent'. - [ ] keep - [ set-delegate ] keep ; - - -: comma-fields ( mapping quot -- string ) - #! Given a mapping, call quot on each field in - #! the mapping. The contents of quot should call ',' or '%' - #! to generate output. The output of each quot call - #! seperated by commas is returned as a string. 'quot' should be - #! stack effect ( field -- ). - >r mapping-fields r> [ "" make ] curry map "," join ; inline - -GENERIC: create-sql ( mapping -- string ) -M: mapping create-sql ( mapping -- string ) - #! Return the SQL used to create a table for storing this type of tuple. - [ - "create table " % dup mapping-table % - " (" % - [ dup db-field-name % " " % db-field-type % ] comma-fields % - ");" % - ] "" make ; - -GENERIC: drop-sql ( mapping -- string ) -M: mapping drop-sql ( mapping -- string ) - #! Return the SQL used to drop the table for storing this type of tuple. - [ - "drop table " % mapping-table % ";" % - ] "" make ; - -GENERIC: insert-sql ( mapping -- string ) -M: mapping insert-sql ( mapping -- string ) - #! Return the SQL used to insert a tuple into a table - [ - "insert into " % dup mapping-table % - " values(" % - [ db-field-bind-name % ] comma-fields % - ");" % - ] "" make ; - -GENERIC: delete-sql ( mapping -- string ) -M: mapping delete-sql ( mapping -- string ) - #! Return the SQL used to delete a tuple from a table - [ - "delete from " % mapping-table % - " where ROWID=:rowid;" % - ] "" make ; - -GENERIC: update-sql ( mapping -- string ) -M: mapping update-sql ( mapping -- string ) - #! Return the SQL used to update the tuple - [ - "update " % dup mapping-table % - " set " % - [ dup db-field-name % "=" % db-field-bind-name % ] comma-fields % - " where ROWID=:rowid;" % - ] "" make ; - -GENERIC: select-sql ( tuple mapping -- select ) -M: mapping select-sql ( tuple mapping -- select ) - #! Return the SQL used to select a series of tuples from the database. It - #! will select based on only the filled in fields of the tuple (ie. all non-f). - [ - "select ROWID,* from " % dup mapping-table % - mapping-fields [ ! tuple field - swap over db-field-slot slot ! field value - [ - [ dup db-field-name % "=" % db-field-bind-name % ] "" make - ] [ - drop f - ] if - ] with map [ ] subset dup length 0 > [ - " where " % - " and " join % - ] [ - drop - ] if - ";" % - ] "" make ; - -: execute-update-sql ( db string -- ) - #! Execute the SQL, which should contain a database update - #! statement (update, insert, create, etc). Ignore the result. - sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ; - -: create-tuple-table ( db class -- ) - #! Create the table for the tuple class. - get-mapping create-sql execute-update-sql ; - -: drop-tuple-table ( db class -- ) - #! Create the table for the tuple class. - get-mapping drop-sql execute-update-sql ; - -: bind-for-insert ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared insert statement. - dup class get-mapping mapping-fields [ ! statement tuple field - [ db-field-slot slot ] keep ! statement value field - db-field-bind-name swap ! statement name value - >r dupd r> sqlite-bind-text-by-name - ] with each drop ; - -: bind-for-select ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared select statement. - dup class get-mapping mapping-fields [ ! statement tuple field - [ db-field-slot slot ] keep ! statement value field - over [ - db-field-bind-name swap ! statement name value - >r dupd r> sqlite-bind-text-by-name - ] [ - 2drop - ] if - ] with each drop ; - -: bind-for-update ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared update statement. - 2dup bind-for-insert - >r ":rowid" r> persistent-key sqlite-bind-text-by-name ; - -: bind-for-delete ( statement tuple -- ) - #! Bind the fields in the tuple to the fields in the - #! prepared delete statement. - >r ":rowid" r> persistent-key sqlite-bind-text-by-name ; - -: (insert-tuple) ( db tuple -- ) - #! Insert this tuple instance into the database. Note that - #! it inserts only this instance, and not any one-to-one or - #! one-to-many fields. - dup class get-mapping insert-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-insert ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: insert-tuple ( db tuple -- ) - #! Insert this tuple instance into the database and - #! update the rowid of the insert in the tuple. - [ (insert-tuple) ] 2keep - >r sqlite-last-insert-rowid number>string r> make-persistent set-persistent-key ; - -: update-tuple ( db tuple -- ) - #! Update this tuple instance in the database. The tuple should have - #! a delegate of 'persistent' with the key field set. - dup class get-mapping update-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-update ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: save-tuple ( db tuple -- ) - #! Insert or Update the tuple instance depending on whether it - #! has a persistent delegate. - dup delegate [ update-tuple ] [ insert-tuple ] if ; - -: delete-tuple ( db tuple -- ) - #! Delete this tuple instance from the database. The tuple should have - #! a delegate of 'persistent' with the key field set. - dup class get-mapping delete-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - dupd bind-for-delete ! statement - dup [ drop ] sqlite-each - sqlite-finalize ; - -: restore-tuple ( statement tuple -- tuple ) - #! Using 'tuple' as a template, clone it and - #! return the clone with fields set to the values from the - #! database. - clone dup class get-mapping mapping-fields 1 swap - [ ! statement tuple index field ) - over 1+ >r ! statement tuple index field r: index+1 - db-field-slot >r ! statement tuple index r: index+1 slot - pick swap column-text ! statement tuple value r: index+1 slot - over r> set-slot r> ! statement tuple index+1 - ] each ! statement tuple index - drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ; - -: find-tuples ( db tuple -- seq ) - #! Return a sequence of all tuples in the database that - #! match the tuple provided as a template. All fields in the - #! tuple must match the entries in the database, except for - #! those set to 'f'. - dup class get-mapping dupd select-sql ! db tuple sql - swapd sqlite-prepare swap ! statement tuple - 2dup bind-for-select ! statement tuple - [ - over [ ! tuple statement - over restore-tuple , - ] sqlite-each - ] { } make nip ! statement tuple accum - swap sqlite-finalize ; - - -get-mappings [ init-mappings ] unless diff --git a/extra/webapps/article-manager/article-manager-docs.factor b/extra/webapps/article-manager/article-manager-docs.factor deleted file mode 100644 index b8dc700d51..0000000000 --- a/extra/webapps/article-manager/article-manager-docs.factor +++ /dev/null @@ -1,33 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax webapps.article-manager.database ; -IN: webapps.article-manager - -ARTICLE: { "article-manager" "loading" } "Loading Article Manager" -"To start an instance of the article-manager furnace application:" -{ $example "\"webapps.article-manager\" run" } -"The article-manager database needs to be opened before it can be accessed." -{ $example "open-db" } ; - -ARTICLE: { "article-manager" "security" } "Article Manager Security" -"To setup an article manager site you need to authenticate under the basic-authentication realm called \"article-manager-site\". To add and edit articles you need to authenticate under the realm \"article-manager-article\". The following sets up an 'admin' user under these two realms with a password of 'password'." -{ $example "H{ { \"admin\" \"5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8\" } } \"article-manager-site\" add-realm\nH{ { \"admin\" \"5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8\" } } \"article-manager-article\" add-realm " } -"Multiple users can be added with different passwords under these realms." ; - -ARTICLE: { "article-manager" "setup" } "Article Manager Setup" -"A site must first be setup before it can be accessed by the user. This can be access via the URL " { $url "http://site-name/responder/article-manager/setup-site/" } "\n\n" -"The 'hostname' is the hostname portion of the URL used to access the site. The 'title' is what appears in the title bar. 'footer' appears at the bottom of the pages in the site and can be used for a copyright notice, etc. 'Introduction' Should be Wiky code and will appear on the first index page of the site. 'HTML' will be appended to every page just before the closing of the 'body' HTML tag. It can be used to put HTML for counters, user tracking, etc.\n\n" -"The 'Ad Block' sections are used for entering HTML and Javascript code for ads that will appear in the article pages. 'Ad Block 1' appears in the left hand navigation area underneat the menu and above the 'tags' list. The other two ad blocks appear at the top of articles randomly split between either no ad and one of those two blocks." ; - -ARTICLE: { "article-manager" "articles" } "Adding or Editing Articles" -"Articles are added or edited using the URL " { $url "http://site-name/responder/article-manager/edit-article/article-name" } ". This will bring up a form with information about the article.\n\n'Publication Date' is the date you want to appear next to the article. You can click the button next to it to select it using a popup calendar. 'Title' is the title of the article.\n\n'Status' can be 'Draft' or 'Published'. 'Draft' articles do not appear in the main index page or list of tags. They can still be accessed via the direct URL however. Note that editing an existing article will default this to 'Draft' automatically, so you'll need to change it back to 'Published' if you want it to appear.\n\n'Tags' is a space-separated list of tag names that can be used for finding articles.\n\n'Body' is the text of the article. It is in Wiky format and shows a preview below it. For more on the Wiky syntax see " { $url "http://goessner.net/articles/wiky/WikyBox.html" } " or Google for 'Wikybox'." -; - -ARTICLE: { "article-manager" "article-manager" } "Article Manager" -"The article-manager is a Furnace application used to manage and display a tagged set of articles. Each instance of the article-manager responder can run multiple sites containing different articles. Follow these instructions to set up an article manager instance." -{ $subsection { "article-manager" "loading" } } -{ $subsection { "article-manager" "security" } } -{ $subsection { "article-manager" "setup" } } -{ $subsection { "article-manager" "articles" } } ; - -ABOUT: { "article-manager" "article-manager" } \ No newline at end of file diff --git a/extra/webapps/article-manager/article-manager.factor b/extra/webapps/article-manager/article-manager.factor deleted file mode 100644 index 66e7faff94..0000000000 --- a/extra/webapps/article-manager/article-manager.factor +++ /dev/null @@ -1,165 +0,0 @@ -! Copyright (C) 2007 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel furnace sqlite.tuple-db webapps.article-manager.database - sequences namespaces math arrays assocs quotations io.files - http.server http.basic-authentication http.server.responders - webapps.file html html.elements io ; -IN: webapps.article-manager - -: current-site ( -- site ) - host get-site* ; - -: render-titled-page* ( model body-template head-template title -- ) - [ - [ render-component ] swap [ write f rot render-component ] curry html-document - ] serve-html ; - -TUPLE: template-args arg1 ; - -C: template-args - -: setup-site ( -- ) - "article-manager-site" [ - current-site "setup-site" "edit-head" "Setup Site" render-titled-page* - ] with-basic-authentication ; - -\ setup-site { } define-action - -: site-index ( -- ) - host get-site [ - current-site "index" "head" pick site-title render-titled-page* - ] [ - "404" "Unknown Site" httpd-error - ] if ; - -! An action called 'site-index' -\ site-index { } define-action - -: requested-article-path ( action -- url ) - length "responder-url" get length 1 + + "request" get swap tail ; - -: requested-article-url ( action -- url ) - requested-article-path CHAR: / over index dup [ - head - ] [ - drop - ] if ; - -: requested-article-filename ( action -- url ) - requested-article-path CHAR: / over last-index 1+ tail ; - -: tag ( -- ) - current-site - "tag" requested-article-url host swap get-tag dup >r - 2array "tag" "head" r> tag-title render-titled-page* ; - -! An action for tags -\ tag { } define-action - -: article ( -- ) - current-site - "article" requested-article-url host swap article-by-url dup >r - 2array - "article" "head" r> article-title render-titled-page* ; - -! An action for articles -\ article { } define-action - - -: edit-article ( -- ) - "article-manager-article" [ - "edit-article" requested-article-url host swap article-by-url* - "edit-article" "edit-head" "Edit" render-titled-page* - ] with-basic-authentication ; - -! An action for articles -\ edit-article { } define-action - -: update-article ( pubdate title status tags body url -- ) - "article-manager-article" [ - host swap article-by-url* - [ set-article-body ] keep - [ set-article-tags ] keep - [ set-article-status ] keep - [ set-article-title ] keep - [ set-article-pubdate ] keep - [ save-article ] keep - article-url "responder-url" get "article/" rot 3append "/" append permanent-redirect - ] with-basic-authentication ; - - -\ update-article { { "pubdate" } { "title" } { "status" } { "tags" } { "body" } { "url" } } define-action - -: update-article-link ( -- link ) - "responder-url" get "update-article" append ; - -: remove-article ( url -- ) - "article-manager-article" [ - host swap article-by-url [ remove-article ] when* - "responder-url" get permanent-redirect - ] with-basic-authentication ; - -\ remove-article { { "url" } } define-action - -: update-site ( ad3 ad2 ad1 html title intro footer hostname -- ) - "article-manager-site" [ - dup get-site* - [ set-site-hostname ] keep - [ set-site-footer ] keep - [ set-site-intro ] keep - [ set-site-title ] keep - [ set-site-html ] keep - [ set-site-ad1 ] keep - [ set-site-ad2 ] keep - [ set-site-ad3 ] keep - get-db swap save-tuple - "responder-url" get permanent-redirect - ] with-basic-authentication ; - - -\ update-site { { "ad3" } { "ad2" } { "ad1" } { "html" } { "title" } { "intro" } { "footer" } { "hostname" } } define-action - -: update-site-link ( -- link ) - "responder-url" get "update-site" append ; - - -SYMBOL: redirections - -: redirector ( url quot -- ) - over redirections get H{ } or at dup [ - 2nip permanent-redirect - ] [ - drop call - ] if ; - -: install-redirector ( hash responder host -- ) - vhost [ responder ] bind [ - "post" get [ redirector ] curry "post" set - "get" get [ redirector ] curry "get" set - redirections set - ] bind ; - -: get-redirections ( responder host -- hash ) - vhost [ responder ] bind [ redirections get ] bind ; - -: article-manager-web-app ( -- ) - ! Create the web app, providing access - ! under '/responder/article-manager' which calls the - ! 'site-index' action. - "article-manager" "site-index" "extra/webapps/article-manager/furnace/" web-app - - ! An URL to the javascript and css resource files - "article-manager-resources" [ - [ - "extra/webapps/article-manager/resources/" resource-path "doc-root" set - file-responder - ] with-scope - ] add-simple-responder ; - -MAIN: article-manager-web-app - -! Just for testing. Password is 'password' -! H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "article-manager-site" add-realm -! H{ { "admin" "5e884898da28047151d0e56f8dc6292773603d0d6aabbdd62a11ef721d1542d8" } } "article-manager-article" add-realm - diff --git a/extra/webapps/article-manager/authors.txt b/extra/webapps/article-manager/authors.txt deleted file mode 100644 index 44b06f94bc..0000000000 --- a/extra/webapps/article-manager/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/article-manager/database/authors.txt b/extra/webapps/article-manager/database/authors.txt deleted file mode 100755 index 44b06f94bc..0000000000 --- a/extra/webapps/article-manager/database/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Chris Double diff --git a/extra/webapps/article-manager/database/database.factor b/extra/webapps/article-manager/database/database.factor deleted file mode 100644 index 8463c2545b..0000000000 --- a/extra/webapps/article-manager/database/database.factor +++ /dev/null @@ -1,118 +0,0 @@ -! Copyright (C) 2007 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -USING: kernel sqlite sqlite.tuple-db io.files sequences splitting - hashtables ; -IN: webapps.article-manager.database - -TUPLE: site hostname title intro footer html ad1 ad2 ad3 ; - -C: site - -TUPLE: article hostname url pubdate title status body tags ; - -C:

article - -TUPLE: tag hostname name title description ; - -C: tag - -site default-mapping set-mapping -article default-mapping set-mapping -tag default-mapping set-mapping - -: db ( -- object ) - { f } ; - -: set-db ( value -- ) - 0 db set-nth ; - - -: get-db ( -- value ) - 0 db nth ; - -: db-filename ( -- name ) - "extra/webapps/article-manager/article-manager.db" resource-path ; - -: open-db ( -- ) - get-db [ sqlite-close ] when* - db-filename exists? [ - db-filename sqlite-open set-db - ] [ - db-filename sqlite-open dup set-db - dup article create-tuple-table - dup site create-tuple-table - tag create-tuple-table - ] if ; - -: close-db ( -- ) - get-db [ sqlite-close ] when* - f set-db ; - -: all-sites ( -- sites ) - get-db f f f f f f f f find-tuples ; - -: get-site ( hostname -- site ) - f f f f f f f get-db swap find-tuples dup empty? [ - drop f - ] [ - first - ] if ; - -: get-site* ( hostname -- site ) - f f f f f f f dup get-db swap find-tuples dup empty? [ - drop site-hostname dup "" "" "" "" "" "" - ] [ - nip first - ] if ; - -: get-tag ( hostname name -- tag ) - f f dup get-db swap find-tuples dup empty? [ - drop - [ dup tag-name swap set-tag-title ] keep - [ "" swap set-tag-description ] keep - ] [ - nip first - ] if ; - -: add-article ( article -- ) - get-db swap insert-tuple ; - -: remove-article ( article -- ) - get-db swap delete-tuple ; - -: save-article ( article -- ) - get-db swap save-tuple ; - -: all-articles ( hostname -- seq ) - f f f "published" f f
get-db swap find-tuples ; - -: article-by-url ( hostname url -- article ) - f f f f f
get-db swap find-tuples dup empty? [ - drop f - ] [ - first - ] if ; - -: article-by-url* ( hostname url -- article ) - f f f f f
dup get-db swap find-tuples dup empty? [ - drop - [ "" swap set-article-pubdate ] keep - [ "" swap set-article-title ] keep - [ "draft" swap set-article-status ] keep - [ "" swap set-article-body ] keep - [ "" swap set-article-tags ] keep - ] [ - nip first - ] if ; - -: tags-for-article ( article -- seq ) - article-tags " " split [ empty? not ] subset ; - -: all-tags ( hostname -- seq ) - all-articles [ tags-for-article ] map concat prune ; - -: articles-for-tag ( tag -- seq ) - [ tag-name ] keep tag-hostname all-articles [ - tags-for-article member? - ] with subset ; diff --git a/extra/webapps/article-manager/furnace/article.furnace b/extra/webapps/article-manager/furnace/article.furnace deleted file mode 100644 index c3a19263be..0000000000 --- a/extra/webapps/article-manager/furnace/article.furnace +++ /dev/null @@ -1,13 +0,0 @@ -<% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %> - - <% "navigation" render-template %> -
- <% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %> - <% "arg1" get second article-body write-html %> - -

Tags

- <% "arg1" get second tags-for-article "tags" render-component %> -
-

- -<% "arg1" get first site-html write-html %> diff --git a/extra/webapps/article-manager/furnace/edit-article.furnace b/extra/webapps/article-manager/furnace/edit-article.furnace deleted file mode 100644 index 76ec95fde5..0000000000 --- a/extra/webapps/article-manager/furnace/edit-article.furnace +++ /dev/null @@ -1,41 +0,0 @@ -<% USING: kernel io namespaces furnace webapps.article-manager html.elements ; %> - -
- - - - - - - - - - - - diff --git a/extra/webapps/article-manager/furnace/edit-head.furnace b/extra/webapps/article-manager/furnace/edit-head.furnace deleted file mode 100644 index c1d55ae0b8..0000000000 --- a/extra/webapps/article-manager/furnace/edit-head.furnace +++ /dev/null @@ -1,12 +0,0 @@ - - - - - - - - - - - - diff --git a/extra/webapps/article-manager/furnace/head.furnace b/extra/webapps/article-manager/furnace/head.furnace deleted file mode 100644 index 21a4e9c9bd..0000000000 --- a/extra/webapps/article-manager/furnace/head.furnace +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/extra/webapps/article-manager/furnace/index.furnace b/extra/webapps/article-manager/furnace/index.furnace deleted file mode 100644 index da48d324cc..0000000000 --- a/extra/webapps/article-manager/furnace/index.furnace +++ /dev/null @@ -1,32 +0,0 @@ -<% USING: kernel sequences furnace webapps.article-manager webapps.article-manager.database io namespaces http.server sorting html.elements math ; %> - - - <% "title" get write %> - - - - - <% "navigation" render-template %> -
- <% "intro" get write-html %> -

Recent Articles

-
    - <% host all-articles [ >r article-pubdate r> article-pubdate swap <=> ] sort [ %> -
  • "><% dup article-title write %> (<% article-pubdate write %>)
    • - <% ] each %> -
- -

Tags

-

The information in this site is 'tagged'. By searching or - selecting one of the tags below you can find information about - that area. A search facility will be added soon - but in the meantime, Google is likely to provide - reasonable results. -

- <% host all-tags "tags" render-component %> -
-

- - <% "html" get write-html %> - - \ No newline at end of file diff --git a/extra/webapps/article-manager/furnace/navigation.furnace b/extra/webapps/article-manager/furnace/navigation.furnace deleted file mode 100644 index b42a384ca1..0000000000 --- a/extra/webapps/article-manager/furnace/navigation.furnace +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: kernel furnace webapps.article-manager webapps.article-manager.database io namespaces http.server html.elements ; %> - diff --git a/extra/webapps/article-manager/furnace/setup-site.furnace b/extra/webapps/article-manager/furnace/setup-site.furnace deleted file mode 100644 index 8922b8d04c..0000000000 --- a/extra/webapps/article-manager/furnace/setup-site.furnace +++ /dev/null @@ -1,33 +0,0 @@ -<% USING: kernel io namespaces furnace webapps.article-manager html.elements ; %> - -

Setup New Site

- -
URL:"/>"/>
Publication Date:"/>
Title:"/>
Status:
Tags:"/>
Body:
Preview:
<% "body" get write-html %>
- - - - - - - - - - - - - diff --git a/extra/webapps/article-manager/furnace/tag.furnace b/extra/webapps/article-manager/furnace/tag.furnace deleted file mode 100644 index 4e04196097..0000000000 --- a/extra/webapps/article-manager/furnace/tag.furnace +++ /dev/null @@ -1,16 +0,0 @@ -<% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %> - - - <% "navigation" render-component %> -
-

<% "arg1" get second tag-title write %>

- <% "arg1" get second tag-description write-html %> - -
-

- -<% "arg1" get first site-html write-html %> diff --git a/extra/webapps/article-manager/furnace/tags.furnace b/extra/webapps/article-manager/furnace/tags.furnace deleted file mode 100644 index 77d3656779..0000000000 --- a/extra/webapps/article-manager/furnace/tags.furnace +++ /dev/null @@ -1,6 +0,0 @@ -<% USING: kernel namespaces sequences webapps.article-manager.database io sorting ; %> -
    - <% "arg1" get [ <=> ] sort [ %> -
  • "><% write %>
    • - <% ] each %> -
diff --git a/extra/webapps/article-manager/load.factor b/extra/webapps/article-manager/load.factor deleted file mode 100644 index facb6517b8..0000000000 --- a/extra/webapps/article-manager/load.factor +++ /dev/null @@ -1,18 +0,0 @@ -! Copyright (C) 2007 Chris Double. All Rights Reserved. -! See http://factorcode.org/license.txt for BSD license. -! -REQUIRES: libs/furnace libs/sqlite libs/basic-authentication ; - -PROVIDE: apps/article-manager -{ - +files+ { - "article-manager-db.factor" - "article-manager.factor" - "article-manager.facts" - } -} { - +tests+ { - } -} -{ +help+ { "article-manager" "article-manager" } } - ; diff --git a/extra/webapps/article-manager/resources/jquery.js b/extra/webapps/article-manager/resources/jquery.js deleted file mode 100644 index 2531342aef..0000000000 --- a/extra/webapps/article-manager/resources/jquery.js +++ /dev/null @@ -1 +0,0 @@ -eval(function(p,a,c,k,e,d){e=function(c){return(c35?String.fromCharCode(c+29):c.toString(36))};if(!''.replace(/^/,String)){while(c--){d[e(c)]=k[c]||e(c)}k=[function(e){return d[e]}];e=function(){return'\\w+'};c=1};while(c--){if(k[c]){p=p.replace(new RegExp('\\b'+e(c)+'\\b','g'),k[c])}}return p}('l(1T 1z.6=="Q"){1z.Q=1z.Q;u 6=q(a,c){l(a&&1T a=="q"&&6.C.1W)v 6(17).1W(a);a=a||6.1o||17;l(a.3E)v 6(6.1X(a,[]));l(c&&c.3E)v 6(c).1V(a);l(1z==7)v 1h 6(a,c);l(a.O==1C){u m=/^[^<]*(<.+>)[^>]*$/.3d(a);l(m)a=6.3D([m[1]])}7.1n(a.O==2z||a.D&&!a.1R&&a[0]!=Q&&a[0].1R?6.1X(a,[]):6.1V(a,c));u C=19[19.D-1];l(C&&1T C=="q")7.W(C);v 7};l(1T $!="Q")6.44$=$;u $=6;6.C=6.8b={3E:"1.0.3",5J:q(){v 7.D},1n:q(23){l(23&&23.O==2z){7.D=0;[].1k.16(7,23);v 7}G v 23==Q?6.1X(7,[]):7[23]},W:q(C,1g){v 6.W(7,C,1g)},8g:q(15){u 2j=-1;7.W(q(i){l(7==15)2j=i});v 2j},1t:q(1L,Y,B){v 1L.O!=1C||Y!=Q?7.W(q(){l(Y==Q)I(u E 1r 1L)6.1t(B?7.1a:7,E,1L[E]);G 6.1t(B?7.1a:7,1L,Y)}):6[B||"1t"](7[0],1L)},1f:q(1L,Y){v 7.1t(1L,Y,"26")},2B:q(e){e=e||7;u t="";I(u j=0;j0:U},2T:q(1g,22,2X,C){u 4f=7.5J()>1;u a=6.3D(1g);v 7.W(q(){u 15=7;l(22&&7.2p.2b()=="8m"&&a[0].2p.2b()!="62"){u 29=7.4S("29");l(!29.D){15=17.5N("29");7.4e(15)}G 15=29[0]}I(u i=(2X<0?a.D-1:0);i!=(2X<0?2X:a.D);i+=2X){C.16(15,[4f?a[i].3f(T):a[i]])}})},2n:q(a,1g){u C=1g&&1g[1g.D-1];u 2d=1g&&1g[1g.D-2];l(C&&C.O!=1v)C=M;l(2d&&2d.O!=1v)2d=M;l(!C){l(!7.33)7.33=[];7.33.1k(7.1n());7.1n(a)}G{u 1Z=7.1n();7.1n(a);l(2d&&a.D||!2d)7.W(2d||C).1n(1Z);G 7.1n(1Z).W(C)}v 7}};6.1y=6.C.1y=q(15,E){l(19.D>1&&(E===M||E==Q))v 15;l(!E){E=15;15=7}I(u i 1r E)15[i]=E[i];v 15};6.1y({5C:q(){6.65=T;6.W(6.2e.5r,q(i,n){6.C[i]=q(a){u L=6.2r(7,n);l(a&&a.O==1C)L=6.1c(a,L).r;v 7.2n(L,19)}});6.W(6.2e.2o,q(i,n){6.C[i]=q(){u a=19;v 7.W(q(){I(u j=0;j",""];G l(!s.1b("<6w")||!s.1b("<29"))1Y=[1,"<22>",""];G l(!s.1b("<4t"))1Y=[2,"<22>",""];G l(!s.1b("<6x")||!s.1b("<6z"))1Y=[3,"<22><29><4t>",""];21.2V=1Y[1]+s+1Y[2];24(1Y[0]--)21=21.2a;I(u j=0;j<21.2f.D;j++)r.1k(21.2f[j])}G l(1M.D!=Q&&!1M.1R)I(u n=0;n<1M.D;n++)r.1k(1M[n]);G r.1k(1M.1R?1M:17.6A(1M.6C()))}v r},2u:{"":"m[2]== \'*\'||a.2p.2b()==m[2].2b()","#":"a.3a(\'3H\')&&a.3a(\'3H\')==m[2]",":":{5o:"im[3]-0",5L:"m[3]-0==i",5n:"m[3]-0==i",2h:"i==0",1N:"i==r.D-1",52:"i%2==0",53:"i%2","5L-3x":"6.1x(a,m[3]).1l","2h-3x":"6.1x(a,0).1l","1N-3x":"6.1x(a,0).1N","6D-3x":"6.1x(a).D==1",5s:"a.2f.D",5B:"!a.2f.D",5p:"6.C.2B.16([a]).1b(m[3])>=0",6E:"a.B!=\'1S\'&&6.1f(a,\'1u\')!=\'20\'&&6.1f(a,\'3U\')!=\'1S\'",1S:"a.B==\'1S\'||6.1f(a,\'1u\')==\'20\'||6.1f(a,\'3U\')==\'1S\'",6F:"!a.2P",2P:"a.2P",2J:"a.2J",3V:"a.3V || 6.1t(a, \'3V\')",2B:"a.B==\'2B\'",3W:"a.B==\'3W\'",5y:"a.B==\'5y\'",3Q:"a.B==\'3Q\'",5v:"a.B==\'5v\'",4x:"a.B==\'4x\'",5w:"a.B==\'5w\'",4w:"a.B==\'4w\'",4s:"a.B==\'4s\'",5z:"a.2p.4d().4T(/5z|3c|6L|4s/)"},".":"6.1j.3t(a,m[2])","@":{"=":"z==m[4]","!=":"z!=m[4]","^=":"z && !z.1b(m[4])","$=":"z && z.32(z.D - m[4].D,m[4].D)==m[4]","*=":"z && z.1b(m[4])>=0","":"z"},"[":"6.1V(m[2],a).D"},3B:["\\\\.\\\\.|/\\\\.\\\\.","a.1i",">|/","6.1x(a.2a)","\\\\+","6.1x(a).3z","~",q(a){u r=[];u s=6.1x(a);l(s.n>0)I(u i=s.n;i=1)t=t.32(t.1b("/"),t.D)}u L=[1o];u 1K=[];u 1N=M;24(t.D>0&&1N!=t){u r=[];1N=t;t=6.2K(t).1B(/^\\/\\//i,"");u 36=U;I(u i=0;i<6.3B.D;i+=2){l(36)51;u 2v=1h 43("^("+6.3B[i]+")");u m=2v.3d(t);l(m){r=L=6.2r(L,6.3B[i+1]);t=6.2K(t.1B(2v,""));36=T}}l(!36){l(!t.1b(",")||!t.1b("|")){l(L[0]==1o)L.4h();1K=6.1X(1K,L);r=L=[1o];t=" "+t.32(1,t.D)}G{u 3Z=/^([#.]?)([a-4Y-9\\\\*44-]*)/i;u m=3Z.3d(t);l(m[1]=="#"){u 4l=17.5V(m[2]);r=L=4l?[4l]:[];t=t.1B(3Z,"")}G{l(!m[2]||m[1]==".")m[2]="*";I(u i=0;i<\\/27>");u 27=17.5V("5W");27.2w=q(){l(7.3n!="1I")v;7.1i.3s(7);6.1W()};27=M}G l(6.11.2M){6.3N=42(q(){l(17.3n=="63"||17.3n=="1I"){56(6.3N);6.3N=M;6.1W()}},10)}6.J.2g(1z,"2S",6.1W)};l(6.11.1p)6(1z).4z(q(){u J=6.J,1e=J.1e;I(u B 1r 1e){u 3P=1e[B],i=3P.D;l(i>0)6a l(B!=\'4z\')J.25(3P[i-1],B);24(--i)}});6.C.1y({60:6.C.1A,1A:q(12,H){v 12?7.1U({1G:"1A",2c:"1A",1m:"1A"},12,H):7.60()},5U:6.C.1s,1s:q(12,H){v 12?7.1U({1G:"1s",2c:"1s",1m:"1s"},12,H):7.5U()},6n:q(12,H){v 7.1U({1G:"1A"},12,H)},6o:q(12,H){v 7.1U({1G:"1s"},12,H)},6p:q(12,H){v 7.W(q(){u 4J=6(7).4E(":1S")?"1A":"1s";6(7).1U({1G:4J},12,H)})},6r:q(12,H){v 7.1U({1m:"1A"},12,H)},6s:q(12,H){v 7.1U({1m:"1s"},12,H)},6t:q(12,2o,H){v 7.1U({1m:2o},12,H)},1U:q(E,12,H){v 7.1w(q(){7.2U=6.1y({},E);I(u p 1r E){u e=1h 6.2R(7,6.12(12,H),p);l(E[p].O==4O)e.3e(e.1l(),E[p]);G e[E[p]](E)}})},1w:q(B,C){l(!C){C=B;B="2R"}v 7.W(q(){l(!7.1w)7.1w={};l(!7.1w[B])7.1w[B]=[];7.1w[B].1k(C);l(7.1w[B].D==1)C.16(7)})}});6.1y({5f:q(e,p){l(e.5F)v;l(p=="1G"&&e.4L!=3l(6.26(e,p)))v;l(p=="2c"&&e.4M!=3l(6.26(e,p)))v;u a=e.1a[p];u o=6.26(e,p,1);l(p=="1G"&&e.4L!=o||p=="2c"&&e.4M!=o)v;e.1a[p]=e.34?"":"5H";u n=6.26(e,p,1);l(o!=n&&n!="5H"){e.1a[p]=a;e.5F=T}},12:q(s,o){o=o||{};l(o.O==1v)o={1I:o};u 5D={6G:6H,6J:4K};o.2E=(s&&s.O==4O?s:5D[s])||5k;o.3J=o.1I;o.1I=q(){6.4R(7,"2R");l(o.3J&&o.3J.O==1v)o.3J.16(7)};v o},1w:{},4R:q(F,B){B=B||"2R";l(F.1w&&F.1w[B]){F.1w[B].4h();u f=F.1w[B][0];l(f)f.16(F)}},2R:q(F,2x,E){u z=7;z.o={2E:2x.2E||5k,1I:2x.1I,2s:2x.2s};z.V=F;u y=z.V.1a;z.a=q(){l(2x.2s)2x.2s.16(F,[z.2i]);l(E=="1m")6.1t(y,"1m",z.2i);G l(3l(z.2i))y[E]=3l(z.2i)+"5d";y.1u="2F"};z.61=q(){v 4c(6.1f(z.V,E))};z.1l=q(){u r=4c(6.26(z.V,E));v r&&r>-6Z?r:z.61()};z.3e=q(41,2o){z.3M=(1h 54()).55();z.2i=41;z.a();z.49=42(q(){z.2s(41,2o)},13)};z.1A=q(){l(!z.V.1Q)z.V.1Q={};z.V.1Q[E]=7.1l();z.3e(0,z.V.1Q[E]);l(E!="1m")y[E]="77"};z.1s=q(){l(!z.V.1Q)z.V.1Q={};z.V.1Q[E]=7.1l();z.o.1s=T;z.3e(z.V.1Q[E],0)};l(!z.V.4b)z.V.4b=6.1f(z.V,"3h");y.3h="1S";z.2s=q(4B,4g){u t=(1h 54()).55();l(t>z.o.2E+z.3M){56(z.49);z.49=M;z.2i=4g;z.a();z.V.2U[E]=T;u 1K=T;I(u i 1r z.V.2U)l(z.V.2U[i]!==T)1K=U;l(1K){y.3h=z.V.4b;l(z.o.1s)y.1u=\'20\';l(z.o.1s){I(u p 1r z.V.2U){l(p=="1m")6.1t(y,p,z.V.1Q[p]);G y[p]=z.V.1Q[p]+"5d";l(p==\'1G\'||p==\'2c\')6.5f(z.V,p)}}}l(1K&&z.o.1I&&z.o.1I.O==1v)z.o.1I.16(z.V)}G{u p=(t-7.3M)/z.o.2E;z.2i=((-5q.7w(p*5q.7y)/2)+0.5)*(4g-4B)+4B;z.a()}}}});6.C.1y({7D:q(N,1O,H){7.2S(N,1O,H,1)},2S:q(N,1O,H,1F){l(N.O==1v)v 7.2Z("2S",N);H=H||q(){};u B="3T";l(1O){l(1O.O==1v){H=1O;1O=M}G{1O=6.2Q(1O);B="4W"}}u 4m=7;6.3I(B,N,1O,q(3v,18){l(18=="2D"||!1F&&18=="5m"){4m.38(3v.3G).3X().W(H,[3v.3G,18])}G H.16(4m,[3v.3G,18])},1F);v 7},7J:q(){v 6.2Q(7)},3X:q(){v 7.1V(\'27\').W(q(){l(7.3w)6.5Y(7.3w,q(){});G 3A.3O(1z,7.2B||7.7L||7.2V||"")}).4q()}});l(6.11.1p&&1T 3i=="Q")3i=q(){v 1h 7Q(5I.5K.1b("7W 5")>=0?"82.5R":"84.5R")};1h q(){u e="5O,5G,5A,5x,5t".3b(",");I(u i=0;i-1)?"&":"?")+6.2Q(K);6.3I("3T",N,M,q(r,18){l(H)H(6.3r(r,B),18)},1F)},8h:q(N,K,H,B){6.1n(N,K,H,B,1)},5Y:q(N,H){l(H)6.1n(N,M,H,"27");G{6.1n(N,M,M,"27")}},64:q(N,K,H){l(H)6.1n(N,K,H,"3S");G{6.1n(N,K,"3S")}},8o:q(N,K,H,B){6.3I("4W",N,6.2Q(K),q(r,18){l(H)H(6.3r(r,B),18)})},1q:0,6h:q(1q){6.1q=1q},39:{},3I:q(B,N,K,L,1F){u 1e=T;u 1q=6.1q;l(!N){L=B.1I;u 2D=B.2D;u 2l=B.2l;u 4k=B.4k;u 1e=1T B.1e=="6q"?B.1e:T;u 1q=1T B.1q=="6u"?B.1q:6.1q;1F=B.1F||U;K=B.K;N=B.N;B=B.B}l(1e&&!6.4v++)6.J.1P("5O");u 4y=U;u R=1h 3i();R.6B(B||"3T",N,T);l(K)R.3j("6I-6K","6M/x-6N-6Q-6T");l(1F)R.3j("6V-3Y-6Y",6.39[N]||"71, 74 75 78 46:46:46 79");R.3j("X-7a-7d","3i");l(R.7g)R.3j("7j","7k");u 2w=q(4F){l(R&&(R.3n==4||4F=="1q")){4y=T;u 18=6.4G(R)&&4F!="1q"?1F&&6.4N(R,N)?"5m":"2D":"2l";l(18!="2l"){u 3q;3u{3q=R.4i("4P-3Y")}3o(e){}l(1F&&3q)6.39[N]=3q;l(2D)2D(6.3r(R,4k),18);l(1e)6.J.1P("5t")}G{l(2l)2l(R,18);l(1e)6.J.1P("5x")}l(1e)6.J.1P("5A");l(1e&&!--6.4v)6.J.1P("5G");l(L)L(R,18);R.2w=q(){};R=M}};R.2w=2w;l(1q>0)7Z(q(){l(R){R.85();l(!4y)2w("1q");R=M}},1q);R.8i(K)},4v:0,4G:q(r){3u{v!r.18&&66.6d=="3Q:"||(r.18>=4K&&r.18<6y)||r.18==5b||6.11.2M&&r.18==Q}3o(e){}v U},4N:q(R,N){3u{u 4V=R.4i("4P-3Y");v R.18==5b||4V==6.39[N]||6.11.2M&&R.18==Q}3o(e){}v U},3r:q(r,B){u 4n=r.4i("7I-B");u K=!B&&4n&&4n.1b("R")>=0;K=B=="R"||K?r.80:r.3G;l(B=="27")3A.3O(1z,K);l(B=="3S")3A("K = "+K);l(B=="38")$("<21>").38(K).3X();v K},2Q:q(a){u s=[];l(a.O==2z||a.3E){I(u i=0;i", ">>" buttons have this class */ - text-align: center; /* They are the navigation buttons */ - padding: 2px; /* Make the buttons seem like they're pressing */ -} - -.calendar .nav { - background: #778 url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; /* Pressing it will take you to the current date */ - text-align: center; - background: #fff; - color: #000; - padding: 2px; -} - -.calendar thead .headrow { /* Row containing navigation buttons */ - background: #778; - color: #fff; -} - -.calendar thead .daynames { /* Row containing the day names */ - background: #bdf; -} - -.calendar thead .name { /* Cells in footer (only one right now) */ - text-align: center; - background: #556; - color: #fff; -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ - background: #007ED1; - color: #fff; -} - -.calendar thead .daynames { /* Row containing the day names */ - background: #C7E1F3; -} - -.calendar thead .name { /* Cells in footer (only one right now) */ - text-align: center; - background: #206A9B; - color: #fff; -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ - background: #edc; - color: #000; -} - -.calendar thead .name { /* Cells containing the day names */ - background: #fed; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells in footer (only one right now) */ - text-align: center; - background: #988; - color: #000; -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .name { /* Cells containing the day names */ - background: #dfb; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells in footer (only one right now) */ - text-align: center; - background: #565; - color: #fff; -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .daynames { /* Row containing the day names */ -} - -.calendar thead .name { /* Cells in footer (only one right now) */ -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ - /*background: #3B86A0;*/ - color: #363636; - font-weight: bold; -filter: -progid:DXImageTransform.Microsoft.Gradient(GradientType=0,StartColorStr=#ffffff,EndColorStr=#3b86a0); -} - -.calendar thead .name { /* Cells containing the day names */ - background: #fed; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells in footer (only one right now) */ - text-align: center; - background: #988; - color: #000; - -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .daynames { /* Row containing the day names */ -} - -.calendar thead .name { /* Cells in footer (only one right now) */ -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .daynames { /* Row containing the day names */ -} - -.calendar thead .name { /* Cells in footer (only one right now) */ -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .daynames { /* Row containing the day names */ -} - -.calendar thead .name { /* Cells in footer (only one right now) */ -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell containing navigation buttons */ -} - -.calendar thead .daynames { /* Row containing the day names */ -} - -.calendar thead .name { /* Cells in footer (only one right now) */ -} - -.calendar tfoot .ttip { /* Tooltip (status bar) cell ";} }, - { rex:/<(p|table)>(?:\xB6)?(?:\{(.*?)\})/g, tmplt:function($0,$1,$2){return "<"+$1+Wiky.style($2)+">";} }, - { rex:/

([ \t\f\v\xB6]*?)<\/p>/g, tmplt:"$1" }, // .. remove empty paragraphs .. - "Wiky.rules.shortcuts" - ], - nonwikiinlines: [ - { rex:/%(?:\{([^}]*)\})?(?:\(([^)]*)\))?(.*?)%/g, tmplt:function($0,$1,$2,$3){return Wiky.store("" + Wiky.apply($3, $2?Wiky.rules.lang[Wiky.attr($2)]:Wiky.rules.code) + "");} }, // inline code - { rex:/%(.*?)%/g, tmplt:function($0,$1){return Wiky.store("" + Wiky.apply($2, Wiky.rules.code) + "");} } - ], - wikiinlines: [ - { rex:/\*([^*]+)\*/g, tmplt:"$1" }, // .. strong .. - { rex:/_([^_]+)_/g, tmplt:"$1" }, - { rex:/\^([^^]+)\^/g, tmplt:"$1" }, - { rex:/~([^~]+)~/g, tmplt:"$1" }, - { rex:/\(-(.+?)-\)/g, tmplt:"$1" }, - { rex:/\?([^ \t\f\v\xB6]+)\((.+)\)\?/g, tmplt:"$1" }, // .. abbreviation .. - { rex:/\[(?:\{([^}]*)\})?[Ii]ma?ge?\:([^ ,\]]*)(?:[, ]([^\]]*))?\]/g, tmplt:function($0,$1,$2,$3){return Wiky.store("");} }, // wikimedia image style .. - { rex:/\[([^ ,]+)[, ]([^\]]*)\]/g, tmplt:function($0,$1,$2){return Wiky.store(""+$2+"");}}, // wiki block style uri's .. - { rex:/(((http(s?))\:\/\/)?[A-Za-z0-9\._\/~\-:]+\.(?:png|jpg|jpeg|gif|bmp))/g, tmplt:function($0,$1,$2){return Wiky.store("\""+$1+"\"/");} }, // simple images .. - { rex:/((mailto\:|javascript\:|(news|file|(ht|f)tp(s?))\:\/\/)[A-Za-z0-9\.:_\/~%\-+&#?!=()@\x80-\xB5\xB7\xFF]+)/g, tmplt:"$1" } // simple uri's .. - ], - escapes: [ - { rex:/\\([|*_~\^])/g, tmplt:function($0,$1){return Wiky.store($1);} }, - { rex:/\\&/g, tmplt:"&" }, - { rex:/\\>/g, tmplt:">" }, - { rex:/\\/g, tmplt:"↔"}, // $harr; - { rex:/<-/g, tmplt:"←"}, // ← - { rex:/->/g, tmplt:"→"}, //→ - ], - code: [ - { rex:/&/g, tmplt:"&"}, - { rex://g, tmplt:">"} - ], - lang: {} - }, - - inverse: { - all: [ - "Wiky.inverse.pre", - "Wiky.inverse.nonwikiblocks", - "Wiky.inverse.wikiblocks", - "Wiky.inverse.post" - ], - pre: [ - { rex:/(\r?\n)/g, tmplt:"\xB6" } // replace line breaks with '¶' .. - ], - post: [ - { rex:/@([0-9]+)@/g, tmplt:function($0,$1){return Wiky.restore($1);} }, // resolve blocks .. - { rex:/\xB6/g, tmplt:"\n" } // replace '¶' with line breaks .. - ], - nonwikiblocks: [ - { rex:/]*)>(.*?)<\/pre>/mgi, tmplt:function($0,$1,$2){return Wiky.store("["+Wiky.invStyle($1)+Wiky.invAttr($1,["lang"]).replace(/x\-/,"")+"%"+Wiky.apply($2, Wiky.hasAttr($1,"lang")?Wiky.inverse.lang[Wiky.attrVal($1,"lang").substr(2)]:Wiky.inverse.code)+"%]");} } //code block - ], - wikiblocks: [ - "Wiky.inverse.nonwikiinlines", - "Wiky.inverse.escapes", - "Wiky.inverse.wikiinlines", - { rex:/

(.*?)<\/h1>/mgi, tmplt:"=$1=" }, - { rex:/

(.*?)<\/h2>/mgi, tmplt:"==$1==" }, - { rex:/

(.*?)<\/h3>/mgi, tmplt:"===$1===" }, - { rex:/

(.*?)<\/h4>/mgi, tmplt:"====$1====" }, - { rex:/

(.*?)<\/h5>/mgi, tmplt:"=====$1=====" }, - { rex:/
(.*?)<\/h6>/mgi, tmplt:"======$1======" }, - { rex:/<(p|table)[^>]+(style=\"[^\"]*\")[^>]*>/mgi, tmplt:function($0,$1,$2){return "<"+$1+">"+Wiky.invStyle($2);} }, - { rex:/\xB6{2}
  • \"]*)\"?[^>]*?>([^<]*)/mgi, tmplt:function($0,$1,$2){return $1.replace(/u/g,"*").replace(/([01aAiIg])$/,"$1.")+" "+$2;}}, // list items .. - { rex:/(^|\xB6)<(u|o)l[^>]*?>\xB6/mgi, tmplt:"$1" }, // only outer level list start at BOL ... - { rex:/(<\/(?:dl|ol|ul|p)>[ \xB6]*<(?:p)>)/gi, tmplt:"\xB6\xB6" }, - { rex:/
    (.*?)<\/dt>[ \f\n\r\t\v]*
    /mgi, tmplt:"; $1: " }, - { rex:/]*)>/mgi, tmplt:function($0,$1){return Wiky.store("["+Wiky.invStyle($1)+Wiky.invAttr($1,["cite","title"])+"\"");} }, - { rex:/<\/blockquote>/mgi, tmplt:"\"]" }, - { rex:/
    • ", - r_p: "", - r_u: "", - c_c: "", -// c_u: "
    Hostname:"/>
    Title:"/>
    footer:"/>
    Introduction:
    Preview:
    <% "intro" get write-html %>
    HTML:
    Ad Block 1:
    Ad Block 2:
    Ad Block 3:
    containing the day names */ - border-bottom: 1px solid #556; - padding: 2px; - text-align: center; - color: #000; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #a66; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - background-color: #aaf; - color: #000; - border: 1px solid #04f; - padding: 1px; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - background-color: #77c; - padding: 2px 0px 0px 2px; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - color: #456; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #bbb; -} -.calendar tbody .day.othermonth.oweekend { - color: #fbb; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #bdf; -} - -.calendar tbody .rowhilite td { - background: #def; -} - -.calendar tbody .rowhilite td.wn { - background: #eef; -} - -.calendar tbody td.hilite { /* Hovered cells */ - background: #def; - padding: 1px 3px 1px 1px; - border: 1px solid #bbb; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - background: #cde; - padding: 2px 2px 0px 2px; -} - -.calendar tbody td.selected { /* Cell showing today date */ - font-weight: bold; - border: 1px solid #000; - padding: 1px 3px 1px 1px; - background: #fff; - color: #000; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #a66; -} - -.calendar tbody td.today { /* Cell showing selected date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #fff; - color: #445; - border-top: 1px solid #556; - padding: 1px; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - background: #aaf; - border: 1px solid #04f; - color: #000; - padding: 1px; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - background: #77c; - padding: 2px 0px 0px 2px; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - top: 0px; - left: 0px; - width: 4em; - cursor: default; - border: 1px solid #655; - background: #def; - color: #000; - font-size: 90%; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .hilite { - background: #acf; -} - -.calendar .combo .active { - border-top: 1px solid #46a; - border-bottom: 1px solid #46a; - background: #eef; - font-weight: bold; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #f4f0e8; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #667; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-blue2.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-blue2.css deleted file mode 100644 index 47128ecb0f..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-blue2.css +++ /dev/null @@ -1,236 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -div.calendar { position: relative; } - -.calendar, .calendar table { - border: 1px solid #206A9B; - font-size: 11px; - color: #000; - cursor: default; - background: #F1F8FC; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; /* They are the navigation buttons */ - padding: 2px; /* Make the buttons seem like they're pressing */ -} - -.calendar .nav { - background: #007ED1 url(menuarrow2.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; /* Pressing it will take you to the current date */ - text-align: center; - background: #000; - color: #fff; - padding: 2px; -} - -.calendar thead tr { /* Row
    containing the day names */ - border-bottom: 1px solid #206A9B; - padding: 2px; - text-align: center; - color: #000; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #a66; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - background-color: #34ABFA; - color: #000; - border: 1px solid #016DC5; - padding: 1px; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - background-color: #006AA9; - border: 1px solid #008AFF; - padding: 2px 0px 0px 2px; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - color: #456; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #bbb; -} -.calendar tbody .day.othermonth.oweekend { - color: #fbb; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #C7E1F3; -} - -.calendar tbody .rowhilite td { - background: #def; -} - -.calendar tbody .rowhilite td.wn { - background: #F1F8FC; -} - -.calendar tbody td.hilite { /* Hovered cells */ - background: #def; - padding: 1px 3px 1px 1px; - border: 1px solid #8FC4E8; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - background: #cde; - padding: 2px 2px 0px 2px; -} - -.calendar tbody td.selected { /* Cell showing today date */ - font-weight: bold; - border: 1px solid #000; - padding: 1px 3px 1px 1px; - background: #fff; - color: #000; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #a66; -} - -.calendar tbody td.today { /* Cell showing selected date */ - font-weight: bold; - color: #D50000; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #000; - color: #fff; - border-top: 1px solid #206A9B; - padding: 1px; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - background: #B8DAF0; - border: 1px solid #178AEB; - color: #000; - padding: 1px; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - background: #006AA9; - padding: 2px 0px 0px 2px; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - top: 0px; - left: 0px; - width: 4em; - cursor: default; - border: 1px solid #655; - background: #def; - color: #000; - font-size: 90%; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .hilite { - background: #34ABFA; - border-top: 1px solid #46a; - border-bottom: 1px solid #46a; - font-weight: bold; -} - -.calendar .combo .active { - border-top: 1px solid #46a; - border-bottom: 1px solid #46a; - background: #F1F8FC; - font-weight: bold; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #E3F0F9; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #F1F8FC; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #267DB7; - color: #fff; -} - -.calendar td.time span.active { - border-color: red; - background-color: #000; - color: #A5FF00; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-brown.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-brown.css deleted file mode 100644 index c42da5e0d9..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-brown.css +++ /dev/null @@ -1,225 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -div.calendar { position: relative; } - -.calendar, .calendar table { - border: 1px solid #655; - font-size: 11px; - color: #000; - cursor: default; - background: #ffd; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; /* They are the navigation buttons */ - padding: 2px; /* Make the buttons seem like they're pressing */ -} - -.calendar .nav { - background: #edc url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; /* Pressing it will take you to the current date */ - text-align: center; - background: #654; - color: #fed; - padding: 2px; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #655; - padding: 2px; - text-align: center; - color: #000; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - background-color: #faa; - color: #000; - border: 1px solid #f40; - padding: 1px; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - background-color: #c77; - padding: 2px 0px 0px 2px; -} - -.calendar thead .daynames { /* Row
    containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #bbb; -} -.calendar tbody .day.othermonth.oweekend { - color: #fbb; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #fed; -} - -.calendar tbody .rowhilite td { - background: #ddf; -} - -.calendar tbody .rowhilite td.wn { - background: #efe; -} - -.calendar tbody td.hilite { /* Hovered cells */ - background: #ffe; - padding: 1px 3px 1px 1px; - border: 1px solid #bbb; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - background: #ddc; - padding: 2px 2px 0px 2px; -} - -.calendar tbody td.selected { /* Cell showing today date */ - font-weight: bold; - border: 1px solid #000; - padding: 1px 3px 1px 1px; - background: #fea; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { font-weight: bold; } - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - border-top: 1px solid #655; - background: #dcb; - color: #840; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - background: #faa; - border: 1px solid #f40; - padding: 1px; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - background: #c77; - padding: 2px 0px 0px 2px; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - top: 0px; - left: 0px; - width: 4em; - cursor: default; - border: 1px solid #655; - background: #ffe; - color: #000; - font-size: 90%; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .hilite { - background: #fc8; -} - -.calendar .combo .active { - border-top: 1px solid #a64; - border-bottom: 1px solid #a64; - background: #fee; - font-weight: bold; -} - -.calendar td.time { - border-top: 1px solid #a88; - padding: 1px 0px; - text-align: center; - background-color: #fed; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #988; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #866; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-green.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-green.css deleted file mode 100644 index 2e1867a0c2..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-green.css +++ /dev/null @@ -1,229 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -div.calendar { position: relative; } - -.calendar, .calendar table { - border: 1px solid #565; - font-size: 11px; - color: #000; - cursor: default; - background: #efe; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; /* They are the navigation buttons */ - padding: 2px; /* Make the buttons seem like they're pressing */ - background: #676; - color: #fff; - font-size: 90%; -} - -.calendar .nav { - background: #676 url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; /* Pressing it will take you to the current date */ - text-align: center; - padding: 2px; - background: #250; - color: #efa; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #565; - padding: 2px; - text-align: center; - color: #000; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #a66; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - background-color: #afa; - color: #000; - border: 1px solid #084; - padding: 1px; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - background-color: #7c7; - padding: 2px 0px 0px 2px; -} - -.calendar thead .daynames { /* Row
    containing month days dates */ - width: 2em; - color: #564; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #bbb; -} -.calendar tbody .day.othermonth.oweekend { - color: #fbb; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #8a8; - background: #dfb; -} - -.calendar tbody .rowhilite td { - background: #dfd; -} - -.calendar tbody .rowhilite td.wn { - background: #efe; -} - -.calendar tbody td.hilite { /* Hovered cells */ - background: #efd; - padding: 1px 3px 1px 1px; - border: 1px solid #bbb; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - background: #dec; - padding: 2px 2px 0px 2px; -} - -.calendar tbody td.selected { /* Cell showing today date */ - font-weight: bold; - border: 1px solid #000; - padding: 1px 3px 1px 1px; - background: #f8fff8; - color: #000; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #a66; -} - -.calendar tbody td.today { font-weight: bold; color: #0a0; } - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - padding: 2px; - background: #250; - color: #efa; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - background: #afa; - border: 1px solid #084; - color: #000; - padding: 1px; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - background: #7c7; - padding: 2px 0px 0px 2px; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - top: 0px; - left: 0px; - width: 4em; - cursor: default; - border: 1px solid #565; - background: #efd; - color: #000; - font-size: 90%; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .hilite { - background: #af8; -} - -.calendar .combo .active { - border-top: 1px solid #6a4; - border-bottom: 1px solid #6a4; - background: #efe; - font-weight: bold; -} - -.calendar td.time { - border-top: 1px solid #8a8; - padding: 1px 0px; - text-align: center; - background-color: #dfb; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #898; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #686; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup.js b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup.js deleted file mode 100644 index f2b4854308..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup.js +++ /dev/null @@ -1,200 +0,0 @@ -/* Copyright Mihai Bazon, 2002, 2003 | http://dynarch.com/mishoo/ - * --------------------------------------------------------------------------- - * - * The DHTML Calendar - * - * Details and latest version at: - * http://dynarch.com/mishoo/calendar.epl - * - * This script is distributed under the GNU Lesser General Public License. - * Read the entire license text here: http://www.gnu.org/licenses/lgpl.html - * - * This file defines helper functions for setting up the calendar. They are - * intended to help non-programmers get a working calendar on their site - * quickly. This script should not be seen as part of the calendar. It just - * shows you what one can do with the calendar, while in the same time - * providing a quick and simple method for setting it up. If you need - * exhaustive customization of the calendar creation process feel free to - * modify this code to suit your needs (this is recommended and much better - * than modifying calendar.js itself). - */ - -// $Id: calendar-setup.js,v 1.25 2005/03/07 09:51:33 mishoo Exp $ - -/** - * This function "patches" an input field (or other element) to use a calendar - * widget for date selection. - * - * The "params" is a single object that can have the following properties: - * - * prop. name | description - * ------------------------------------------------------------------------------------------------- - * inputField | the ID of an input field to store the date - * displayArea | the ID of a DIV or other element to show the date - * button | ID of a button or other element that will trigger the calendar - * eventName | event that will trigger the calendar, without the "on" prefix (default: "click") - * ifFormat | date format that will be stored in the input field - * daFormat | the date format that will be used to display the date in displayArea - * singleClick | (true/false) wether the calendar is in single click mode or not (default: true) - * firstDay | numeric: 0 to 6. "0" means display Sunday first, "1" means display Monday first, etc. - * align | alignment (default: "Br"); if you don't know what's this see the calendar documentation - * range | array with 2 elements. Default: [1900, 2999] -- the range of years available - * weekNumbers | (true/false) if it's true (default) the calendar will display week numbers - * flat | null or element ID; if not null the calendar will be a flat calendar having the parent with the given ID - * flatCallback | function that receives a JS Date object and returns an URL to point the browser to (for flat calendar) - * disableFunc | function that receives a JS Date object and should return true if that date has to be disabled in the calendar - * onSelect | function that gets called when a date is selected. You don't _have_ to supply this (the default is generally okay) - * onClose | function that gets called when the calendar is closed. [default] - * onUpdate | function that gets called after the date is updated in the input field. Receives a reference to the calendar. - * date | the date that the calendar will be initially displayed to - * showsTime | default: false; if true the calendar will include a time selector - * timeFormat | the time format; can be "12" or "24", default is "12" - * electric | if true (default) then given fields/date areas are updated for each move; otherwise they're updated only on close - * step | configures the step of the years in drop-down boxes; default: 2 - * position | configures the calendar absolute position; default: null - * cache | if "true" (but default: "false") it will reuse the same calendar object, where possible - * showOthers | if "true" (but default: "false") it will show days from other months too - * - * None of them is required, they all have default values. However, if you - * pass none of "inputField", "displayArea" or "button" you'll get a warning - * saying "nothing to setup". - */ -Calendar.setup = function (params) { - function param_default(pname, def) { if (typeof params[pname] == "undefined") { params[pname] = def; } }; - - param_default("inputField", null); - param_default("displayArea", null); - param_default("button", null); - param_default("eventName", "click"); - param_default("ifFormat", "%Y/%m/%d"); - param_default("daFormat", "%Y/%m/%d"); - param_default("singleClick", true); - param_default("disableFunc", null); - param_default("dateStatusFunc", params["disableFunc"]); // takes precedence if both are defined - param_default("dateText", null); - param_default("firstDay", null); - param_default("align", "Br"); - param_default("range", [1900, 2999]); - param_default("weekNumbers", true); - param_default("flat", null); - param_default("flatCallback", null); - param_default("onSelect", null); - param_default("onClose", null); - param_default("onUpdate", null); - param_default("date", null); - param_default("showsTime", false); - param_default("timeFormat", "24"); - param_default("electric", true); - param_default("step", 2); - param_default("position", null); - param_default("cache", false); - param_default("showOthers", false); - param_default("multiple", null); - - var tmp = ["inputField", "displayArea", "button"]; - for (var i in tmp) { - if (typeof params[tmp[i]] == "string") { - params[tmp[i]] = document.getElementById(params[tmp[i]]); - } - } - if (!(params.flat || params.multiple || params.inputField || params.displayArea || params.button)) { - alert("Calendar.setup:\n Nothing to setup (no fields found). Please check your code"); - return false; - } - - function onSelect(cal) { - var p = cal.params; - var update = (cal.dateClicked || p.electric); - if (update && p.inputField) { - p.inputField.value = cal.date.print(p.ifFormat); - if (typeof p.inputField.onchange == "function") - p.inputField.onchange(); - } - if (update && p.displayArea) - p.displayArea.innerHTML = cal.date.print(p.daFormat); - if (update && typeof p.onUpdate == "function") - p.onUpdate(cal); - if (update && p.flat) { - if (typeof p.flatCallback == "function") - p.flatCallback(cal); - } - if (update && p.singleClick && cal.dateClicked) - cal.callCloseHandler(); - }; - - if (params.flat != null) { - if (typeof params.flat == "string") - params.flat = document.getElementById(params.flat); - if (!params.flat) { - alert("Calendar.setup:\n Flat specified but can't find parent."); - return false; - } - var cal = new Calendar(params.firstDay, params.date, params.onSelect || onSelect); - cal.showsOtherMonths = params.showOthers; - cal.showsTime = params.showsTime; - cal.time24 = (params.timeFormat == "24"); - cal.params = params; - cal.weekNumbers = params.weekNumbers; - cal.setRange(params.range[0], params.range[1]); - cal.setDateStatusHandler(params.dateStatusFunc); - cal.getDateText = params.dateText; - if (params.ifFormat) { - cal.setDateFormat(params.ifFormat); - } - if (params.inputField && typeof params.inputField.value == "string") { - cal.parseDate(params.inputField.value); - } - cal.create(params.flat); - cal.show(); - return false; - } - - var triggerEl = params.button || params.displayArea || params.inputField; - triggerEl["on" + params.eventName] = function() { - var dateEl = params.inputField || params.displayArea; - var dateFmt = params.inputField ? params.ifFormat : params.daFormat; - var mustCreate = false; - var cal = window.calendar; - if (dateEl) - params.date = Date.parseDate(dateEl.value || dateEl.innerHTML, dateFmt); - if (!(cal && params.cache)) { - window.calendar = cal = new Calendar(params.firstDay, - params.date, - params.onSelect || onSelect, - params.onClose || function(cal) { cal.hide(); }); - cal.showsTime = params.showsTime; - cal.time24 = (params.timeFormat == "24"); - cal.weekNumbers = params.weekNumbers; - mustCreate = true; - } else { - if (params.date) - cal.setDate(params.date); - cal.hide(); - } - if (params.multiple) { - cal.multiple = {}; - for (var i = params.multiple.length; --i >= 0;) { - var d = params.multiple[i]; - var ds = d.print("%Y%m%d"); - cal.multiple[ds] = d; - } - } - cal.showsOtherMonths = params.showOthers; - cal.yearStep = params.step; - cal.setRange(params.range[0], params.range[1]); - cal.params = params; - cal.setDateStatusHandler(params.dateStatusFunc); - cal.getDateText = params.dateText; - cal.setDateFormat(dateFmt); - if (mustCreate) - cal.create(); - cal.refresh(); - if (!params.position) - cal.showAtElement(params.button || params.displayArea || params.inputField, params.align); - else - cal.showAt(params.position[0], params.position[1]); - return false; - }; - - return cal; -}; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup_stripped.js b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup_stripped.js deleted file mode 100644 index 91c927f82e..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-setup_stripped.js +++ /dev/null @@ -1,21 +0,0 @@ -/* Copyright Mihai Bazon, 2002, 2003 | http://dynarch.com/mishoo/ - * --------------------------------------------------------------------------- - * - * The DHTML Calendar - * - * Details and latest version at: - * http://dynarch.com/mishoo/calendar.epl - * - * This script is distributed under the GNU Lesser General Public License. - * Read the entire license text here: http://www.gnu.org/licenses/lgpl.html - * - * This file defines helper functions for setting up the calendar. They are - * intended to help non-programmers get a working calendar on their site - * quickly. This script should not be seen as part of the calendar. It just - * shows you what one can do with the calendar, while in the same time - * providing a quick and simple method for setting it up. If you need - * exhaustive customization of the calendar creation process feel free to - * modify this code to suit your needs (this is recommended and much better - * than modifying calendar.js itself). - */ - Calendar.setup=function(params){function param_default(pname,def){if(typeof params[pname]=="undefined"){params[pname]=def;}};param_default("inputField",null);param_default("displayArea",null);param_default("button",null);param_default("eventName","click");param_default("ifFormat","%Y/%m/%d");param_default("daFormat","%Y/%m/%d");param_default("singleClick",true);param_default("disableFunc",null);param_default("dateStatusFunc",params["disableFunc"]);param_default("dateText",null);param_default("firstDay",null);param_default("align","Br");param_default("range",[1900,2999]);param_default("weekNumbers",true);param_default("flat",null);param_default("flatCallback",null);param_default("onSelect",null);param_default("onClose",null);param_default("onUpdate",null);param_default("date",null);param_default("showsTime",false);param_default("timeFormat","24");param_default("electric",true);param_default("step",2);param_default("position",null);param_default("cache",false);param_default("showOthers",false);param_default("multiple",null);var tmp=["inputField","displayArea","button"];for(var i in tmp){if(typeof params[tmp[i]]=="string"){params[tmp[i]]=document.getElementById(params[tmp[i]]);}}if(!(params.flat||params.multiple||params.inputField||params.displayArea||params.button)){alert("Calendar.setup:\n Nothing to setup (no fields found). Please check your code");return false;}function onSelect(cal){var p=cal.params;var update=(cal.dateClicked||p.electric);if(update&&p.inputField){p.inputField.value=cal.date.print(p.ifFormat);if(typeof p.inputField.onchange=="function")p.inputField.onchange();}if(update&&p.displayArea)p.displayArea.innerHTML=cal.date.print(p.daFormat);if(update&&typeof p.onUpdate=="function")p.onUpdate(cal);if(update&&p.flat){if(typeof p.flatCallback=="function")p.flatCallback(cal);}if(update&&p.singleClick&&cal.dateClicked)cal.callCloseHandler();};if(params.flat!=null){if(typeof params.flat=="string")params.flat=document.getElementById(params.flat);if(!params.flat){alert("Calendar.setup:\n Flat specified but can't find parent.");return false;}var cal=new Calendar(params.firstDay,params.date,params.onSelect||onSelect);cal.showsOtherMonths=params.showOthers;cal.showsTime=params.showsTime;cal.time24=(params.timeFormat=="24");cal.params=params;cal.weekNumbers=params.weekNumbers;cal.setRange(params.range[0],params.range[1]);cal.setDateStatusHandler(params.dateStatusFunc);cal.getDateText=params.dateText;if(params.ifFormat){cal.setDateFormat(params.ifFormat);}if(params.inputField&&typeof params.inputField.value=="string"){cal.parseDate(params.inputField.value);}cal.create(params.flat);cal.show();return false;}var triggerEl=params.button||params.displayArea||params.inputField;triggerEl["on"+params.eventName]=function(){var dateEl=params.inputField||params.displayArea;var dateFmt=params.inputField?params.ifFormat:params.daFormat;var mustCreate=false;var cal=window.calendar;if(dateEl)params.date=Date.parseDate(dateEl.value||dateEl.innerHTML,dateFmt);if(!(cal&¶ms.cache)){window.calendar=cal=new Calendar(params.firstDay,params.date,params.onSelect||onSelect,params.onClose||function(cal){cal.hide();});cal.showsTime=params.showsTime;cal.time24=(params.timeFormat=="24");cal.weekNumbers=params.weekNumbers;mustCreate=true;}else{if(params.date)cal.setDate(params.date);cal.hide();}if(params.multiple){cal.multiple={};for(var i=params.multiple.length;--i>=0;){var d=params.multiple[i];var ds=d.print("%Y%m%d");cal.multiple[ds]=d;}}cal.showsOtherMonths=params.showOthers;cal.yearStep=params.step;cal.setRange(params.range[0],params.range[1]);cal.params=params;cal.setDateStatusHandler(params.dateStatusFunc);cal.getDateText=params.dateText;cal.setDateFormat(dateFmt);if(mustCreate)cal.create();cal.refresh();if(!params.position)cal.showAtElement(params.button||params.displayArea||params.inputField,params.align);else cal.showAt(params.position[0],params.position[1]);return false;};return cal;}; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-system.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-system.css deleted file mode 100644 index b22488572e..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-system.css +++ /dev/null @@ -1,251 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -.calendar { - position: relative; - display: none; - border: 1px solid; - border-color: #fff #000 #000 #fff; - font-size: 11px; - cursor: default; - background: Window; - color: WindowText; - font-family: tahoma,verdana,sans-serif; -} - -.calendar table { - border: 1px solid; - border-color: #fff #000 #000 #fff; - font-size: 11px; - cursor: default; - background: Window; - color: WindowText; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; - padding: 1px; - border: 1px solid; - border-color: ButtonHighlight ButtonShadow ButtonShadow ButtonHighlight; - background: ButtonFace; -} - -.calendar .nav { - background: ButtonFace url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; - padding: 1px; - border: 1px solid #000; - background: ActiveCaption; - color: CaptionText; - text-align: center; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid ButtonShadow; - padding: 2px; - text-align: center; - background: ButtonFace; - color: ButtonText; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - border: 2px solid; - padding: 0px; - border-color: ButtonHighlight ButtonShadow ButtonShadow ButtonHighlight; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - border-width: 1px; - padding: 2px 0px 0px 2px; - border-color: ButtonShadow ButtonHighlight ButtonHighlight ButtonShadow; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid ButtonShadow; - background: ButtonFace; - color: ButtonText; -} - -.calendar tbody .rowhilite td { - background: Highlight; - color: HighlightText; -} - -.calendar tbody td.hilite { /* Hovered cells */ - padding: 1px 3px 1px 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - padding: 2px 2px 0px 2px; - border: 1px solid; - border-color: ButtonShadow ButtonHighlight ButtonHighlight ButtonShadow; -} - -.calendar tbody td.selected { /* Cell showing selected date */ - font-weight: bold; - border: 1px solid; - border-color: ButtonShadow ButtonHighlight ButtonHighlight ButtonShadow; - padding: 2px 2px 0px 2px; - background: ButtonFace; - color: ButtonText; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { /* Cell showing today date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody td.disabled { color: GrayText; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: ButtonFace; - padding: 1px; - border: 1px solid; - border-color: ButtonShadow ButtonHighlight ButtonHighlight ButtonShadow; - color: ButtonText; - text-align: center; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - padding: 1px; - background: #e4e0d8; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - width: 4em; - top: 0px; - left: 0px; - cursor: default; - border: 1px solid; - border-color: ButtonHighlight ButtonShadow ButtonShadow ButtonHighlight; - background: Menu; - color: MenuText; - font-size: 90%; - padding: 1px; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .active { - padding: 0px; - border: 1px solid #000; -} - -.calendar .combo .hilite { - background: Highlight; - color: HighlightText; -} - -.calendar td.time { - border-top: 1px solid ButtonShadow; - padding: 1px 0px; - text-align: center; - background-color: ButtonFace; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: Menu; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: Highlight; - color: HighlightText; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-tas.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-tas.css deleted file mode 100644 index c2f872168c..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-tas.css +++ /dev/null @@ -1,239 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -div.calendar { position: relative; } - -.calendar, .calendar table { - border: 1px solid #655; - font-size: 11px; - color: #000; - cursor: default; - background: #ffd; - font-family: tahoma,verdana,sans-serif; - filter: -progid:DXImageTransform.Microsoft.Gradient(GradientType=0,StartColorStr=#DDDCCC,EndColorStr=#FFFFFF); -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; /* They are the navigation buttons */ - padding: 2px; /* Make the buttons seem like they're pressing */ - color:#363636; -} - -.calendar .nav { - background: #edc url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; /* Pressing it will take you to the current date */ - text-align: center; - background: #654; - color: #363636; - padding: 2px; - filter: -progid:DXImageTransform.Microsoft.Gradient(GradientType=0,StartColorStr=#ffffff,EndColorStr=#dddccc); -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #655; - padding: 2px; - text-align: center; - color: #363636; - filter: -progid:DXImageTransform.Microsoft.Gradient(GradientType=0,StartColorStr=#DDDCCC,EndColorStr=#FFFFFF); -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - background-color: #ffcc86; - color: #000; - border: 1px solid #b59345; - padding: 1px; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - background-color: #c77; - padding: 2px 0px 0px 2px; -} - -.calendar thead .daynames { /* Row
    containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #fed; -} - -.calendar tbody .rowhilite td { - background: #ddf; - -} - -.calendar tbody .rowhilite td.wn { - background: #efe; -} - -.calendar tbody td.hilite { /* Hovered cells */ - background: #ffe; - padding: 1px 3px 1px 1px; - border: 1px solid #bbb; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - background: #ddc; - padding: 2px 2px 0px 2px; -} - -.calendar tbody td.selected { /* Cell showing today date */ - font-weight: bold; - border: 1px solid #000; - padding: 1px 3px 1px 1px; - background: #fea; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { font-weight: bold; } - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - border-top: 1px solid #655; - background: #dcb; - color: #363636; - font-weight: bold; - filter: -progid:DXImageTransform.Microsoft.Gradient(GradientType=0,StartColorStr=#FFFFFF,EndColorStr=#DDDCCC); -} -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - background: #faa; - border: 1px solid #f40; - padding: 1px; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - background: #c77; - padding: 2px 0px 0px 2px; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.combo { - position: absolute; - display: none; - top: 0px; - left: 0px; - width: 4em; - cursor: default; - border: 1px solid #655; - background: #ffe; - color: #000; - font-size: smaller; - z-index: 100; -} - -.combo .label, -.combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.combo .label-IEfix { - width: 4em; -} - -.combo .hilite { - background: #fc8; -} - -.combo .active { - border-top: 1px solid #a64; - border-bottom: 1px solid #a64; - background: #fee; - font-weight: bold; -} - -.calendar td.time { - border-top: 1px solid #a88; - padding: 1px 0px; - text-align: center; - background-color: #fed; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #988; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #866; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-1.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-1.css deleted file mode 100644 index 8c5d026657..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-1.css +++ /dev/null @@ -1,271 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -.calendar { - position: relative; - display: none; - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - font-size: 11px; - color: #000; - cursor: default; - background: #d4d0c8; - font-family: tahoma,verdana,sans-serif; -} - -.calendar table { - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - font-size: 11px; - color: #000; - cursor: default; - background: #d4d0c8; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; - padding: 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar .nav { - background: transparent url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; - padding: 1px; - border: 1px solid #000; - background: #848078; - color: #fff; - text-align: center; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #000; - padding: 2px; - text-align: center; - background: #f4f0e8; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - padding: 0px; - background-color: #e4e0d8; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - background-color: #c4c0b8; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #f4f0e8; -} - -.calendar tbody .rowhilite td { - background: #e4e0d8; -} - -.calendar tbody .rowhilite td.wn { - background: #d4d0c8; -} - -.calendar tbody td.hilite { /* Hovered cells */ - padding: 1px 3px 1px 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - padding: 2px 2px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar tbody td.selected { /* Cell showing selected date */ - font-weight: bold; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - padding: 2px 2px 0px 2px; - background: #e4e0d8; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { /* Cell showing today date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #f4f0e8; - padding: 1px; - border: 1px solid #000; - background: #848078; - color: #fff; - text-align: center; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - padding: 1px; - background: #e4e0d8; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - width: 4em; - top: 0px; - left: 0px; - cursor: default; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - background: #e4e0d8; - font-size: 90%; - padding: 1px; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .active { - background: #c4c0b8; - padding: 0px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar .combo .hilite { - background: #048; - color: #fea; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #f4f0e8; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #766; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-2.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-2.css deleted file mode 100644 index 6f37b7dcd7..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-2.css +++ /dev/null @@ -1,271 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -.calendar { - position: relative; - display: none; - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - font-size: 11px; - color: #000; - cursor: default; - background: #d4c8d0; - font-family: tahoma,verdana,sans-serif; -} - -.calendar table { - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - font-size: 11px; - color: #000; - cursor: default; - background: #d4c8d0; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; - padding: 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar .nav { - background: transparent url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; - padding: 1px; - border: 1px solid #000; - background: #847880; - color: #fff; - text-align: center; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #000; - padding: 2px; - text-align: center; - background: #f4e8f0; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - padding: 0px; - background-color: #e4d8e0; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - background-color: #c4b8c0; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #f4e8f0; -} - -.calendar tbody .rowhilite td { - background: #e4d8e0; -} - -.calendar tbody .rowhilite td.wn { - background: #d4c8d0; -} - -.calendar tbody td.hilite { /* Hovered cells */ - padding: 1px 3px 1px 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - padding: 2px 2px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar tbody td.selected { /* Cell showing selected date */ - font-weight: bold; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - padding: 2px 2px 0px 2px; - background: #e4d8e0; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { /* Cell showing today date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #f4e8f0; - padding: 1px; - border: 1px solid #000; - background: #847880; - color: #fff; - text-align: center; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - padding: 1px; - background: #e4d8e0; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - width: 4em; - top: 0px; - left: 0px; - cursor: default; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - background: #e4d8e0; - font-size: 90%; - padding: 1px; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .active { - background: #d4c8d0; - padding: 0px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar .combo .hilite { - background: #408; - color: #fea; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #f4f0e8; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #766; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-1.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-1.css deleted file mode 100644 index fa5c093217..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-1.css +++ /dev/null @@ -1,265 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -.calendar { - position: relative; - display: none; - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - font-size: 11px; - color: #000; - cursor: default; - background: #c8d0d4; - font-family: tahoma,verdana,sans-serif; -} - -.calendar table { - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - font-size: 11px; - color: #000; - cursor: default; - background: #c8d0d4; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; - padding: 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar .nav { - background: transparent url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; - padding: 1px; - border: 1px solid #000; - background: #788084; - color: #fff; - text-align: center; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #000; - padding: 2px; - text-align: center; - background: #e8f0f4; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - padding: 0px; - background-color: #d8e0e4; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - background-color: #b8c0c4; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #e8f4f0; -} - -.calendar tbody .rowhilite td { - background: #d8e4e0; -} - -.calendar tbody .rowhilite td.wn { - background: #c8d4d0; -} - -.calendar tbody td.hilite { /* Hovered cells */ - padding: 1px 3px 1px 1px; - border: 1px solid; - border-color: #fff #000 #000 #fff; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - padding: 2px 2px 0px 2px; - border: 1px solid; - border-color: #000 #fff #fff #000; -} - -.calendar tbody td.selected { /* Cell showing selected date */ - font-weight: bold; - padding: 2px 2px 0px 2px; - border: 1px solid; - border-color: #000 #fff #fff #000; - background: #d8e0e4; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { /* Cell showing today date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #e8f0f4; - padding: 1px; - border: 1px solid #000; - background: #788084; - color: #fff; - text-align: center; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - padding: 1px; - background: #d8e0e4; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - width: 4em; - top: 0px; - left: 0px; - cursor: default; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - background: #d8e0e4; - font-size: 90%; - padding: 1px; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .active { - background: #c8d0d4; - padding: 0px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar .combo .hilite { - background: #048; - color: #aef; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #e8f0f4; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #667; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-2.css b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-2.css deleted file mode 100644 index 8e930c8f4f..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar-win2k-cold-2.css +++ /dev/null @@ -1,271 +0,0 @@ -/* The main calendar widget. DIV containing a table. */ - -.calendar { - position: relative; - display: none; - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - font-size: 11px; - color: #000; - cursor: default; - background: #c8d4d0; - font-family: tahoma,verdana,sans-serif; -} - -.calendar table { - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - font-size: 11px; - color: #000; - cursor: default; - background: #c8d4d0; - font-family: tahoma,verdana,sans-serif; -} - -/* Header part -- contains navigation buttons and day names. */ - -.calendar .button { /* "<<", "<", ">", ">>" buttons have this class */ - text-align: center; - padding: 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar .nav { - background: transparent url(menuarrow.gif) no-repeat 100% 100%; -} - -.calendar thead .title { /* This holds the current "month, year" */ - font-weight: bold; - padding: 1px; - border: 1px solid #000; - background: #788480; - color: #fff; - text-align: center; -} - -.calendar thead .headrow { /* Row
    containing the day names */ - border-bottom: 1px solid #000; - padding: 2px; - text-align: center; - background: #e8f4f0; -} - -.calendar thead .weekend { /* How a weekend day name shows in header */ - color: #f00; -} - -.calendar thead .hilite { /* How do the buttons in header appear when hover */ - border-top: 2px solid #fff; - border-right: 2px solid #000; - border-bottom: 2px solid #000; - border-left: 2px solid #fff; - padding: 0px; - background-color: #d8e4e0; -} - -.calendar thead .active { /* Active (pressed) buttons in header */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - background-color: #b8c4c0; -} - -/* The body part -- contains all the days in month. */ - -.calendar tbody .day { /* Cells containing month days dates */ - width: 2em; - text-align: right; - padding: 2px 4px 2px 2px; -} -.calendar tbody .day.othermonth { - font-size: 80%; - color: #aaa; -} -.calendar tbody .day.othermonth.oweekend { - color: #faa; -} - -.calendar table .wn { - padding: 2px 3px 2px 2px; - border-right: 1px solid #000; - background: #e8f4f0; -} - -.calendar tbody .rowhilite td { - background: #d8e4e0; -} - -.calendar tbody .rowhilite td.wn { - background: #c8d4d0; -} - -.calendar tbody td.hilite { /* Hovered cells */ - padding: 1px 3px 1px 1px; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; -} - -.calendar tbody td.active { /* Active (pressed) cells */ - padding: 2px 2px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar tbody td.selected { /* Cell showing selected date */ - font-weight: bold; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; - padding: 2px 2px 0px 2px; - background: #d8e4e0; -} - -.calendar tbody td.weekend { /* Cells showing weekend days */ - color: #f00; -} - -.calendar tbody td.today { /* Cell showing today date */ - font-weight: bold; - color: #00f; -} - -.calendar tbody .disabled { color: #999; } - -.calendar tbody .emptycell { /* Empty cells (the best is to hide them) */ - visibility: hidden; -} - -.calendar tbody .emptyrow { /* Empty row (some months need less than 6 rows) */ - display: none; -} - -/* The footer part -- status bar and "Close" button */ - -.calendar tfoot .footrow { /* The
    */ - background: #e8f4f0; - padding: 1px; - border: 1px solid #000; - background: #788480; - color: #fff; - text-align: center; -} - -.calendar tfoot .hilite { /* Hover style for buttons in footer */ - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - padding: 1px; - background: #d8e4e0; -} - -.calendar tfoot .active { /* Active (pressed) style for buttons in footer */ - padding: 2px 0px 0px 2px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -/* Combo boxes (menus that display months/years for direct selection) */ - -.calendar .combo { - position: absolute; - display: none; - width: 4em; - top: 0px; - left: 0px; - cursor: default; - border-top: 1px solid #fff; - border-right: 1px solid #000; - border-bottom: 1px solid #000; - border-left: 1px solid #fff; - background: #d8e4e0; - font-size: 90%; - padding: 1px; - z-index: 100; -} - -.calendar .combo .label, -.calendar .combo .label-IEfix { - text-align: center; - padding: 1px; -} - -.calendar .combo .label-IEfix { - width: 4em; -} - -.calendar .combo .active { - background: #c8d4d0; - padding: 0px; - border-top: 1px solid #000; - border-right: 1px solid #fff; - border-bottom: 1px solid #fff; - border-left: 1px solid #000; -} - -.calendar .combo .hilite { - background: #048; - color: #aef; -} - -.calendar td.time { - border-top: 1px solid #000; - padding: 1px 0px; - text-align: center; - background-color: #e8f0f4; -} - -.calendar td.time .hour, -.calendar td.time .minute, -.calendar td.time .ampm { - padding: 0px 3px 0px 4px; - border: 1px solid #889; - font-weight: bold; - background-color: #fff; -} - -.calendar td.time .ampm { - text-align: center; -} - -.calendar td.time .colon { - padding: 0px 2px 0px 3px; - font-weight: bold; -} - -.calendar td.time span.hilite { - border-color: #000; - background-color: #667; - color: #fff; -} - -.calendar td.time span.active { - border-color: #f00; - background-color: #000; - color: #0f0; -} diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar.js b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar.js deleted file mode 100644 index 9088e0e897..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar.js +++ /dev/null @@ -1,1806 +0,0 @@ -/* Copyright Mihai Bazon, 2002-2005 | www.bazon.net/mishoo - * ----------------------------------------------------------- - * - * The DHTML Calendar, version 1.0 "It is happening again" - * - * Details and latest version at: - * www.dynarch.com/projects/calendar - * - * This script is developed by Dynarch.com. Visit us at www.dynarch.com. - * - * This script is distributed under the GNU Lesser General Public License. - * Read the entire license text here: http://www.gnu.org/licenses/lgpl.html - */ - -// $Id: calendar.js,v 1.51 2005/03/07 16:44:31 mishoo Exp $ - -/** The Calendar object constructor. */ -Calendar = function (firstDayOfWeek, dateStr, onSelected, onClose) { - // member variables - this.activeDiv = null; - this.currentDateEl = null; - this.getDateStatus = null; - this.getDateToolTip = null; - this.getDateText = null; - this.timeout = null; - this.onSelected = onSelected || null; - this.onClose = onClose || null; - this.dragging = false; - this.hidden = false; - this.minYear = 1970; - this.maxYear = 2050; - this.dateFormat = Calendar._TT["DEF_DATE_FORMAT"]; - this.ttDateFormat = Calendar._TT["TT_DATE_FORMAT"]; - this.isPopup = true; - this.weekNumbers = true; - this.firstDayOfWeek = typeof firstDayOfWeek == "number" ? firstDayOfWeek : Calendar._FD; // 0 for Sunday, 1 for Monday, etc. - this.showsOtherMonths = false; - this.dateStr = dateStr; - this.ar_days = null; - this.showsTime = false; - this.time24 = true; - this.yearStep = 2; - this.hiliteToday = true; - this.multiple = null; - // HTML elements - this.table = null; - this.element = null; - this.tbody = null; - this.firstdayname = null; - // Combo boxes - this.monthsCombo = null; - this.yearsCombo = null; - this.hilitedMonth = null; - this.activeMonth = null; - this.hilitedYear = null; - this.activeYear = null; - // Information - this.dateClicked = false; - - // one-time initializations - if (typeof Calendar._SDN == "undefined") { - // table of short day names - if (typeof Calendar._SDN_len == "undefined") - Calendar._SDN_len = 3; - var ar = new Array(); - for (var i = 8; i > 0;) { - ar[--i] = Calendar._DN[i].substr(0, Calendar._SDN_len); - } - Calendar._SDN = ar; - // table of short month names - if (typeof Calendar._SMN_len == "undefined") - Calendar._SMN_len = 3; - ar = new Array(); - for (var i = 12; i > 0;) { - ar[--i] = Calendar._MN[i].substr(0, Calendar._SMN_len); - } - Calendar._SMN = ar; - } -}; - -// ** constants - -/// "static", needed for event handlers. -Calendar._C = null; - -/// detect a special case of "web browser" -Calendar.is_ie = ( /msie/i.test(navigator.userAgent) && - !/opera/i.test(navigator.userAgent) ); - -Calendar.is_ie5 = ( Calendar.is_ie && /msie 5\.0/i.test(navigator.userAgent) ); - -/// detect Opera browser -Calendar.is_opera = /opera/i.test(navigator.userAgent); - -/// detect KHTML-based browsers -Calendar.is_khtml = /Konqueror|Safari|KHTML/i.test(navigator.userAgent); - -// BEGIN: UTILITY FUNCTIONS; beware that these might be moved into a separate -// library, at some point. - -Calendar.getAbsolutePos = function(el) { - var SL = 0, ST = 0; - var is_div = /^div$/i.test(el.tagName); - if (is_div && el.scrollLeft) - SL = el.scrollLeft; - if (is_div && el.scrollTop) - ST = el.scrollTop; - var r = { x: el.offsetLeft - SL, y: el.offsetTop - ST }; - if (el.offsetParent) { - var tmp = this.getAbsolutePos(el.offsetParent); - r.x += tmp.x; - r.y += tmp.y; - } - return r; -}; - -Calendar.isRelated = function (el, evt) { - var related = evt.relatedTarget; - if (!related) { - var type = evt.type; - if (type == "mouseover") { - related = evt.fromElement; - } else if (type == "mouseout") { - related = evt.toElement; - } - } - while (related) { - if (related == el) { - return true; - } - related = related.parentNode; - } - return false; -}; - -Calendar.removeClass = function(el, className) { - if (!(el && el.className)) { - return; - } - var cls = el.className.split(" "); - var ar = new Array(); - for (var i = cls.length; i > 0;) { - if (cls[--i] != className) { - ar[ar.length] = cls[i]; - } - } - el.className = ar.join(" "); -}; - -Calendar.addClass = function(el, className) { - Calendar.removeClass(el, className); - el.className += " " + className; -}; - -// FIXME: the following 2 functions totally suck, are useless and should be replaced immediately. -Calendar.getElement = function(ev) { - var f = Calendar.is_ie ? window.event.srcElement : ev.currentTarget; - while (f.nodeType != 1 || /^div$/i.test(f.tagName)) - f = f.parentNode; - return f; -}; - -Calendar.getTargetElement = function(ev) { - var f = Calendar.is_ie ? window.event.srcElement : ev.target; - while (f.nodeType != 1) - f = f.parentNode; - return f; -}; - -Calendar.stopEvent = function(ev) { - ev || (ev = window.event); - if (Calendar.is_ie) { - ev.cancelBubble = true; - ev.returnValue = false; - } else { - ev.preventDefault(); - ev.stopPropagation(); - } - return false; -}; - -Calendar.addEvent = function(el, evname, func) { - if (el.attachEvent) { // IE - el.attachEvent("on" + evname, func); - } else if (el.addEventListener) { // Gecko / W3C - el.addEventListener(evname, func, true); - } else { - el["on" + evname] = func; - } -}; - -Calendar.removeEvent = function(el, evname, func) { - if (el.detachEvent) { // IE - el.detachEvent("on" + evname, func); - } else if (el.removeEventListener) { // Gecko / W3C - el.removeEventListener(evname, func, true); - } else { - el["on" + evname] = null; - } -}; - -Calendar.createElement = function(type, parent) { - var el = null; - if (document.createElementNS) { - // use the XHTML namespace; IE won't normally get here unless - // _they_ "fix" the DOM2 implementation. - el = document.createElementNS("http://www.w3.org/1999/xhtml", type); - } else { - el = document.createElement(type); - } - if (typeof parent != "undefined") { - parent.appendChild(el); - } - return el; -}; - -// END: UTILITY FUNCTIONS - -// BEGIN: CALENDAR STATIC FUNCTIONS - -/** Internal -- adds a set of events to make some element behave like a button. */ -Calendar._add_evs = function(el) { - with (Calendar) { - addEvent(el, "mouseover", dayMouseOver); - addEvent(el, "mousedown", dayMouseDown); - addEvent(el, "mouseout", dayMouseOut); - if (is_ie) { - addEvent(el, "dblclick", dayMouseDblClick); - el.setAttribute("unselectable", true); - } - } -}; - -Calendar.findMonth = function(el) { - if (typeof el.month != "undefined") { - return el; - } else if (typeof el.parentNode.month != "undefined") { - return el.parentNode; - } - return null; -}; - -Calendar.findYear = function(el) { - if (typeof el.year != "undefined") { - return el; - } else if (typeof el.parentNode.year != "undefined") { - return el.parentNode; - } - return null; -}; - -Calendar.showMonthsCombo = function () { - var cal = Calendar._C; - if (!cal) { - return false; - } - var cal = cal; - var cd = cal.activeDiv; - var mc = cal.monthsCombo; - if (cal.hilitedMonth) { - Calendar.removeClass(cal.hilitedMonth, "hilite"); - } - if (cal.activeMonth) { - Calendar.removeClass(cal.activeMonth, "active"); - } - var mon = cal.monthsCombo.getElementsByTagName("div")[cal.date.getMonth()]; - Calendar.addClass(mon, "active"); - cal.activeMonth = mon; - var s = mc.style; - s.display = "block"; - if (cd.navtype < 0) - s.left = cd.offsetLeft + "px"; - else { - var mcw = mc.offsetWidth; - if (typeof mcw == "undefined") - // Konqueror brain-dead techniques - mcw = 50; - s.left = (cd.offsetLeft + cd.offsetWidth - mcw) + "px"; - } - s.top = (cd.offsetTop + cd.offsetHeight) + "px"; -}; - -Calendar.showYearsCombo = function (fwd) { - var cal = Calendar._C; - if (!cal) { - return false; - } - var cal = cal; - var cd = cal.activeDiv; - var yc = cal.yearsCombo; - if (cal.hilitedYear) { - Calendar.removeClass(cal.hilitedYear, "hilite"); - } - if (cal.activeYear) { - Calendar.removeClass(cal.activeYear, "active"); - } - cal.activeYear = null; - var Y = cal.date.getFullYear() + (fwd ? 1 : -1); - var yr = yc.firstChild; - var show = false; - for (var i = 12; i > 0; --i) { - if (Y >= cal.minYear && Y <= cal.maxYear) { - yr.innerHTML = Y; - yr.year = Y; - yr.style.display = "block"; - show = true; - } else { - yr.style.display = "none"; - } - yr = yr.nextSibling; - Y += fwd ? cal.yearStep : -cal.yearStep; - } - if (show) { - var s = yc.style; - s.display = "block"; - if (cd.navtype < 0) - s.left = cd.offsetLeft + "px"; - else { - var ycw = yc.offsetWidth; - if (typeof ycw == "undefined") - // Konqueror brain-dead techniques - ycw = 50; - s.left = (cd.offsetLeft + cd.offsetWidth - ycw) + "px"; - } - s.top = (cd.offsetTop + cd.offsetHeight) + "px"; - } -}; - -// event handlers - -Calendar.tableMouseUp = function(ev) { - var cal = Calendar._C; - if (!cal) { - return false; - } - if (cal.timeout) { - clearTimeout(cal.timeout); - } - var el = cal.activeDiv; - if (!el) { - return false; - } - var target = Calendar.getTargetElement(ev); - ev || (ev = window.event); - Calendar.removeClass(el, "active"); - if (target == el || target.parentNode == el) { - Calendar.cellClick(el, ev); - } - var mon = Calendar.findMonth(target); - var date = null; - if (mon) { - date = new Date(cal.date); - if (mon.month != date.getMonth()) { - date.setMonth(mon.month); - cal.setDate(date); - cal.dateClicked = false; - cal.callHandler(); - } - } else { - var year = Calendar.findYear(target); - if (year) { - date = new Date(cal.date); - if (year.year != date.getFullYear()) { - date.setFullYear(year.year); - cal.setDate(date); - cal.dateClicked = false; - cal.callHandler(); - } - } - } - with (Calendar) { - removeEvent(document, "mouseup", tableMouseUp); - removeEvent(document, "mouseover", tableMouseOver); - removeEvent(document, "mousemove", tableMouseOver); - cal._hideCombos(); - _C = null; - return stopEvent(ev); - } -}; - -Calendar.tableMouseOver = function (ev) { - var cal = Calendar._C; - if (!cal) { - return; - } - var el = cal.activeDiv; - var target = Calendar.getTargetElement(ev); - if (target == el || target.parentNode == el) { - Calendar.addClass(el, "hilite active"); - Calendar.addClass(el.parentNode, "rowhilite"); - } else { - if (typeof el.navtype == "undefined" || (el.navtype != 50 && (el.navtype == 0 || Math.abs(el.navtype) > 2))) - Calendar.removeClass(el, "active"); - Calendar.removeClass(el, "hilite"); - Calendar.removeClass(el.parentNode, "rowhilite"); - } - ev || (ev = window.event); - if (el.navtype == 50 && target != el) { - var pos = Calendar.getAbsolutePos(el); - var w = el.offsetWidth; - var x = ev.clientX; - var dx; - var decrease = true; - if (x > pos.x + w) { - dx = x - pos.x - w; - decrease = false; - } else - dx = pos.x - x; - - if (dx < 0) dx = 0; - var range = el._range; - var current = el._current; - var count = Math.floor(dx / 10) % range.length; - for (var i = range.length; --i >= 0;) - if (range[i] == current) - break; - while (count-- > 0) - if (decrease) { - if (--i < 0) - i = range.length - 1; - } else if ( ++i >= range.length ) - i = 0; - var newval = range[i]; - el.innerHTML = newval; - - cal.onUpdateTime(); - } - var mon = Calendar.findMonth(target); - if (mon) { - if (mon.month != cal.date.getMonth()) { - if (cal.hilitedMonth) { - Calendar.removeClass(cal.hilitedMonth, "hilite"); - } - Calendar.addClass(mon, "hilite"); - cal.hilitedMonth = mon; - } else if (cal.hilitedMonth) { - Calendar.removeClass(cal.hilitedMonth, "hilite"); - } - } else { - if (cal.hilitedMonth) { - Calendar.removeClass(cal.hilitedMonth, "hilite"); - } - var year = Calendar.findYear(target); - if (year) { - if (year.year != cal.date.getFullYear()) { - if (cal.hilitedYear) { - Calendar.removeClass(cal.hilitedYear, "hilite"); - } - Calendar.addClass(year, "hilite"); - cal.hilitedYear = year; - } else if (cal.hilitedYear) { - Calendar.removeClass(cal.hilitedYear, "hilite"); - } - } else if (cal.hilitedYear) { - Calendar.removeClass(cal.hilitedYear, "hilite"); - } - } - return Calendar.stopEvent(ev); -}; - -Calendar.tableMouseDown = function (ev) { - if (Calendar.getTargetElement(ev) == Calendar.getElement(ev)) { - return Calendar.stopEvent(ev); - } -}; - -Calendar.calDragIt = function (ev) { - var cal = Calendar._C; - if (!(cal && cal.dragging)) { - return false; - } - var posX; - var posY; - if (Calendar.is_ie) { - posY = window.event.clientY + document.body.scrollTop; - posX = window.event.clientX + document.body.scrollLeft; - } else { - posX = ev.pageX; - posY = ev.pageY; - } - cal.hideShowCovered(); - var st = cal.element.style; - st.left = (posX - cal.xOffs) + "px"; - st.top = (posY - cal.yOffs) + "px"; - return Calendar.stopEvent(ev); -}; - -Calendar.calDragEnd = function (ev) { - var cal = Calendar._C; - if (!cal) { - return false; - } - cal.dragging = false; - with (Calendar) { - removeEvent(document, "mousemove", calDragIt); - removeEvent(document, "mouseup", calDragEnd); - tableMouseUp(ev); - } - cal.hideShowCovered(); -}; - -Calendar.dayMouseDown = function(ev) { - var el = Calendar.getElement(ev); - if (el.disabled) { - return false; - } - var cal = el.calendar; - cal.activeDiv = el; - Calendar._C = cal; - if (el.navtype != 300) with (Calendar) { - if (el.navtype == 50) { - el._current = el.innerHTML; - addEvent(document, "mousemove", tableMouseOver); - } else - addEvent(document, Calendar.is_ie5 ? "mousemove" : "mouseover", tableMouseOver); - addClass(el, "hilite active"); - addEvent(document, "mouseup", tableMouseUp); - } else if (cal.isPopup) { - cal._dragStart(ev); - } - if (el.navtype == -1 || el.navtype == 1) { - if (cal.timeout) clearTimeout(cal.timeout); - cal.timeout = setTimeout("Calendar.showMonthsCombo()", 250); - } else if (el.navtype == -2 || el.navtype == 2) { - if (cal.timeout) clearTimeout(cal.timeout); - cal.timeout = setTimeout((el.navtype > 0) ? "Calendar.showYearsCombo(true)" : "Calendar.showYearsCombo(false)", 250); - } else { - cal.timeout = null; - } - return Calendar.stopEvent(ev); -}; - -Calendar.dayMouseDblClick = function(ev) { - Calendar.cellClick(Calendar.getElement(ev), ev || window.event); - if (Calendar.is_ie) { - document.selection.empty(); - } -}; - -Calendar.dayMouseOver = function(ev) { - var el = Calendar.getElement(ev); - if (Calendar.isRelated(el, ev) || Calendar._C || el.disabled) { - return false; - } - if (el.ttip) { - if (el.ttip.substr(0, 1) == "_") { - el.ttip = el.caldate.print(el.calendar.ttDateFormat) + el.ttip.substr(1); - } - el.calendar.tooltips.innerHTML = el.ttip; - } - if (el.navtype != 300) { - Calendar.addClass(el, "hilite"); - if (el.caldate) { - Calendar.addClass(el.parentNode, "rowhilite"); - } - } - return Calendar.stopEvent(ev); -}; - -Calendar.dayMouseOut = function(ev) { - with (Calendar) { - var el = getElement(ev); - if (isRelated(el, ev) || _C || el.disabled) - return false; - removeClass(el, "hilite"); - if (el.caldate) - removeClass(el.parentNode, "rowhilite"); - if (el.calendar) - el.calendar.tooltips.innerHTML = _TT["SEL_DATE"]; - return stopEvent(ev); - } -}; - -/** - * A generic "click" handler :) handles all types of buttons defined in this - * calendar. - */ -Calendar.cellClick = function(el, ev) { - var cal = el.calendar; - var closing = false; - var newdate = false; - var date = null; - if (typeof el.navtype == "undefined") { - if (cal.currentDateEl) { - Calendar.removeClass(cal.currentDateEl, "selected"); - Calendar.addClass(el, "selected"); - closing = (cal.currentDateEl == el); - if (!closing) { - cal.currentDateEl = el; - } - } - cal.date.setDateOnly(el.caldate); - date = cal.date; - var other_month = !(cal.dateClicked = !el.otherMonth); - if (!other_month && !cal.currentDateEl) - cal._toggleMultipleDate(new Date(date)); - else - newdate = !el.disabled; - // a date was clicked - if (other_month) - cal._init(cal.firstDayOfWeek, date); - } else { - if (el.navtype == 200) { - Calendar.removeClass(el, "hilite"); - cal.callCloseHandler(); - return; - } - date = new Date(cal.date); - if (el.navtype == 0) - date.setDateOnly(new Date()); // TODAY - // unless "today" was clicked, we assume no date was clicked so - // the selected handler will know not to close the calenar when - // in single-click mode. - // cal.dateClicked = (el.navtype == 0); - cal.dateClicked = false; - var year = date.getFullYear(); - var mon = date.getMonth(); - function setMonth(m) { - var day = date.getDate(); - var max = date.getMonthDays(m); - if (day > max) { - date.setDate(max); - } - date.setMonth(m); - }; - switch (el.navtype) { - case 400: - Calendar.removeClass(el, "hilite"); - var text = Calendar._TT["ABOUT"]; - if (typeof text != "undefined") { - text += cal.showsTime ? Calendar._TT["ABOUT_TIME"] : ""; - } else { - // FIXME: this should be removed as soon as lang files get updated! - text = "Help and about box text is not translated into this language.\n" + - "If you know this language and you feel generous please update\n" + - "the corresponding file in \"lang\" subdir to match calendar-en.js\n" + - "and send it back to to get it into the distribution ;-)\n\n" + - "Thank you!\n" + - "http://dynarch.com/mishoo/calendar.epl\n"; - } - alert(text); - return; - case -2: - if (year > cal.minYear) { - date.setFullYear(year - 1); - } - break; - case -1: - if (mon > 0) { - setMonth(mon - 1); - } else if (year-- > cal.minYear) { - date.setFullYear(year); - setMonth(11); - } - break; - case 1: - if (mon < 11) { - setMonth(mon + 1); - } else if (year < cal.maxYear) { - date.setFullYear(year + 1); - setMonth(0); - } - break; - case 2: - if (year < cal.maxYear) { - date.setFullYear(year + 1); - } - break; - case 100: - cal.setFirstDayOfWeek(el.fdow); - return; - case 50: - var range = el._range; - var current = el.innerHTML; - for (var i = range.length; --i >= 0;) - if (range[i] == current) - break; - if (ev && ev.shiftKey) { - if (--i < 0) - i = range.length - 1; - } else if ( ++i >= range.length ) - i = 0; - var newval = range[i]; - el.innerHTML = newval; - cal.onUpdateTime(); - return; - case 0: - // TODAY will bring us here - if ((typeof cal.getDateStatus == "function") && - cal.getDateStatus(date, date.getFullYear(), date.getMonth(), date.getDate())) { - return false; - } - break; - } - if (!date.equalsTo(cal.date)) { - cal.setDate(date); - newdate = true; - } else if (el.navtype == 0) - newdate = closing = true; - } - if (newdate) { - ev && cal.callHandler(); - } - if (closing) { - Calendar.removeClass(el, "hilite"); - ev && cal.callCloseHandler(); - } -}; - -// END: CALENDAR STATIC FUNCTIONS - -// BEGIN: CALENDAR OBJECT FUNCTIONS - -/** - * This function creates the calendar inside the given parent. If _par is - * null than it creates a popup calendar inside the BODY element. If _par is - * an element, be it BODY, then it creates a non-popup calendar (still - * hidden). Some properties need to be set before calling this function. - */ -Calendar.prototype.create = function (_par) { - var parent = null; - if (! _par) { - // default parent is the document body, in which case we create - // a popup calendar. - parent = document.getElementsByTagName("body")[0]; - this.isPopup = true; - } else { - parent = _par; - this.isPopup = false; - } - this.date = this.dateStr ? new Date(this.dateStr) : new Date(); - - var table = Calendar.createElement("table"); - this.table = table; - table.cellSpacing = 0; - table.cellPadding = 0; - table.calendar = this; - Calendar.addEvent(table, "mousedown", Calendar.tableMouseDown); - - var div = Calendar.createElement("div"); - this.element = div; - div.className = "calendar"; - if (this.isPopup) { - div.style.position = "absolute"; - div.style.display = "none"; - } - div.appendChild(table); - - var thead = Calendar.createElement("thead", table); - var cell = null; - var row = null; - - var cal = this; - var hh = function (text, cs, navtype) { - cell = Calendar.createElement("td", row); - cell.colSpan = cs; - cell.className = "button"; - if (navtype != 0 && Math.abs(navtype) <= 2) - cell.className += " nav"; - Calendar._add_evs(cell); - cell.calendar = cal; - cell.navtype = navtype; - cell.innerHTML = "
    " + text + "
    "; - return cell; - }; - - row = Calendar.createElement("tr", thead); - var title_length = 6; - (this.isPopup) && --title_length; - (this.weekNumbers) && ++title_length; - - hh("?", 1, 400).ttip = Calendar._TT["INFO"]; - this.title = hh("", title_length, 300); - this.title.className = "title"; - if (this.isPopup) { - this.title.ttip = Calendar._TT["DRAG_TO_MOVE"]; - this.title.style.cursor = "move"; - hh("×", 1, 200).ttip = Calendar._TT["CLOSE"]; - } - - row = Calendar.createElement("tr", thead); - row.className = "headrow"; - - this._nav_py = hh("«", 1, -2); - this._nav_py.ttip = Calendar._TT["PREV_YEAR"]; - - this._nav_pm = hh("‹", 1, -1); - this._nav_pm.ttip = Calendar._TT["PREV_MONTH"]; - - this._nav_now = hh(Calendar._TT["TODAY"], this.weekNumbers ? 4 : 3, 0); - this._nav_now.ttip = Calendar._TT["GO_TODAY"]; - - this._nav_nm = hh("›", 1, 1); - this._nav_nm.ttip = Calendar._TT["NEXT_MONTH"]; - - this._nav_ny = hh("»", 1, 2); - this._nav_ny.ttip = Calendar._TT["NEXT_YEAR"]; - - // day names - row = Calendar.createElement("tr", thead); - row.className = "daynames"; - if (this.weekNumbers) { - cell = Calendar.createElement("td", row); - cell.className = "name wn"; - cell.innerHTML = Calendar._TT["WK"]; - } - for (var i = 7; i > 0; --i) { - cell = Calendar.createElement("td", row); - if (!i) { - cell.navtype = 100; - cell.calendar = this; - Calendar._add_evs(cell); - } - } - this.firstdayname = (this.weekNumbers) ? row.firstChild.nextSibling : row.firstChild; - this._displayWeekdays(); - - var tbody = Calendar.createElement("tbody", table); - this.tbody = tbody; - - for (i = 6; i > 0; --i) { - row = Calendar.createElement("tr", tbody); - if (this.weekNumbers) { - cell = Calendar.createElement("td", row); - } - for (var j = 7; j > 0; --j) { - cell = Calendar.createElement("td", row); - cell.calendar = this; - Calendar._add_evs(cell); - } - } - - if (this.showsTime) { - row = Calendar.createElement("tr", tbody); - row.className = "time"; - - cell = Calendar.createElement("td", row); - cell.className = "time"; - cell.colSpan = 2; - cell.innerHTML = Calendar._TT["TIME"] || " "; - - cell = Calendar.createElement("td", row); - cell.className = "time"; - cell.colSpan = this.weekNumbers ? 4 : 3; - - (function(){ - function makeTimePart(className, init, range_start, range_end) { - var part = Calendar.createElement("span", cell); - part.className = className; - part.innerHTML = init; - part.calendar = cal; - part.ttip = Calendar._TT["TIME_PART"]; - part.navtype = 50; - part._range = []; - if (typeof range_start != "number") - part._range = range_start; - else { - for (var i = range_start; i <= range_end; ++i) { - var txt; - if (i < 10 && range_end >= 10) txt = '0' + i; - else txt = '' + i; - part._range[part._range.length] = txt; - } - } - Calendar._add_evs(part); - return part; - }; - var hrs = cal.date.getHours(); - var mins = cal.date.getMinutes(); - var t12 = !cal.time24; - var pm = (hrs > 12); - if (t12 && pm) hrs -= 12; - var H = makeTimePart("hour", hrs, t12 ? 1 : 0, t12 ? 12 : 23); - var span = Calendar.createElement("span", cell); - span.innerHTML = ":"; - span.className = "colon"; - var M = makeTimePart("minute", mins, 0, 59); - var AP = null; - cell = Calendar.createElement("td", row); - cell.className = "time"; - cell.colSpan = 2; - if (t12) - AP = makeTimePart("ampm", pm ? "pm" : "am", ["am", "pm"]); - else - cell.innerHTML = " "; - - cal.onSetTime = function() { - var pm, hrs = this.date.getHours(), - mins = this.date.getMinutes(); - if (t12) { - pm = (hrs >= 12); - if (pm) hrs -= 12; - if (hrs == 0) hrs = 12; - AP.innerHTML = pm ? "pm" : "am"; - } - H.innerHTML = (hrs < 10) ? ("0" + hrs) : hrs; - M.innerHTML = (mins < 10) ? ("0" + mins) : mins; - }; - - cal.onUpdateTime = function() { - var date = this.date; - var h = parseInt(H.innerHTML, 10); - if (t12) { - if (/pm/i.test(AP.innerHTML) && h < 12) - h += 12; - else if (/am/i.test(AP.innerHTML) && h == 12) - h = 0; - } - var d = date.getDate(); - var m = date.getMonth(); - var y = date.getFullYear(); - date.setHours(h); - date.setMinutes(parseInt(M.innerHTML, 10)); - date.setFullYear(y); - date.setMonth(m); - date.setDate(d); - this.dateClicked = false; - this.callHandler(); - }; - })(); - } else { - this.onSetTime = this.onUpdateTime = function() {}; - } - - var tfoot = Calendar.createElement("tfoot", table); - - row = Calendar.createElement("tr", tfoot); - row.className = "footrow"; - - cell = hh(Calendar._TT["SEL_DATE"], this.weekNumbers ? 8 : 7, 300); - cell.className = "ttip"; - if (this.isPopup) { - cell.ttip = Calendar._TT["DRAG_TO_MOVE"]; - cell.style.cursor = "move"; - } - this.tooltips = cell; - - div = Calendar.createElement("div", this.element); - this.monthsCombo = div; - div.className = "combo"; - for (i = 0; i < Calendar._MN.length; ++i) { - var mn = Calendar.createElement("div"); - mn.className = Calendar.is_ie ? "label-IEfix" : "label"; - mn.month = i; - mn.innerHTML = Calendar._SMN[i]; - div.appendChild(mn); - } - - div = Calendar.createElement("div", this.element); - this.yearsCombo = div; - div.className = "combo"; - for (i = 12; i > 0; --i) { - var yr = Calendar.createElement("div"); - yr.className = Calendar.is_ie ? "label-IEfix" : "label"; - div.appendChild(yr); - } - - this._init(this.firstDayOfWeek, this.date); - parent.appendChild(this.element); -}; - -/** keyboard navigation, only for popup calendars */ -Calendar._keyEvent = function(ev) { - var cal = window._dynarch_popupCalendar; - if (!cal || cal.multiple) - return false; - (Calendar.is_ie) && (ev = window.event); - var act = (Calendar.is_ie || ev.type == "keypress"), - K = ev.keyCode; - if (ev.ctrlKey) { - switch (K) { - case 37: // KEY left - act && Calendar.cellClick(cal._nav_pm); - break; - case 38: // KEY up - act && Calendar.cellClick(cal._nav_py); - break; - case 39: // KEY right - act && Calendar.cellClick(cal._nav_nm); - break; - case 40: // KEY down - act && Calendar.cellClick(cal._nav_ny); - break; - default: - return false; - } - } else switch (K) { - case 32: // KEY space (now) - Calendar.cellClick(cal._nav_now); - break; - case 27: // KEY esc - act && cal.callCloseHandler(); - break; - case 37: // KEY left - case 38: // KEY up - case 39: // KEY right - case 40: // KEY down - if (act) { - var prev, x, y, ne, el, step; - prev = K == 37 || K == 38; - step = (K == 37 || K == 39) ? 1 : 7; - function setVars() { - el = cal.currentDateEl; - var p = el.pos; - x = p & 15; - y = p >> 4; - ne = cal.ar_days[y][x]; - };setVars(); - function prevMonth() { - var date = new Date(cal.date); - date.setDate(date.getDate() - step); - cal.setDate(date); - }; - function nextMonth() { - var date = new Date(cal.date); - date.setDate(date.getDate() + step); - cal.setDate(date); - }; - while (1) { - switch (K) { - case 37: // KEY left - if (--x >= 0) - ne = cal.ar_days[y][x]; - else { - x = 6; - K = 38; - continue; - } - break; - case 38: // KEY up - if (--y >= 0) - ne = cal.ar_days[y][x]; - else { - prevMonth(); - setVars(); - } - break; - case 39: // KEY right - if (++x < 7) - ne = cal.ar_days[y][x]; - else { - x = 0; - K = 40; - continue; - } - break; - case 40: // KEY down - if (++y < cal.ar_days.length) - ne = cal.ar_days[y][x]; - else { - nextMonth(); - setVars(); - } - break; - } - break; - } - if (ne) { - if (!ne.disabled) - Calendar.cellClick(ne); - else if (prev) - prevMonth(); - else - nextMonth(); - } - } - break; - case 13: // KEY enter - if (act) - Calendar.cellClick(cal.currentDateEl, ev); - break; - default: - return false; - } - return Calendar.stopEvent(ev); -}; - -/** - * (RE)Initializes the calendar to the given date and firstDayOfWeek - */ -Calendar.prototype._init = function (firstDayOfWeek, date) { - var today = new Date(), - TY = today.getFullYear(), - TM = today.getMonth(), - TD = today.getDate(); - this.table.style.visibility = "hidden"; - var year = date.getFullYear(); - if (year < this.minYear) { - year = this.minYear; - date.setFullYear(year); - } else if (year > this.maxYear) { - year = this.maxYear; - date.setFullYear(year); - } - this.firstDayOfWeek = firstDayOfWeek; - this.date = new Date(date); - var month = date.getMonth(); - var mday = date.getDate(); - var no_days = date.getMonthDays(); - - // calendar voodoo for computing the first day that would actually be - // displayed in the calendar, even if it's from the previous month. - // WARNING: this is magic. ;-) - date.setDate(1); - var day1 = (date.getDay() - this.firstDayOfWeek) % 7; - if (day1 < 0) - day1 += 7; - date.setDate(-day1); - date.setDate(date.getDate() + 1); - - var row = this.tbody.firstChild; - var MN = Calendar._SMN[month]; - var ar_days = this.ar_days = new Array(); - var weekend = Calendar._TT["WEEKEND"]; - var dates = this.multiple ? (this.datesCells = {}) : null; - for (var i = 0; i < 6; ++i, row = row.nextSibling) { - var cell = row.firstChild; - if (this.weekNumbers) { - cell.className = "day wn"; - cell.innerHTML = date.getWeekNumber(); - cell = cell.nextSibling; - } - row.className = "daysrow"; - var hasdays = false, iday, dpos = ar_days[i] = []; - for (var j = 0; j < 7; ++j, cell = cell.nextSibling, date.setDate(iday + 1)) { - iday = date.getDate(); - var wday = date.getDay(); - cell.className = "day"; - cell.pos = i << 4 | j; - dpos[j] = cell; - var current_month = (date.getMonth() == month); - if (!current_month) { - if (this.showsOtherMonths) { - cell.className += " othermonth"; - cell.otherMonth = true; - } else { - cell.className = "emptycell"; - cell.innerHTML = " "; - cell.disabled = true; - continue; - } - } else { - cell.otherMonth = false; - hasdays = true; - } - cell.disabled = false; - cell.innerHTML = this.getDateText ? this.getDateText(date, iday) : iday; - if (dates) - dates[date.print("%Y%m%d")] = cell; - if (this.getDateStatus) { - var status = this.getDateStatus(date, year, month, iday); - if (this.getDateToolTip) { - var toolTip = this.getDateToolTip(date, year, month, iday); - if (toolTip) - cell.title = toolTip; - } - if (status === true) { - cell.className += " disabled"; - cell.disabled = true; - } else { - if (/disabled/i.test(status)) - cell.disabled = true; - cell.className += " " + status; - } - } - if (!cell.disabled) { - cell.caldate = new Date(date); - cell.ttip = "_"; - if (!this.multiple && current_month - && iday == mday && this.hiliteToday) { - cell.className += " selected"; - this.currentDateEl = cell; - } - if (date.getFullYear() == TY && - date.getMonth() == TM && - iday == TD) { - cell.className += " today"; - cell.ttip += Calendar._TT["PART_TODAY"]; - } - if (weekend.indexOf(wday.toString()) != -1) - cell.className += cell.otherMonth ? " oweekend" : " weekend"; - } - } - if (!(hasdays || this.showsOtherMonths)) - row.className = "emptyrow"; - } - this.title.innerHTML = Calendar._MN[month] + ", " + year; - this.onSetTime(); - this.table.style.visibility = "visible"; - this._initMultipleDates(); - // PROFILE - // this.tooltips.innerHTML = "Generated in " + ((new Date()) - today) + " ms"; -}; - -Calendar.prototype._initMultipleDates = function() { - if (this.multiple) { - for (var i in this.multiple) { - var cell = this.datesCells[i]; - var d = this.multiple[i]; - if (!d) - continue; - if (cell) - cell.className += " selected"; - } - } -}; - -Calendar.prototype._toggleMultipleDate = function(date) { - if (this.multiple) { - var ds = date.print("%Y%m%d"); - var cell = this.datesCells[ds]; - if (cell) { - var d = this.multiple[ds]; - if (!d) { - Calendar.addClass(cell, "selected"); - this.multiple[ds] = date; - } else { - Calendar.removeClass(cell, "selected"); - delete this.multiple[ds]; - } - } - } -}; - -Calendar.prototype.setDateToolTipHandler = function (unaryFunction) { - this.getDateToolTip = unaryFunction; -}; - -/** - * Calls _init function above for going to a certain date (but only if the - * date is different than the currently selected one). - */ -Calendar.prototype.setDate = function (date) { - if (!date.equalsTo(this.date)) { - this._init(this.firstDayOfWeek, date); - } -}; - -/** - * Refreshes the calendar. Useful if the "disabledHandler" function is - * dynamic, meaning that the list of disabled date can change at runtime. - * Just * call this function if you think that the list of disabled dates - * should * change. - */ -Calendar.prototype.refresh = function () { - this._init(this.firstDayOfWeek, this.date); -}; - -/** Modifies the "firstDayOfWeek" parameter (pass 0 for Synday, 1 for Monday, etc.). */ -Calendar.prototype.setFirstDayOfWeek = function (firstDayOfWeek) { - this._init(firstDayOfWeek, this.date); - this._displayWeekdays(); -}; - -/** - * Allows customization of what dates are enabled. The "unaryFunction" - * parameter must be a function object that receives the date (as a JS Date - * object) and returns a boolean value. If the returned value is true then - * the passed date will be marked as disabled. - */ -Calendar.prototype.setDateStatusHandler = Calendar.prototype.setDisabledHandler = function (unaryFunction) { - this.getDateStatus = unaryFunction; -}; - -/** Customization of allowed year range for the calendar. */ -Calendar.prototype.setRange = function (a, z) { - this.minYear = a; - this.maxYear = z; -}; - -/** Calls the first user handler (selectedHandler). */ -Calendar.prototype.callHandler = function () { - if (this.onSelected) { - this.onSelected(this, this.date.print(this.dateFormat)); - } -}; - -/** Calls the second user handler (closeHandler). */ -Calendar.prototype.callCloseHandler = function () { - if (this.onClose) { - this.onClose(this); - } - this.hideShowCovered(); -}; - -/** Removes the calendar object from the DOM tree and destroys it. */ -Calendar.prototype.destroy = function () { - var el = this.element.parentNode; - el.removeChild(this.element); - Calendar._C = null; - window._dynarch_popupCalendar = null; -}; - -/** - * Moves the calendar element to a different section in the DOM tree (changes - * its parent). - */ -Calendar.prototype.reparent = function (new_parent) { - var el = this.element; - el.parentNode.removeChild(el); - new_parent.appendChild(el); -}; - -// This gets called when the user presses a mouse button anywhere in the -// document, if the calendar is shown. If the click was outside the open -// calendar this function closes it. -Calendar._checkCalendar = function(ev) { - var calendar = window._dynarch_popupCalendar; - if (!calendar) { - return false; - } - var el = Calendar.is_ie ? Calendar.getElement(ev) : Calendar.getTargetElement(ev); - for (; el != null && el != calendar.element; el = el.parentNode); - if (el == null) { - // calls closeHandler which should hide the calendar. - window._dynarch_popupCalendar.callCloseHandler(); - return Calendar.stopEvent(ev); - } -}; - -/** Shows the calendar. */ -Calendar.prototype.show = function () { - var rows = this.table.getElementsByTagName("tr"); - for (var i = rows.length; i > 0;) { - var row = rows[--i]; - Calendar.removeClass(row, "rowhilite"); - var cells = row.getElementsByTagName("td"); - for (var j = cells.length; j > 0;) { - var cell = cells[--j]; - Calendar.removeClass(cell, "hilite"); - Calendar.removeClass(cell, "active"); - } - } - this.element.style.display = "block"; - this.hidden = false; - if (this.isPopup) { - window._dynarch_popupCalendar = this; - Calendar.addEvent(document, "keydown", Calendar._keyEvent); - Calendar.addEvent(document, "keypress", Calendar._keyEvent); - Calendar.addEvent(document, "mousedown", Calendar._checkCalendar); - } - this.hideShowCovered(); -}; - -/** - * Hides the calendar. Also removes any "hilite" from the class of any TD - * element. - */ -Calendar.prototype.hide = function () { - if (this.isPopup) { - Calendar.removeEvent(document, "keydown", Calendar._keyEvent); - Calendar.removeEvent(document, "keypress", Calendar._keyEvent); - Calendar.removeEvent(document, "mousedown", Calendar._checkCalendar); - } - this.element.style.display = "none"; - this.hidden = true; - this.hideShowCovered(); -}; - -/** - * Shows the calendar at a given absolute position (beware that, depending on - * the calendar element style -- position property -- this might be relative - * to the parent's containing rectangle). - */ -Calendar.prototype.showAt = function (x, y) { - var s = this.element.style; - s.left = x + "px"; - s.top = y + "px"; - this.show(); -}; - -/** Shows the calendar near a given element. */ -Calendar.prototype.showAtElement = function (el, opts) { - var self = this; - var p = Calendar.getAbsolutePos(el); - if (!opts || typeof opts != "string") { - this.showAt(p.x, p.y + el.offsetHeight); - return true; - } - function fixPosition(box) { - if (box.x < 0) - box.x = 0; - if (box.y < 0) - box.y = 0; - var cp = document.createElement("div"); - var s = cp.style; - s.position = "absolute"; - s.right = s.bottom = s.width = s.height = "0px"; - document.body.appendChild(cp); - var br = Calendar.getAbsolutePos(cp); - document.body.removeChild(cp); - if (Calendar.is_ie) { - br.y += document.body.scrollTop; - br.x += document.body.scrollLeft; - } else { - br.y += window.scrollY; - br.x += window.scrollX; - } - var tmp = box.x + box.width - br.x; - if (tmp > 0) box.x -= tmp; - tmp = box.y + box.height - br.y; - if (tmp > 0) box.y -= tmp; - }; - this.element.style.display = "block"; - Calendar.continuation_for_the_fucking_khtml_browser = function() { - var w = self.element.offsetWidth; - var h = self.element.offsetHeight; - self.element.style.display = "none"; - var valign = opts.substr(0, 1); - var halign = "l"; - if (opts.length > 1) { - halign = opts.substr(1, 1); - } - // vertical alignment - switch (valign) { - case "T": p.y -= h; break; - case "B": p.y += el.offsetHeight; break; - case "C": p.y += (el.offsetHeight - h) / 2; break; - case "t": p.y += el.offsetHeight - h; break; - case "b": break; // already there - } - // horizontal alignment - switch (halign) { - case "L": p.x -= w; break; - case "R": p.x += el.offsetWidth; break; - case "C": p.x += (el.offsetWidth - w) / 2; break; - case "l": p.x += el.offsetWidth - w; break; - case "r": break; // already there - } - p.width = w; - p.height = h + 40; - self.monthsCombo.style.display = "none"; - fixPosition(p); - self.showAt(p.x, p.y); - }; - if (Calendar.is_khtml) - setTimeout("Calendar.continuation_for_the_fucking_khtml_browser()", 10); - else - Calendar.continuation_for_the_fucking_khtml_browser(); -}; - -/** Customizes the date format. */ -Calendar.prototype.setDateFormat = function (str) { - this.dateFormat = str; -}; - -/** Customizes the tooltip date format. */ -Calendar.prototype.setTtDateFormat = function (str) { - this.ttDateFormat = str; -}; - -/** - * Tries to identify the date represented in a string. If successful it also - * calls this.setDate which moves the calendar to the given date. - */ -Calendar.prototype.parseDate = function(str, fmt) { - if (!fmt) - fmt = this.dateFormat; - this.setDate(Date.parseDate(str, fmt)); -}; - -Calendar.prototype.hideShowCovered = function () { - if (!Calendar.is_ie && !Calendar.is_opera) - return; - function getVisib(obj){ - var value = obj.style.visibility; - if (!value) { - if (document.defaultView && typeof (document.defaultView.getComputedStyle) == "function") { // Gecko, W3C - if (!Calendar.is_khtml) - value = document.defaultView. - getComputedStyle(obj, "").getPropertyValue("visibility"); - else - value = ''; - } else if (obj.currentStyle) { // IE - value = obj.currentStyle.visibility; - } else - value = ''; - } - return value; - }; - - var tags = new Array("applet", "iframe", "select"); - var el = this.element; - - var p = Calendar.getAbsolutePos(el); - var EX1 = p.x; - var EX2 = el.offsetWidth + EX1; - var EY1 = p.y; - var EY2 = el.offsetHeight + EY1; - - for (var k = tags.length; k > 0; ) { - var ar = document.getElementsByTagName(tags[--k]); - var cc = null; - - for (var i = ar.length; i > 0;) { - cc = ar[--i]; - - p = Calendar.getAbsolutePos(cc); - var CX1 = p.x; - var CX2 = cc.offsetWidth + CX1; - var CY1 = p.y; - var CY2 = cc.offsetHeight + CY1; - - if (this.hidden || (CX1 > EX2) || (CX2 < EX1) || (CY1 > EY2) || (CY2 < EY1)) { - if (!cc.__msh_save_visibility) { - cc.__msh_save_visibility = getVisib(cc); - } - cc.style.visibility = cc.__msh_save_visibility; - } else { - if (!cc.__msh_save_visibility) { - cc.__msh_save_visibility = getVisib(cc); - } - cc.style.visibility = "hidden"; - } - } - } -}; - -/** Internal function; it displays the bar with the names of the weekday. */ -Calendar.prototype._displayWeekdays = function () { - var fdow = this.firstDayOfWeek; - var cell = this.firstdayname; - var weekend = Calendar._TT["WEEKEND"]; - for (var i = 0; i < 7; ++i) { - cell.className = "day name"; - var realday = (i + fdow) % 7; - if (i) { - cell.ttip = Calendar._TT["DAY_FIRST"].replace("%s", Calendar._DN[realday]); - cell.navtype = 100; - cell.calendar = this; - cell.fdow = realday; - Calendar._add_evs(cell); - } - if (weekend.indexOf(realday.toString()) != -1) { - Calendar.addClass(cell, "weekend"); - } - cell.innerHTML = Calendar._SDN[(i + fdow) % 7]; - cell = cell.nextSibling; - } -}; - -/** Internal function. Hides all combo boxes that might be displayed. */ -Calendar.prototype._hideCombos = function () { - this.monthsCombo.style.display = "none"; - this.yearsCombo.style.display = "none"; -}; - -/** Internal function. Starts dragging the element. */ -Calendar.prototype._dragStart = function (ev) { - if (this.dragging) { - return; - } - this.dragging = true; - var posX; - var posY; - if (Calendar.is_ie) { - posY = window.event.clientY + document.body.scrollTop; - posX = window.event.clientX + document.body.scrollLeft; - } else { - posY = ev.clientY + window.scrollY; - posX = ev.clientX + window.scrollX; - } - var st = this.element.style; - this.xOffs = posX - parseInt(st.left); - this.yOffs = posY - parseInt(st.top); - with (Calendar) { - addEvent(document, "mousemove", calDragIt); - addEvent(document, "mouseup", calDragEnd); - } -}; - -// BEGIN: DATE OBJECT PATCHES - -/** Adds the number of days array to the Date object. */ -Date._MD = new Array(31,28,31,30,31,30,31,31,30,31,30,31); - -/** Constants used for time computations */ -Date.SECOND = 1000 /* milliseconds */; -Date.MINUTE = 60 * Date.SECOND; -Date.HOUR = 60 * Date.MINUTE; -Date.DAY = 24 * Date.HOUR; -Date.WEEK = 7 * Date.DAY; - -Date.parseDate = function(str, fmt) { - var today = new Date(); - var y = 0; - var m = -1; - var d = 0; - var a = str.split(/\W+/); - var b = fmt.match(/%./g); - var i = 0, j = 0; - var hr = 0; - var min = 0; - for (i = 0; i < a.length; ++i) { - if (!a[i]) - continue; - switch (b[i]) { - case "%d": - case "%e": - d = parseInt(a[i], 10); - break; - - case "%m": - m = parseInt(a[i], 10) - 1; - break; - - case "%Y": - case "%y": - y = parseInt(a[i], 10); - (y < 100) && (y += (y > 29) ? 1900 : 2000); - break; - - case "%b": - case "%B": - for (j = 0; j < 12; ++j) { - if (Calendar._MN[j].substr(0, a[i].length).toLowerCase() == a[i].toLowerCase()) { m = j; break; } - } - break; - - case "%H": - case "%I": - case "%k": - case "%l": - hr = parseInt(a[i], 10); - break; - - case "%P": - case "%p": - if (/pm/i.test(a[i]) && hr < 12) - hr += 12; - else if (/am/i.test(a[i]) && hr >= 12) - hr -= 12; - break; - - case "%M": - min = parseInt(a[i], 10); - break; - } - } - if (isNaN(y)) y = today.getFullYear(); - if (isNaN(m)) m = today.getMonth(); - if (isNaN(d)) d = today.getDate(); - if (isNaN(hr)) hr = today.getHours(); - if (isNaN(min)) min = today.getMinutes(); - if (y != 0 && m != -1 && d != 0) - return new Date(y, m, d, hr, min, 0); - y = 0; m = -1; d = 0; - for (i = 0; i < a.length; ++i) { - if (a[i].search(/[a-zA-Z]+/) != -1) { - var t = -1; - for (j = 0; j < 12; ++j) { - if (Calendar._MN[j].substr(0, a[i].length).toLowerCase() == a[i].toLowerCase()) { t = j; break; } - } - if (t != -1) { - if (m != -1) { - d = m+1; - } - m = t; - } - } else if (parseInt(a[i], 10) <= 12 && m == -1) { - m = a[i]-1; - } else if (parseInt(a[i], 10) > 31 && y == 0) { - y = parseInt(a[i], 10); - (y < 100) && (y += (y > 29) ? 1900 : 2000); - } else if (d == 0) { - d = a[i]; - } - } - if (y == 0) - y = today.getFullYear(); - if (m != -1 && d != 0) - return new Date(y, m, d, hr, min, 0); - return today; -}; - -/** Returns the number of days in the current month */ -Date.prototype.getMonthDays = function(month) { - var year = this.getFullYear(); - if (typeof month == "undefined") { - month = this.getMonth(); - } - if (((0 == (year%4)) && ( (0 != (year%100)) || (0 == (year%400)))) && month == 1) { - return 29; - } else { - return Date._MD[month]; - } -}; - -/** Returns the number of day in the year. */ -Date.prototype.getDayOfYear = function() { - var now = new Date(this.getFullYear(), this.getMonth(), this.getDate(), 0, 0, 0); - var then = new Date(this.getFullYear(), 0, 0, 0, 0, 0); - var time = now - then; - return Math.floor(time / Date.DAY); -}; - -/** Returns the number of the week in year, as defined in ISO 8601. */ -Date.prototype.getWeekNumber = function() { - var d = new Date(this.getFullYear(), this.getMonth(), this.getDate(), 0, 0, 0); - var DoW = d.getDay(); - d.setDate(d.getDate() - (DoW + 6) % 7 + 3); // Nearest Thu - var ms = d.valueOf(); // GMT - d.setMonth(0); - d.setDate(4); // Thu in Week 1 - return Math.round((ms - d.valueOf()) / (7 * 864e5)) + 1; -}; - -/** Checks date and time equality */ -Date.prototype.equalsTo = function(date) { - return ((this.getFullYear() == date.getFullYear()) && - (this.getMonth() == date.getMonth()) && - (this.getDate() == date.getDate()) && - (this.getHours() == date.getHours()) && - (this.getMinutes() == date.getMinutes())); -}; - -/** Set only the year, month, date parts (keep existing time) */ -Date.prototype.setDateOnly = function(date) { - var tmp = new Date(date); - this.setDate(1); - this.setFullYear(tmp.getFullYear()); - this.setMonth(tmp.getMonth()); - this.setDate(tmp.getDate()); -}; - -/** Prints the date in a string according to the given format. */ -Date.prototype.print = function (str) { - var m = this.getMonth(); - var d = this.getDate(); - var y = this.getFullYear(); - var wn = this.getWeekNumber(); - var w = this.getDay(); - var s = {}; - var hr = this.getHours(); - var pm = (hr >= 12); - var ir = (pm) ? (hr - 12) : hr; - var dy = this.getDayOfYear(); - if (ir == 0) - ir = 12; - var min = this.getMinutes(); - var sec = this.getSeconds(); - s["%a"] = Calendar._SDN[w]; // abbreviated weekday name [FIXME: I18N] - s["%A"] = Calendar._DN[w]; // full weekday name - s["%b"] = Calendar._SMN[m]; // abbreviated month name [FIXME: I18N] - s["%B"] = Calendar._MN[m]; // full month name - // FIXME: %c : preferred date and time representation for the current locale - s["%C"] = 1 + Math.floor(y / 100); // the century number - s["%d"] = (d < 10) ? ("0" + d) : d; // the day of the month (range 01 to 31) - s["%e"] = d; // the day of the month (range 1 to 31) - // FIXME: %D : american date style: %m/%d/%y - // FIXME: %E, %F, %G, %g, %h (man strftime) - s["%H"] = (hr < 10) ? ("0" + hr) : hr; // hour, range 00 to 23 (24h format) - s["%I"] = (ir < 10) ? ("0" + ir) : ir; // hour, range 01 to 12 (12h format) - s["%j"] = (dy < 100) ? ((dy < 10) ? ("00" + dy) : ("0" + dy)) : dy; // day of the year (range 001 to 366) - s["%k"] = hr; // hour, range 0 to 23 (24h format) - s["%l"] = ir; // hour, range 1 to 12 (12h format) - s["%m"] = (m < 9) ? ("0" + (1+m)) : (1+m); // month, range 01 to 12 - s["%M"] = (min < 10) ? ("0" + min) : min; // minute, range 00 to 59 - s["%n"] = "\n"; // a newline character - s["%p"] = pm ? "PM" : "AM"; - s["%P"] = pm ? "pm" : "am"; - // FIXME: %r : the time in am/pm notation %I:%M:%S %p - // FIXME: %R : the time in 24-hour notation %H:%M - s["%s"] = Math.floor(this.getTime() / 1000); - s["%S"] = (sec < 10) ? ("0" + sec) : sec; // seconds, range 00 to 59 - s["%t"] = "\t"; // a tab character - // FIXME: %T : the time in 24-hour notation (%H:%M:%S) - s["%U"] = s["%W"] = s["%V"] = (wn < 10) ? ("0" + wn) : wn; - s["%u"] = w + 1; // the day of the week (range 1 to 7, 1 = MON) - s["%w"] = w; // the day of the week (range 0 to 6, 0 = SUN) - // FIXME: %x : preferred date representation for the current locale without the time - // FIXME: %X : preferred time representation for the current locale without the date - s["%y"] = ('' + y).substr(2, 2); // year without the century (range 00 to 99) - s["%Y"] = y; // year with the century - s["%%"] = "%"; // a literal '%' character - - var re = /%./g; - if (!Calendar.is_ie5 && !Calendar.is_khtml) - return str.replace(re, function (par) { return s[par] || par; }); - - var a = str.match(re); - for (var i = 0; i < a.length; i++) { - var tmp = s[a[i]]; - if (tmp) { - re = new RegExp(a[i], 'g'); - str = str.replace(re, tmp); - } - } - - return str; -}; - -Date.prototype.__msh_oldSetFullYear = Date.prototype.setFullYear; -Date.prototype.setFullYear = function(y) { - var d = new Date(this); - d.__msh_oldSetFullYear(y); - if (d.getMonth() != this.getMonth()) - this.setDate(28); - this.__msh_oldSetFullYear(y); -}; - -// END: DATE OBJECT PATCHES - - -// global object that remembers the calendar -window._dynarch_popupCalendar = null; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar_stripped.js b/extra/webapps/article-manager/resources/jscalendar-1.0/calendar_stripped.js deleted file mode 100644 index 4fe03f1ea9..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/calendar_stripped.js +++ /dev/null @@ -1,14 +0,0 @@ -/* Copyright Mihai Bazon, 2002-2005 | www.bazon.net/mishoo - * ----------------------------------------------------------- - * - * The DHTML Calendar, version 1.0 "It is happening again" - * - * Details and latest version at: - * www.dynarch.com/projects/calendar - * - * This script is developed by Dynarch.com. Visit us at www.dynarch.com. - * - * This script is distributed under the GNU Lesser General Public License. - * Read the entire license text here: http://www.gnu.org/licenses/lgpl.html - */ - Calendar=function(firstDayOfWeek,dateStr,onSelected,onClose){this.activeDiv=null;this.currentDateEl=null;this.getDateStatus=null;this.getDateToolTip=null;this.getDateText=null;this.timeout=null;this.onSelected=onSelected||null;this.onClose=onClose||null;this.dragging=false;this.hidden=false;this.minYear=1970;this.maxYear=2050;this.dateFormat=Calendar._TT["DEF_DATE_FORMAT"];this.ttDateFormat=Calendar._TT["TT_DATE_FORMAT"];this.isPopup=true;this.weekNumbers=true;this.firstDayOfWeek=typeof firstDayOfWeek=="number"?firstDayOfWeek:Calendar._FD;this.showsOtherMonths=false;this.dateStr=dateStr;this.ar_days=null;this.showsTime=false;this.time24=true;this.yearStep=2;this.hiliteToday=true;this.multiple=null;this.table=null;this.element=null;this.tbody=null;this.firstdayname=null;this.monthsCombo=null;this.yearsCombo=null;this.hilitedMonth=null;this.activeMonth=null;this.hilitedYear=null;this.activeYear=null;this.dateClicked=false;if(typeof Calendar._SDN=="undefined"){if(typeof Calendar._SDN_len=="undefined")Calendar._SDN_len=3;var ar=new Array();for(var i=8;i>0;){ar[--i]=Calendar._DN[i].substr(0,Calendar._SDN_len);}Calendar._SDN=ar;if(typeof Calendar._SMN_len=="undefined")Calendar._SMN_len=3;ar=new Array();for(var i=12;i>0;){ar[--i]=Calendar._MN[i].substr(0,Calendar._SMN_len);}Calendar._SMN=ar;}};Calendar._C=null;Calendar.is_ie=(/msie/i.test(navigator.userAgent)&&!/opera/i.test(navigator.userAgent));Calendar.is_ie5=(Calendar.is_ie&&/msie 5\.0/i.test(navigator.userAgent));Calendar.is_opera=/opera/i.test(navigator.userAgent);Calendar.is_khtml=/Konqueror|Safari|KHTML/i.test(navigator.userAgent);Calendar.getAbsolutePos=function(el){var SL=0,ST=0;var is_div=/^div$/i.test(el.tagName);if(is_div&&el.scrollLeft)SL=el.scrollLeft;if(is_div&&el.scrollTop)ST=el.scrollTop;var r={x:el.offsetLeft-SL,y:el.offsetTop-ST};if(el.offsetParent){var tmp=this.getAbsolutePos(el.offsetParent);r.x+=tmp.x;r.y+=tmp.y;}return r;};Calendar.isRelated=function(el,evt){var related=evt.relatedTarget;if(!related){var type=evt.type;if(type=="mouseover"){related=evt.fromElement;}else if(type=="mouseout"){related=evt.toElement;}}while(related){if(related==el){return true;}related=related.parentNode;}return false;};Calendar.removeClass=function(el,className){if(!(el&&el.className)){return;}var cls=el.className.split(" ");var ar=new Array();for(var i=cls.length;i>0;){if(cls[--i]!=className){ar[ar.length]=cls[i];}}el.className=ar.join(" ");};Calendar.addClass=function(el,className){Calendar.removeClass(el,className);el.className+=" "+className;};Calendar.getElement=function(ev){var f=Calendar.is_ie?window.event.srcElement:ev.currentTarget;while(f.nodeType!=1||/^div$/i.test(f.tagName))f=f.parentNode;return f;};Calendar.getTargetElement=function(ev){var f=Calendar.is_ie?window.event.srcElement:ev.target;while(f.nodeType!=1)f=f.parentNode;return f;};Calendar.stopEvent=function(ev){ev||(ev=window.event);if(Calendar.is_ie){ev.cancelBubble=true;ev.returnValue=false;}else{ev.preventDefault();ev.stopPropagation();}return false;};Calendar.addEvent=function(el,evname,func){if(el.attachEvent){el.attachEvent("on"+evname,func);}else if(el.addEventListener){el.addEventListener(evname,func,true);}else{el["on"+evname]=func;}};Calendar.removeEvent=function(el,evname,func){if(el.detachEvent){el.detachEvent("on"+evname,func);}else if(el.removeEventListener){el.removeEventListener(evname,func,true);}else{el["on"+evname]=null;}};Calendar.createElement=function(type,parent){var el=null;if(document.createElementNS){el=document.createElementNS("http://www.w3.org/1999/xhtml",type);}else{el=document.createElement(type);}if(typeof parent!="undefined"){parent.appendChild(el);}return el;};Calendar._add_evs=function(el){with(Calendar){addEvent(el,"mouseover",dayMouseOver);addEvent(el,"mousedown",dayMouseDown);addEvent(el,"mouseout",dayMouseOut);if(is_ie){addEvent(el,"dblclick",dayMouseDblClick);el.setAttribute("unselectable",true);}}};Calendar.findMonth=function(el){if(typeof el.month!="undefined"){return el;}else if(typeof el.parentNode.month!="undefined"){return el.parentNode;}return null;};Calendar.findYear=function(el){if(typeof el.year!="undefined"){return el;}else if(typeof el.parentNode.year!="undefined"){return el.parentNode;}return null;};Calendar.showMonthsCombo=function(){var cal=Calendar._C;if(!cal){return false;}var cal=cal;var cd=cal.activeDiv;var mc=cal.monthsCombo;if(cal.hilitedMonth){Calendar.removeClass(cal.hilitedMonth,"hilite");}if(cal.activeMonth){Calendar.removeClass(cal.activeMonth,"active");}var mon=cal.monthsCombo.getElementsByTagName("div")[cal.date.getMonth()];Calendar.addClass(mon,"active");cal.activeMonth=mon;var s=mc.style;s.display="block";if(cd.navtype<0)s.left=cd.offsetLeft+"px";else{var mcw=mc.offsetWidth;if(typeof mcw=="undefined")mcw=50;s.left=(cd.offsetLeft+cd.offsetWidth-mcw)+"px";}s.top=(cd.offsetTop+cd.offsetHeight)+"px";};Calendar.showYearsCombo=function(fwd){var cal=Calendar._C;if(!cal){return false;}var cal=cal;var cd=cal.activeDiv;var yc=cal.yearsCombo;if(cal.hilitedYear){Calendar.removeClass(cal.hilitedYear,"hilite");}if(cal.activeYear){Calendar.removeClass(cal.activeYear,"active");}cal.activeYear=null;var Y=cal.date.getFullYear()+(fwd?1:-1);var yr=yc.firstChild;var show=false;for(var i=12;i>0;--i){if(Y>=cal.minYear&&Y<=cal.maxYear){yr.innerHTML=Y;yr.year=Y;yr.style.display="block";show=true;}else{yr.style.display="none";}yr=yr.nextSibling;Y+=fwd?cal.yearStep:-cal.yearStep;}if(show){var s=yc.style;s.display="block";if(cd.navtype<0)s.left=cd.offsetLeft+"px";else{var ycw=yc.offsetWidth;if(typeof ycw=="undefined")ycw=50;s.left=(cd.offsetLeft+cd.offsetWidth-ycw)+"px";}s.top=(cd.offsetTop+cd.offsetHeight)+"px";}};Calendar.tableMouseUp=function(ev){var cal=Calendar._C;if(!cal){return false;}if(cal.timeout){clearTimeout(cal.timeout);}var el=cal.activeDiv;if(!el){return false;}var target=Calendar.getTargetElement(ev);ev||(ev=window.event);Calendar.removeClass(el,"active");if(target==el||target.parentNode==el){Calendar.cellClick(el,ev);}var mon=Calendar.findMonth(target);var date=null;if(mon){date=new Date(cal.date);if(mon.month!=date.getMonth()){date.setMonth(mon.month);cal.setDate(date);cal.dateClicked=false;cal.callHandler();}}else{var year=Calendar.findYear(target);if(year){date=new Date(cal.date);if(year.year!=date.getFullYear()){date.setFullYear(year.year);cal.setDate(date);cal.dateClicked=false;cal.callHandler();}}}with(Calendar){removeEvent(document,"mouseup",tableMouseUp);removeEvent(document,"mouseover",tableMouseOver);removeEvent(document,"mousemove",tableMouseOver);cal._hideCombos();_C=null;return stopEvent(ev);}};Calendar.tableMouseOver=function(ev){var cal=Calendar._C;if(!cal){return;}var el=cal.activeDiv;var target=Calendar.getTargetElement(ev);if(target==el||target.parentNode==el){Calendar.addClass(el,"hilite active");Calendar.addClass(el.parentNode,"rowhilite");}else{if(typeof el.navtype=="undefined"||(el.navtype!=50&&(el.navtype==0||Math.abs(el.navtype)>2)))Calendar.removeClass(el,"active");Calendar.removeClass(el,"hilite");Calendar.removeClass(el.parentNode,"rowhilite");}ev||(ev=window.event);if(el.navtype==50&&target!=el){var pos=Calendar.getAbsolutePos(el);var w=el.offsetWidth;var x=ev.clientX;var dx;var decrease=true;if(x>pos.x+w){dx=x-pos.x-w;decrease=false;}else dx=pos.x-x;if(dx<0)dx=0;var range=el._range;var current=el._current;var count=Math.floor(dx/10)%range.length;for(var i=range.length;--i>=0;)if(range[i]==current)break;while(count-->0)if(decrease){if(--i<0)i=range.length-1;}else if(++i>=range.length)i=0;var newval=range[i];el.innerHTML=newval;cal.onUpdateTime();}var mon=Calendar.findMonth(target);if(mon){if(mon.month!=cal.date.getMonth()){if(cal.hilitedMonth){Calendar.removeClass(cal.hilitedMonth,"hilite");}Calendar.addClass(mon,"hilite");cal.hilitedMonth=mon;}else if(cal.hilitedMonth){Calendar.removeClass(cal.hilitedMonth,"hilite");}}else{if(cal.hilitedMonth){Calendar.removeClass(cal.hilitedMonth,"hilite");}var year=Calendar.findYear(target);if(year){if(year.year!=cal.date.getFullYear()){if(cal.hilitedYear){Calendar.removeClass(cal.hilitedYear,"hilite");}Calendar.addClass(year,"hilite");cal.hilitedYear=year;}else if(cal.hilitedYear){Calendar.removeClass(cal.hilitedYear,"hilite");}}else if(cal.hilitedYear){Calendar.removeClass(cal.hilitedYear,"hilite");}}return Calendar.stopEvent(ev);};Calendar.tableMouseDown=function(ev){if(Calendar.getTargetElement(ev)==Calendar.getElement(ev)){return Calendar.stopEvent(ev);}};Calendar.calDragIt=function(ev){var cal=Calendar._C;if(!(cal&&cal.dragging)){return false;}var posX;var posY;if(Calendar.is_ie){posY=window.event.clientY+document.body.scrollTop;posX=window.event.clientX+document.body.scrollLeft;}else{posX=ev.pageX;posY=ev.pageY;}cal.hideShowCovered();var st=cal.element.style;st.left=(posX-cal.xOffs)+"px";st.top=(posY-cal.yOffs)+"px";return Calendar.stopEvent(ev);};Calendar.calDragEnd=function(ev){var cal=Calendar._C;if(!cal){return false;}cal.dragging=false;with(Calendar){removeEvent(document,"mousemove",calDragIt);removeEvent(document,"mouseup",calDragEnd);tableMouseUp(ev);}cal.hideShowCovered();};Calendar.dayMouseDown=function(ev){var el=Calendar.getElement(ev);if(el.disabled){return false;}var cal=el.calendar;cal.activeDiv=el;Calendar._C=cal;if(el.navtype!=300)with(Calendar){if(el.navtype==50){el._current=el.innerHTML;addEvent(document,"mousemove",tableMouseOver);}else addEvent(document,Calendar.is_ie5?"mousemove":"mouseover",tableMouseOver);addClass(el,"hilite active");addEvent(document,"mouseup",tableMouseUp);}else if(cal.isPopup){cal._dragStart(ev);}if(el.navtype==-1||el.navtype==1){if(cal.timeout)clearTimeout(cal.timeout);cal.timeout=setTimeout("Calendar.showMonthsCombo()",250);}else if(el.navtype==-2||el.navtype==2){if(cal.timeout)clearTimeout(cal.timeout);cal.timeout=setTimeout((el.navtype>0)?"Calendar.showYearsCombo(true)":"Calendar.showYearsCombo(false)",250);}else{cal.timeout=null;}return Calendar.stopEvent(ev);};Calendar.dayMouseDblClick=function(ev){Calendar.cellClick(Calendar.getElement(ev),ev||window.event);if(Calendar.is_ie){document.selection.empty();}};Calendar.dayMouseOver=function(ev){var el=Calendar.getElement(ev);if(Calendar.isRelated(el,ev)||Calendar._C||el.disabled){return false;}if(el.ttip){if(el.ttip.substr(0,1)=="_"){el.ttip=el.caldate.print(el.calendar.ttDateFormat)+el.ttip.substr(1);}el.calendar.tooltips.innerHTML=el.ttip;}if(el.navtype!=300){Calendar.addClass(el,"hilite");if(el.caldate){Calendar.addClass(el.parentNode,"rowhilite");}}return Calendar.stopEvent(ev);};Calendar.dayMouseOut=function(ev){with(Calendar){var el=getElement(ev);if(isRelated(el,ev)||_C||el.disabled)return false;removeClass(el,"hilite");if(el.caldate)removeClass(el.parentNode,"rowhilite");if(el.calendar)el.calendar.tooltips.innerHTML=_TT["SEL_DATE"];return stopEvent(ev);}};Calendar.cellClick=function(el,ev){var cal=el.calendar;var closing=false;var newdate=false;var date=null;if(typeof el.navtype=="undefined"){if(cal.currentDateEl){Calendar.removeClass(cal.currentDateEl,"selected");Calendar.addClass(el,"selected");closing=(cal.currentDateEl==el);if(!closing){cal.currentDateEl=el;}}cal.date.setDateOnly(el.caldate);date=cal.date;var other_month=!(cal.dateClicked=!el.otherMonth);if(!other_month&&!cal.currentDateEl)cal._toggleMultipleDate(new Date(date));else newdate=!el.disabled;if(other_month)cal._init(cal.firstDayOfWeek,date);}else{if(el.navtype==200){Calendar.removeClass(el,"hilite");cal.callCloseHandler();return;}date=new Date(cal.date);if(el.navtype==0)date.setDateOnly(new Date());cal.dateClicked=false;var year=date.getFullYear();var mon=date.getMonth();function setMonth(m){var day=date.getDate();var max=date.getMonthDays(m);if(day>max){date.setDate(max);}date.setMonth(m);};switch(el.navtype){case 400:Calendar.removeClass(el,"hilite");var text=Calendar._TT["ABOUT"];if(typeof text!="undefined"){text+=cal.showsTime?Calendar._TT["ABOUT_TIME"]:"";}else{text="Help and about box text is not translated into this language.\n"+"If you know this language and you feel generous please update\n"+"the corresponding file in \"lang\" subdir to match calendar-en.js\n"+"and send it back to to get it into the distribution ;-)\n\n"+"Thank you!\n"+"http://dynarch.com/mishoo/calendar.epl\n";}alert(text);return;case-2:if(year>cal.minYear){date.setFullYear(year-1);}break;case-1:if(mon>0){setMonth(mon-1);}else if(year-->cal.minYear){date.setFullYear(year);setMonth(11);}break;case 1:if(mon<11){setMonth(mon+1);}else if(year=0;)if(range[i]==current)break;if(ev&&ev.shiftKey){if(--i<0)i=range.length-1;}else if(++i>=range.length)i=0;var newval=range[i];el.innerHTML=newval;cal.onUpdateTime();return;case 0:if((typeof cal.getDateStatus=="function")&&cal.getDateStatus(date,date.getFullYear(),date.getMonth(),date.getDate())){return false;}break;}if(!date.equalsTo(cal.date)){cal.setDate(date);newdate=true;}else if(el.navtype==0)newdate=closing=true;}if(newdate){ev&&cal.callHandler();}if(closing){Calendar.removeClass(el,"hilite");ev&&cal.callCloseHandler();}};Calendar.prototype.create=function(_par){var parent=null;if(!_par){parent=document.getElementsByTagName("body")[0];this.isPopup=true;}else{parent=_par;this.isPopup=false;}this.date=this.dateStr?new Date(this.dateStr):new Date();var table=Calendar.createElement("table");this.table=table;table.cellSpacing=0;table.cellPadding=0;table.calendar=this;Calendar.addEvent(table,"mousedown",Calendar.tableMouseDown);var div=Calendar.createElement("div");this.element=div;div.className="calendar";if(this.isPopup){div.style.position="absolute";div.style.display="none";}div.appendChild(table);var thead=Calendar.createElement("thead",table);var cell=null;var row=null;var cal=this;var hh=function(text,cs,navtype){cell=Calendar.createElement("td",row);cell.colSpan=cs;cell.className="button";if(navtype!=0&&Math.abs(navtype)<=2)cell.className+=" nav";Calendar._add_evs(cell);cell.calendar=cal;cell.navtype=navtype;cell.innerHTML="
    "+text+"
    ";return cell;};row=Calendar.createElement("tr",thead);var title_length=6;(this.isPopup)&&--title_length;(this.weekNumbers)&&++title_length;hh("?",1,400).ttip=Calendar._TT["INFO"];this.title=hh("",title_length,300);this.title.className="title";if(this.isPopup){this.title.ttip=Calendar._TT["DRAG_TO_MOVE"];this.title.style.cursor="move";hh("×",1,200).ttip=Calendar._TT["CLOSE"];}row=Calendar.createElement("tr",thead);row.className="headrow";this._nav_py=hh("«",1,-2);this._nav_py.ttip=Calendar._TT["PREV_YEAR"];this._nav_pm=hh("‹",1,-1);this._nav_pm.ttip=Calendar._TT["PREV_MONTH"];this._nav_now=hh(Calendar._TT["TODAY"],this.weekNumbers?4:3,0);this._nav_now.ttip=Calendar._TT["GO_TODAY"];this._nav_nm=hh("›",1,1);this._nav_nm.ttip=Calendar._TT["NEXT_MONTH"];this._nav_ny=hh("»",1,2);this._nav_ny.ttip=Calendar._TT["NEXT_YEAR"];row=Calendar.createElement("tr",thead);row.className="daynames";if(this.weekNumbers){cell=Calendar.createElement("td",row);cell.className="name wn";cell.innerHTML=Calendar._TT["WK"];}for(var i=7;i>0;--i){cell=Calendar.createElement("td",row);if(!i){cell.navtype=100;cell.calendar=this;Calendar._add_evs(cell);}}this.firstdayname=(this.weekNumbers)?row.firstChild.nextSibling:row.firstChild;this._displayWeekdays();var tbody=Calendar.createElement("tbody",table);this.tbody=tbody;for(i=6;i>0;--i){row=Calendar.createElement("tr",tbody);if(this.weekNumbers){cell=Calendar.createElement("td",row);}for(var j=7;j>0;--j){cell=Calendar.createElement("td",row);cell.calendar=this;Calendar._add_evs(cell);}}if(this.showsTime){row=Calendar.createElement("tr",tbody);row.className="time";cell=Calendar.createElement("td",row);cell.className="time";cell.colSpan=2;cell.innerHTML=Calendar._TT["TIME"]||" ";cell=Calendar.createElement("td",row);cell.className="time";cell.colSpan=this.weekNumbers?4:3;(function(){function makeTimePart(className,init,range_start,range_end){var part=Calendar.createElement("span",cell);part.className=className;part.innerHTML=init;part.calendar=cal;part.ttip=Calendar._TT["TIME_PART"];part.navtype=50;part._range=[];if(typeof range_start!="number")part._range=range_start;else{for(var i=range_start;i<=range_end;++i){var txt;if(i<10&&range_end>=10)txt='0'+i;else txt=''+i;part._range[part._range.length]=txt;}}Calendar._add_evs(part);return part;};var hrs=cal.date.getHours();var mins=cal.date.getMinutes();var t12=!cal.time24;var pm=(hrs>12);if(t12&&pm)hrs-=12;var H=makeTimePart("hour",hrs,t12?1:0,t12?12:23);var span=Calendar.createElement("span",cell);span.innerHTML=":";span.className="colon";var M=makeTimePart("minute",mins,0,59);var AP=null;cell=Calendar.createElement("td",row);cell.className="time";cell.colSpan=2;if(t12)AP=makeTimePart("ampm",pm?"pm":"am",["am","pm"]);else cell.innerHTML=" ";cal.onSetTime=function(){var pm,hrs=this.date.getHours(),mins=this.date.getMinutes();if(t12){pm=(hrs>=12);if(pm)hrs-=12;if(hrs==0)hrs=12;AP.innerHTML=pm?"pm":"am";}H.innerHTML=(hrs<10)?("0"+hrs):hrs;M.innerHTML=(mins<10)?("0"+mins):mins;};cal.onUpdateTime=function(){var date=this.date;var h=parseInt(H.innerHTML,10);if(t12){if(/pm/i.test(AP.innerHTML)&&h<12)h+=12;else if(/am/i.test(AP.innerHTML)&&h==12)h=0;}var d=date.getDate();var m=date.getMonth();var y=date.getFullYear();date.setHours(h);date.setMinutes(parseInt(M.innerHTML,10));date.setFullYear(y);date.setMonth(m);date.setDate(d);this.dateClicked=false;this.callHandler();};})();}else{this.onSetTime=this.onUpdateTime=function(){};}var tfoot=Calendar.createElement("tfoot",table);row=Calendar.createElement("tr",tfoot);row.className="footrow";cell=hh(Calendar._TT["SEL_DATE"],this.weekNumbers?8:7,300);cell.className="ttip";if(this.isPopup){cell.ttip=Calendar._TT["DRAG_TO_MOVE"];cell.style.cursor="move";}this.tooltips=cell;div=Calendar.createElement("div",this.element);this.monthsCombo=div;div.className="combo";for(i=0;i0;--i){var yr=Calendar.createElement("div");yr.className=Calendar.is_ie?"label-IEfix":"label";div.appendChild(yr);}this._init(this.firstDayOfWeek,this.date);parent.appendChild(this.element);};Calendar._keyEvent=function(ev){var cal=window._dynarch_popupCalendar;if(!cal||cal.multiple)return false;(Calendar.is_ie)&&(ev=window.event);var act=(Calendar.is_ie||ev.type=="keypress"),K=ev.keyCode;if(ev.ctrlKey){switch(K){case 37:act&&Calendar.cellClick(cal._nav_pm);break;case 38:act&&Calendar.cellClick(cal._nav_py);break;case 39:act&&Calendar.cellClick(cal._nav_nm);break;case 40:act&&Calendar.cellClick(cal._nav_ny);break;default:return false;}}else switch(K){case 32:Calendar.cellClick(cal._nav_now);break;case 27:act&&cal.callCloseHandler();break;case 37:case 38:case 39:case 40:if(act){var prev,x,y,ne,el,step;prev=K==37||K==38;step=(K==37||K==39)?1:7;function setVars(){el=cal.currentDateEl;var p=el.pos;x=p&15;y=p>>4;ne=cal.ar_days[y][x];};setVars();function prevMonth(){var date=new Date(cal.date);date.setDate(date.getDate()-step);cal.setDate(date);};function nextMonth(){var date=new Date(cal.date);date.setDate(date.getDate()+step);cal.setDate(date);};while(1){switch(K){case 37:if(--x>=0)ne=cal.ar_days[y][x];else{x=6;K=38;continue;}break;case 38:if(--y>=0)ne=cal.ar_days[y][x];else{prevMonth();setVars();}break;case 39:if(++x<7)ne=cal.ar_days[y][x];else{x=0;K=40;continue;}break;case 40:if(++ythis.maxYear){year=this.maxYear;date.setFullYear(year);}this.firstDayOfWeek=firstDayOfWeek;this.date=new Date(date);var month=date.getMonth();var mday=date.getDate();var no_days=date.getMonthDays();date.setDate(1);var day1=(date.getDay()-this.firstDayOfWeek)%7;if(day1<0)day1+=7;date.setDate(-day1);date.setDate(date.getDate()+1);var row=this.tbody.firstChild;var MN=Calendar._SMN[month];var ar_days=this.ar_days=new Array();var weekend=Calendar._TT["WEEKEND"];var dates=this.multiple?(this.datesCells={}):null;for(var i=0;i<6;++i,row=row.nextSibling){var cell=row.firstChild;if(this.weekNumbers){cell.className="day wn";cell.innerHTML=date.getWeekNumber();cell=cell.nextSibling;}row.className="daysrow";var hasdays=false,iday,dpos=ar_days[i]=[];for(var j=0;j<7;++j,cell=cell.nextSibling,date.setDate(iday+1)){iday=date.getDate();var wday=date.getDay();cell.className="day";cell.pos=i<<4|j;dpos[j]=cell;var current_month=(date.getMonth()==month);if(!current_month){if(this.showsOtherMonths){cell.className+=" othermonth";cell.otherMonth=true;}else{cell.className="emptycell";cell.innerHTML=" ";cell.disabled=true;continue;}}else{cell.otherMonth=false;hasdays=true;}cell.disabled=false;cell.innerHTML=this.getDateText?this.getDateText(date,iday):iday;if(dates)dates[date.print("%Y%m%d")]=cell;if(this.getDateStatus){var status=this.getDateStatus(date,year,month,iday);if(this.getDateToolTip){var toolTip=this.getDateToolTip(date,year,month,iday);if(toolTip)cell.title=toolTip;}if(status===true){cell.className+=" disabled";cell.disabled=true;}else{if(/disabled/i.test(status))cell.disabled=true;cell.className+=" "+status;}}if(!cell.disabled){cell.caldate=new Date(date);cell.ttip="_";if(!this.multiple&¤t_month&&iday==mday&&this.hiliteToday){cell.className+=" selected";this.currentDateEl=cell;}if(date.getFullYear()==TY&&date.getMonth()==TM&&iday==TD){cell.className+=" today";cell.ttip+=Calendar._TT["PART_TODAY"];}if(weekend.indexOf(wday.toString())!=-1)cell.className+=cell.otherMonth?" oweekend":" weekend";}}if(!(hasdays||this.showsOtherMonths))row.className="emptyrow";}this.title.innerHTML=Calendar._MN[month]+", "+year;this.onSetTime();this.table.style.visibility="visible";this._initMultipleDates();};Calendar.prototype._initMultipleDates=function(){if(this.multiple){for(var i in this.multiple){var cell=this.datesCells[i];var d=this.multiple[i];if(!d)continue;if(cell)cell.className+=" selected";}}};Calendar.prototype._toggleMultipleDate=function(date){if(this.multiple){var ds=date.print("%Y%m%d");var cell=this.datesCells[ds];if(cell){var d=this.multiple[ds];if(!d){Calendar.addClass(cell,"selected");this.multiple[ds]=date;}else{Calendar.removeClass(cell,"selected");delete this.multiple[ds];}}}};Calendar.prototype.setDateToolTipHandler=function(unaryFunction){this.getDateToolTip=unaryFunction;};Calendar.prototype.setDate=function(date){if(!date.equalsTo(this.date)){this._init(this.firstDayOfWeek,date);}};Calendar.prototype.refresh=function(){this._init(this.firstDayOfWeek,this.date);};Calendar.prototype.setFirstDayOfWeek=function(firstDayOfWeek){this._init(firstDayOfWeek,this.date);this._displayWeekdays();};Calendar.prototype.setDateStatusHandler=Calendar.prototype.setDisabledHandler=function(unaryFunction){this.getDateStatus=unaryFunction;};Calendar.prototype.setRange=function(a,z){this.minYear=a;this.maxYear=z;};Calendar.prototype.callHandler=function(){if(this.onSelected){this.onSelected(this,this.date.print(this.dateFormat));}};Calendar.prototype.callCloseHandler=function(){if(this.onClose){this.onClose(this);}this.hideShowCovered();};Calendar.prototype.destroy=function(){var el=this.element.parentNode;el.removeChild(this.element);Calendar._C=null;window._dynarch_popupCalendar=null;};Calendar.prototype.reparent=function(new_parent){var el=this.element;el.parentNode.removeChild(el);new_parent.appendChild(el);};Calendar._checkCalendar=function(ev){var calendar=window._dynarch_popupCalendar;if(!calendar){return false;}var el=Calendar.is_ie?Calendar.getElement(ev):Calendar.getTargetElement(ev);for(;el!=null&&el!=calendar.element;el=el.parentNode);if(el==null){window._dynarch_popupCalendar.callCloseHandler();return Calendar.stopEvent(ev);}};Calendar.prototype.show=function(){var rows=this.table.getElementsByTagName("tr");for(var i=rows.length;i>0;){var row=rows[--i];Calendar.removeClass(row,"rowhilite");var cells=row.getElementsByTagName("td");for(var j=cells.length;j>0;){var cell=cells[--j];Calendar.removeClass(cell,"hilite");Calendar.removeClass(cell,"active");}}this.element.style.display="block";this.hidden=false;if(this.isPopup){window._dynarch_popupCalendar=this;Calendar.addEvent(document,"keydown",Calendar._keyEvent);Calendar.addEvent(document,"keypress",Calendar._keyEvent);Calendar.addEvent(document,"mousedown",Calendar._checkCalendar);}this.hideShowCovered();};Calendar.prototype.hide=function(){if(this.isPopup){Calendar.removeEvent(document,"keydown",Calendar._keyEvent);Calendar.removeEvent(document,"keypress",Calendar._keyEvent);Calendar.removeEvent(document,"mousedown",Calendar._checkCalendar);}this.element.style.display="none";this.hidden=true;this.hideShowCovered();};Calendar.prototype.showAt=function(x,y){var s=this.element.style;s.left=x+"px";s.top=y+"px";this.show();};Calendar.prototype.showAtElement=function(el,opts){var self=this;var p=Calendar.getAbsolutePos(el);if(!opts||typeof opts!="string"){this.showAt(p.x,p.y+el.offsetHeight);return true;}function fixPosition(box){if(box.x<0)box.x=0;if(box.y<0)box.y=0;var cp=document.createElement("div");var s=cp.style;s.position="absolute";s.right=s.bottom=s.width=s.height="0px";document.body.appendChild(cp);var br=Calendar.getAbsolutePos(cp);document.body.removeChild(cp);if(Calendar.is_ie){br.y+=document.body.scrollTop;br.x+=document.body.scrollLeft;}else{br.y+=window.scrollY;br.x+=window.scrollX;}var tmp=box.x+box.width-br.x;if(tmp>0)box.x-=tmp;tmp=box.y+box.height-br.y;if(tmp>0)box.y-=tmp;};this.element.style.display="block";Calendar.continuation_for_the_fucking_khtml_browser=function(){var w=self.element.offsetWidth;var h=self.element.offsetHeight;self.element.style.display="none";var valign=opts.substr(0,1);var halign="l";if(opts.length>1){halign=opts.substr(1,1);}switch(valign){case "T":p.y-=h;break;case "B":p.y+=el.offsetHeight;break;case "C":p.y+=(el.offsetHeight-h)/2;break;case "t":p.y+=el.offsetHeight-h;break;case "b":break;}switch(halign){case "L":p.x-=w;break;case "R":p.x+=el.offsetWidth;break;case "C":p.x+=(el.offsetWidth-w)/2;break;case "l":p.x+=el.offsetWidth-w;break;case "r":break;}p.width=w;p.height=h+40;self.monthsCombo.style.display="none";fixPosition(p);self.showAt(p.x,p.y);};if(Calendar.is_khtml)setTimeout("Calendar.continuation_for_the_fucking_khtml_browser()",10);else Calendar.continuation_for_the_fucking_khtml_browser();};Calendar.prototype.setDateFormat=function(str){this.dateFormat=str;};Calendar.prototype.setTtDateFormat=function(str){this.ttDateFormat=str;};Calendar.prototype.parseDate=function(str,fmt){if(!fmt)fmt=this.dateFormat;this.setDate(Date.parseDate(str,fmt));};Calendar.prototype.hideShowCovered=function(){if(!Calendar.is_ie&&!Calendar.is_opera)return;function getVisib(obj){var value=obj.style.visibility;if(!value){if(document.defaultView&&typeof(document.defaultView.getComputedStyle)=="function"){if(!Calendar.is_khtml)value=document.defaultView. getComputedStyle(obj,"").getPropertyValue("visibility");else value='';}else if(obj.currentStyle){value=obj.currentStyle.visibility;}else value='';}return value;};var tags=new Array("applet","iframe","select");var el=this.element;var p=Calendar.getAbsolutePos(el);var EX1=p.x;var EX2=el.offsetWidth+EX1;var EY1=p.y;var EY2=el.offsetHeight+EY1;for(var k=tags.length;k>0;){var ar=document.getElementsByTagName(tags[--k]);var cc=null;for(var i=ar.length;i>0;){cc=ar[--i];p=Calendar.getAbsolutePos(cc);var CX1=p.x;var CX2=cc.offsetWidth+CX1;var CY1=p.y;var CY2=cc.offsetHeight+CY1;if(this.hidden||(CX1>EX2)||(CX2EY2)||(CY229)?1900:2000);break;case "%b":case "%B":for(j=0;j<12;++j){if(Calendar._MN[j].substr(0,a[i].length).toLowerCase()==a[i].toLowerCase()){m=j;break;}}break;case "%H":case "%I":case "%k":case "%l":hr=parseInt(a[i],10);break;case "%P":case "%p":if(/pm/i.test(a[i])&&hr<12)hr+=12;else if(/am/i.test(a[i])&&hr>=12)hr-=12;break;case "%M":min=parseInt(a[i],10);break;}}if(isNaN(y))y=today.getFullYear();if(isNaN(m))m=today.getMonth();if(isNaN(d))d=today.getDate();if(isNaN(hr))hr=today.getHours();if(isNaN(min))min=today.getMinutes();if(y!=0&&m!=-1&&d!=0)return new Date(y,m,d,hr,min,0);y=0;m=-1;d=0;for(i=0;i31&&y==0){y=parseInt(a[i],10);(y<100)&&(y+=(y>29)?1900:2000);}else if(d==0){d=a[i];}}if(y==0)y=today.getFullYear();if(m!=-1&&d!=0)return new Date(y,m,d,hr,min,0);return today;};Date.prototype.getMonthDays=function(month){var year=this.getFullYear();if(typeof month=="undefined"){month=this.getMonth();}if(((0==(year%4))&&((0!=(year%100))||(0==(year%400))))&&month==1){return 29;}else{return Date._MD[month];}};Date.prototype.getDayOfYear=function(){var now=new Date(this.getFullYear(),this.getMonth(),this.getDate(),0,0,0);var then=new Date(this.getFullYear(),0,0,0,0,0);var time=now-then;return Math.floor(time/Date.DAY);};Date.prototype.getWeekNumber=function(){var d=new Date(this.getFullYear(),this.getMonth(),this.getDate(),0,0,0);var DoW=d.getDay();d.setDate(d.getDate()-(DoW+6)%7+3);var ms=d.valueOf();d.setMonth(0);d.setDate(4);return Math.round((ms-d.valueOf())/(7*864e5))+1;};Date.prototype.equalsTo=function(date){return((this.getFullYear()==date.getFullYear())&&(this.getMonth()==date.getMonth())&&(this.getDate()==date.getDate())&&(this.getHours()==date.getHours())&&(this.getMinutes()==date.getMinutes()));};Date.prototype.setDateOnly=function(date){var tmp=new Date(date);this.setDate(1);this.setFullYear(tmp.getFullYear());this.setMonth(tmp.getMonth());this.setDate(tmp.getDate());};Date.prototype.print=function(str){var m=this.getMonth();var d=this.getDate();var y=this.getFullYear();var wn=this.getWeekNumber();var w=this.getDay();var s={};var hr=this.getHours();var pm=(hr>=12);var ir=(pm)?(hr-12):hr;var dy=this.getDayOfYear();if(ir==0)ir=12;var min=this.getMinutes();var sec=this.getSeconds();s["%a"]=Calendar._SDN[w];s["%A"]=Calendar._DN[w];s["%b"]=Calendar._SMN[m];s["%B"]=Calendar._MN[m];s["%C"]=1+Math.floor(y/100);s["%d"]=(d<10)?("0"+d):d;s["%e"]=d;s["%H"]=(hr<10)?("0"+hr):hr;s["%I"]=(ir<10)?("0"+ir):ir;s["%j"]=(dy<100)?((dy<10)?("00"+dy):("0"+dy)):dy;s["%k"]=hr;s["%l"]=ir;s["%m"]=(m<9)?("0"+(1+m)):(1+m);s["%M"]=(min<10)?("0"+min):min;s["%n"]="\n";s["%p"]=pm?"PM":"AM";s["%P"]=pm?"pm":"am";s["%s"]=Math.floor(this.getTime()/1000);s["%S"]=(sec<10)?("0"+sec):sec;s["%t"]="\t";s["%U"]=s["%W"]=s["%V"]=(wn<10)?("0"+wn):wn;s["%u"]=w+1;s["%w"]=w;s["%y"]=(''+y).substr(2,2);s["%Y"]=y;s["%%"]="%";var re=/%./g;if(!Calendar.is_ie5&&!Calendar.is_khtml)return str.replace(re,function(par){return s[par]||par;});var a=str.match(re);for(var i=0;i -// Translator: Valentin Sheiretsky, -// Encoding: Windows-1251 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Íåäåëÿ", - "Ïîíåäåëíèê", - "Âòîðíèê", - "Ñðÿäà", - "×åòâúðòúê", - "Ïåòúê", - "Ñúáîòà", - "Íåäåëÿ"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Íåä", - "Ïîí", - "Âòî", - "Ñðÿ", - "×åò", - "Ïåò", - "Ñúá", - "Íåä"); - -// full month names -Calendar._MN = new Array -("ßíóàðè", - "Ôåâðóàðè", - "Ìàðò", - "Àïðèë", - "Ìàé", - "Þíè", - "Þëè", - "Àâãóñò", - "Ñåïòåìâðè", - "Îêòîìâðè", - "Íîåìâðè", - "Äåêåìâðè"); - -// short month names -Calendar._SMN = new Array -("ßíó", - "Ôåâ", - "Ìàð", - "Àïð", - "Ìàé", - "Þíè", - "Þëè", - "Àâã", - "Ñåï", - "Îêò", - "Íîå", - "Äåê"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Èíôîðìàöèÿ çà êàëåíäàðà"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Date selection:\n" + -"- Use the \xab, \xbb buttons to select year\n" + -"- Use the " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " buttons to select month\n" + -"- Hold mouse button on any of the above buttons for faster selection."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Time selection:\n" + -"- Click on any of the time parts to increase it\n" + -"- or Shift-click to decrease it\n" + -"- or click and drag for faster selection."; - -Calendar._TT["PREV_YEAR"] = "Ïðåäíà ãîäèíà (çàäðúæòå çà ìåíþ)"; -Calendar._TT["PREV_MONTH"] = "Ïðåäåí ìåñåö (çàäðúæòå çà ìåíþ)"; -Calendar._TT["GO_TODAY"] = "Èçáåðåòå äíåñ"; -Calendar._TT["NEXT_MONTH"] = "Ñëåäâàù ìåñåö (çàäðúæòå çà ìåíþ)"; -Calendar._TT["NEXT_YEAR"] = "Ñëåäâàùà ãîäèíà (çàäðúæòå çà ìåíþ)"; -Calendar._TT["SEL_DATE"] = "Èçáåðåòå äàòà"; -Calendar._TT["DRAG_TO_MOVE"] = "Ïðåìåñòâàíå"; -Calendar._TT["PART_TODAY"] = " (äíåñ)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "%s êàòî ïúðâè äåí"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Çàòâîðåòå"; -Calendar._TT["TODAY"] = "Äíåñ"; -Calendar._TT["TIME_PART"] = "(Shift-)Click èëè drag çà äà ïðîìåíèòå ñòîéíîñòòà"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%A - %e %B %Y"; - -Calendar._TT["WK"] = "Ñåäì"; -Calendar._TT["TIME"] = "×àñ:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5-utf8.js deleted file mode 100644 index 14e0d5ddee..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5-utf8.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar big5-utf8 language -// Author: Gary Fu, -// Encoding: utf8 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("星期日", - "星期一", - "星期二", - "星期三", - "星期四", - "星期五", - "星期六", - "星期日"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("æ—¥", - "一", - "二", - "三", - "å››", - "五", - "å…­", - "æ—¥"); - -// full month names -Calendar._MN = new Array -("一月", - "二月", - "三月", - "四月", - "五月", - "六月", - "七月", - "八月", - "ä¹æœˆ", - "å月", - "å一月", - "å二月"); - -// short month names -Calendar._SMN = new Array -("一月", - "二月", - "三月", - "四月", - "五月", - "六月", - "七月", - "八月", - "ä¹æœˆ", - "å月", - "å一月", - "å二月"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "關於"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"日期é¸æ“‡æ–¹æ³•:\n" + -"- 使用 \xab, \xbb 按鈕å¯é¸æ“‡å¹´ä»½\n" + -"- 使用 " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " 按鈕å¯é¸æ“‡æœˆä»½\n" + -"- 按ä½ä¸Šé¢çš„按鈕å¯ä»¥åŠ å¿«é¸å–"; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"時間é¸æ“‡æ–¹æ³•:\n" + -"- 點擊任何的時間部份å¯å¢žåŠ å…¶å€¼\n" + -"- åŒæ™‚按Shiftéµå†é»žæ“Šå¯æ¸›å°‘其值\n" + -"- 點擊並拖曳å¯åŠ å¿«æ”¹è®Šçš„值"; - -Calendar._TT["PREV_YEAR"] = "上一年 (按ä½é¸å–®)"; -Calendar._TT["PREV_MONTH"] = "下一年 (按ä½é¸å–®)"; -Calendar._TT["GO_TODAY"] = "到今日"; -Calendar._TT["NEXT_MONTH"] = "上一月 (按ä½é¸å–®)"; -Calendar._TT["NEXT_YEAR"] = "下一月 (按ä½é¸å–®)"; -Calendar._TT["SEL_DATE"] = "é¸æ“‡æ—¥æœŸ"; -Calendar._TT["DRAG_TO_MOVE"] = "拖曳"; -Calendar._TT["PART_TODAY"] = " (今日)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "å°‡ %s 顯示在å‰"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "關閉"; -Calendar._TT["TODAY"] = "今日"; -Calendar._TT["TIME_PART"] = "點擊or拖曳å¯æ”¹è®Šæ™‚é–“(åŒæ™‚按Shift為減)"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "週"; -Calendar._TT["TIME"] = "Time:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5.js deleted file mode 100644 index a58935873f..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-big5.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar big5 language -// Author: Gary Fu, -// Encoding: big5 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("¬P´Á¤é", - "¬P´Á¤@", - "¬P´Á¤G", - "¬P´Á¤T", - "¬P´Á¥|", - "¬P´Á¤­", - "¬P´Á¤»", - "¬P´Á¤é"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("¤é", - "¤@", - "¤G", - "¤T", - "¥|", - "¤­", - "¤»", - "¤é"); - -// full month names -Calendar._MN = new Array -("¤@¤ë", - "¤G¤ë", - "¤T¤ë", - "¥|¤ë", - "¤­¤ë", - "¤»¤ë", - "¤C¤ë", - "¤K¤ë", - "¤E¤ë", - "¤Q¤ë", - "¤Q¤@¤ë", - "¤Q¤G¤ë"); - -// short month names -Calendar._SMN = new Array -("¤@¤ë", - "¤G¤ë", - "¤T¤ë", - "¥|¤ë", - "¤­¤ë", - "¤»¤ë", - "¤C¤ë", - "¤K¤ë", - "¤E¤ë", - "¤Q¤ë", - "¤Q¤@¤ë", - "¤Q¤G¤ë"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Ãö©ó"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"¤é´Á¿ï¾Ü¤èªk:\n" + -"- ¨Ï¥Î \xab, \xbb «ö¶s¥i¿ï¾Ü¦~¥÷\n" + -"- ¨Ï¥Î " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " «ö¶s¥i¿ï¾Ü¤ë¥÷\n" + -"- «ö¦í¤W­±ªº«ö¶s¥i¥H¥[§Ö¿ï¨ú"; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"®É¶¡¿ï¾Ü¤èªk:\n" + -"- ÂIÀ»¥ô¦óªº®É¶¡³¡¥÷¥i¼W¥[¨ä­È\n" + -"- ¦P®É«öShiftÁä¦AÂIÀ»¥i´î¤Ö¨ä­È\n" + -"- ÂIÀ»¨Ã©ì¦²¥i¥[§Ö§ïÅܪº­È"; - -Calendar._TT["PREV_YEAR"] = "¤W¤@¦~ («ö¦í¿ï³æ)"; -Calendar._TT["PREV_MONTH"] = "¤U¤@¦~ («ö¦í¿ï³æ)"; -Calendar._TT["GO_TODAY"] = "¨ì¤µ¤é"; -Calendar._TT["NEXT_MONTH"] = "¤W¤@¤ë («ö¦í¿ï³æ)"; -Calendar._TT["NEXT_YEAR"] = "¤U¤@¤ë («ö¦í¿ï³æ)"; -Calendar._TT["SEL_DATE"] = "¿ï¾Ü¤é´Á"; -Calendar._TT["DRAG_TO_MOVE"] = "©ì¦²"; -Calendar._TT["PART_TODAY"] = " (¤µ¤é)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "±N %s Åã¥Ü¦b«e"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Ãö³¬"; -Calendar._TT["TODAY"] = "¤µ¤é"; -Calendar._TT["TIME_PART"] = "ÂIÀ»or©ì¦²¥i§ïÅܮɶ¡(¦P®É«öShift¬°´î)"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "¶g"; -Calendar._TT["TIME"] = "Time:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-br.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-br.js deleted file mode 100644 index bfb074717c..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-br.js +++ /dev/null @@ -1,108 +0,0 @@ -// ** I18N - -// Calendar pt-BR language -// Author: Fernando Dourado, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Domingo", - "Segunda", - "Terça", - "Quarta", - "Quinta", - "Sexta", - "Sabádo", - "Domingo"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -// [No changes using default values] - -// full month names -Calendar._MN = new Array -("Janeiro", - "Fevereiro", - "Março", - "Abril", - "Maio", - "Junho", - "Julho", - "Agosto", - "Setembro", - "Outubro", - "Novembro", - "Dezembro"); - -// short month names -// [No changes using default values] - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Sobre o calendário"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Translate to portuguese Brazil (pt-BR) by Fernando Dourado (fernando.dourado@ig.com.br)\n" + -"Tradução para o português Brasil (pt-BR) por Fernando Dourado (fernando.dourado@ig.com.br)" + -"\n\n" + -"Selecionar data:\n" + -"- Use as teclas \xab, \xbb para selecionar o ano\n" + -"- Use as teclas " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " para selecionar o mês\n" + -"- Clique e segure com o mouse em qualquer botão para selecionar rapidamente."; - -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selecionar hora:\n" + -"- Clique em qualquer uma das partes da hora para aumentar\n" + -"- ou Shift-clique para diminuir\n" + -"- ou clique e arraste para selecionar rapidamente."; - -Calendar._TT["PREV_YEAR"] = "Ano anterior (clique e segure para menu)"; -Calendar._TT["PREV_MONTH"] = "Mês anterior (clique e segure para menu)"; -Calendar._TT["GO_TODAY"] = "Ir para a data atual"; -Calendar._TT["NEXT_MONTH"] = "Próximo mês (clique e segure para menu)"; -Calendar._TT["NEXT_YEAR"] = "Próximo ano (clique e segure para menu)"; -Calendar._TT["SEL_DATE"] = "Selecione uma data"; -Calendar._TT["DRAG_TO_MOVE"] = "Clique e segure para mover"; -Calendar._TT["PART_TODAY"] = " (hoje)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Exibir %s primeiro"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Fechar"; -Calendar._TT["TODAY"] = "Hoje"; -Calendar._TT["TIME_PART"] = "(Shift-)Clique ou arraste para mudar o valor"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d/%m/%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%d de %B de %Y"; - -Calendar._TT["WK"] = "sem"; -Calendar._TT["TIME"] = "Hora:"; - diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ca.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ca.js deleted file mode 100644 index a2121bcb40..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ca.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar CA language -// Author: Mihai Bazon, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Diumenge", - "Dilluns", - "Dimarts", - "Dimecres", - "Dijous", - "Divendres", - "Dissabte", - "Diumenge"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Diu", - "Dil", - "Dmt", - "Dmc", - "Dij", - "Div", - "Dis", - "Diu"); - -// full month names -Calendar._MN = new Array -("Gener", - "Febrer", - "Març", - "Abril", - "Maig", - "Juny", - "Juliol", - "Agost", - "Setembre", - "Octubre", - "Novembre", - "Desembre"); - -// short month names -Calendar._SMN = new Array -("Gen", - "Feb", - "Mar", - "Abr", - "Mai", - "Jun", - "Jul", - "Ago", - "Set", - "Oct", - "Nov", - "Des"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Sobre el calendari"; - -Calendar._TT["ABOUT"] = -"DHTML Selector de Data/Hora\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Sel.lecció de Dates:\n" + -"- Fes servir els botons \xab, \xbb per sel.leccionar l'any\n" + -"- Fes servir els botons " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " per se.lecciconar el mes\n" + -"- Manté el ratolí apretat en qualsevol dels anteriors per sel.lecció ràpida."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Time selection:\n" + -"- claca en qualsevol de les parts de la hora per augmentar-les\n" + -"- o Shift-click per decrementar-la\n" + -"- or click and arrastra per sel.lecció ràpida."; - -Calendar._TT["PREV_YEAR"] = "Any anterior (Mantenir per menu)"; -Calendar._TT["PREV_MONTH"] = "Mes anterior (Mantenir per menu)"; -Calendar._TT["GO_TODAY"] = "Anar a avui"; -Calendar._TT["NEXT_MONTH"] = "Mes següent (Mantenir per menu)"; -Calendar._TT["NEXT_YEAR"] = "Any següent (Mantenir per menu)"; -Calendar._TT["SEL_DATE"] = "Sel.leccionar data"; -Calendar._TT["DRAG_TO_MOVE"] = "Arrastrar per moure"; -Calendar._TT["PART_TODAY"] = " (avui)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Mostra %s primer"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Tanca"; -Calendar._TT["TODAY"] = "Avui"; -Calendar._TT["TIME_PART"] = "(Shift-)Click a arrastra per canviar el valor"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "st"; -Calendar._TT["TIME"] = "Hora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-utf8.js deleted file mode 100644 index f6bbbeba14..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-utf8.js +++ /dev/null @@ -1,65 +0,0 @@ -/* - calendar-cs-win.js - language: Czech - encoding: windows-1250 - author: Lubos Jerabek (xnet@seznam.cz) - Jan Uhlir (espinosa@centrum.cz) -*/ - -// ** I18N -Calendar._DN = new Array('NedÄ›le','PondÄ›lí','Úterý','StÅ™eda','ÄŒtvrtek','Pátek','Sobota','NedÄ›le'); -Calendar._SDN = new Array('Ne','Po','Út','St','ÄŒt','Pá','So','Ne'); -Calendar._MN = new Array('Leden','Únor','BÅ™ezen','Duben','KvÄ›ten','ÄŒerven','ÄŒervenec','Srpen','Září','Říjen','Listopad','Prosinec'); -Calendar._SMN = new Array('Led','Úno','BÅ™e','Dub','KvÄ›','ÄŒrv','ÄŒvc','Srp','Zář','Říj','Lis','Pro'); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O komponentÄ› kalendář"; -Calendar._TT["TOGGLE"] = "ZmÄ›na prvního dne v týdnu"; -Calendar._TT["PREV_YEAR"] = "PÅ™edchozí rok (pÅ™idrž pro menu)"; -Calendar._TT["PREV_MONTH"] = "PÅ™edchozí mÄ›síc (pÅ™idrž pro menu)"; -Calendar._TT["GO_TODAY"] = "DneÅ¡ní datum"; -Calendar._TT["NEXT_MONTH"] = "Další mÄ›síc (pÅ™idrž pro menu)"; -Calendar._TT["NEXT_YEAR"] = "Další rok (pÅ™idrž pro menu)"; -Calendar._TT["SEL_DATE"] = "Vyber datum"; -Calendar._TT["DRAG_TO_MOVE"] = "ChyÅ¥ a táhni, pro pÅ™esun"; -Calendar._TT["PART_TODAY"] = " (dnes)"; -Calendar._TT["MON_FIRST"] = "Ukaž jako první PondÄ›lí"; -//Calendar._TT["SUN_FIRST"] = "Ukaž jako první NedÄ›li"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"VýbÄ›r datumu:\n" + -"- Use the \xab, \xbb buttons to select year\n" + -"- Použijte tlaÄítka " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " k výbÄ›ru mÄ›síce\n" + -"- Podržte tlaÄítko myÅ¡i na jakémkoliv z tÄ›ch tlaÄítek pro rychlejší výbÄ›r."; - -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"VýbÄ›r Äasu:\n" + -"- KliknÄ›te na jakoukoliv z Äástí výbÄ›ru Äasu pro zvýšení.\n" + -"- nebo Shift-click pro snížení\n" + -"- nebo kliknÄ›te a táhnÄ›te pro rychlejší výbÄ›r."; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Zobraz %s první"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Zavřít"; -Calendar._TT["TODAY"] = "Dnes"; -Calendar._TT["TIME_PART"] = "(Shift-)Klikni nebo táhni pro zmÄ›nu hodnoty"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "d.m.yy"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "ÄŒas:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-win.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-win.js deleted file mode 100644 index 140dff318c..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-cs-win.js +++ /dev/null @@ -1,65 +0,0 @@ -/* - calendar-cs-win.js - language: Czech - encoding: windows-1250 - author: Lubos Jerabek (xnet@seznam.cz) - Jan Uhlir (espinosa@centrum.cz) -*/ - -// ** I18N -Calendar._DN = new Array('Nedìle','Pondìlí','Úterý','Støeda','Ètvrtek','Pátek','Sobota','Nedìle'); -Calendar._SDN = new Array('Ne','Po','Út','St','Èt','Pá','So','Ne'); -Calendar._MN = new Array('Leden','Únor','Bøezen','Duben','Kvìten','Èerven','Èervenec','Srpen','Záøí','Øíjen','Listopad','Prosinec'); -Calendar._SMN = new Array('Led','Úno','Bøe','Dub','Kvì','Èrv','Èvc','Srp','Záø','Øíj','Lis','Pro'); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O komponentì kalendáø"; -Calendar._TT["TOGGLE"] = "Zmìna prvního dne v týdnu"; -Calendar._TT["PREV_YEAR"] = "Pøedchozí rok (pøidrž pro menu)"; -Calendar._TT["PREV_MONTH"] = "Pøedchozí mìsíc (pøidrž pro menu)"; -Calendar._TT["GO_TODAY"] = "Dnešní datum"; -Calendar._TT["NEXT_MONTH"] = "Další mìsíc (pøidrž pro menu)"; -Calendar._TT["NEXT_YEAR"] = "Další rok (pøidrž pro menu)"; -Calendar._TT["SEL_DATE"] = "Vyber datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Chy a táhni, pro pøesun"; -Calendar._TT["PART_TODAY"] = " (dnes)"; -Calendar._TT["MON_FIRST"] = "Ukaž jako první Pondìlí"; -//Calendar._TT["SUN_FIRST"] = "Ukaž jako první Nedìli"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Výbìr datumu:\n" + -"- Use the \xab, \xbb buttons to select year\n" + -"- Použijte tlaèítka " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " k výbìru mìsíce\n" + -"- Podržte tlaèítko myši na jakémkoliv z tìch tlaèítek pro rychlejší výbìr."; - -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Výbìr èasu:\n" + -"- Kliknìte na jakoukoliv z èástí výbìru èasu pro zvýšení.\n" + -"- nebo Shift-click pro snížení\n" + -"- nebo kliknìte a táhnìte pro rychlejší výbìr."; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Zobraz %s první"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Zavøít"; -Calendar._TT["TODAY"] = "Dnes"; -Calendar._TT["TIME_PART"] = "(Shift-)Klikni nebo táhni pro zmìnu hodnoty"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "d.m.yy"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "Èas:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-da.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-da.js deleted file mode 100644 index a99b598f03..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-da.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar DA language -// Author: Michael Thingmand Henriksen, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Søndag", -"Mandag", -"Tirsdag", -"Onsdag", -"Torsdag", -"Fredag", -"Lørdag", -"Søndag"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Søn", -"Man", -"Tir", -"Ons", -"Tor", -"Fre", -"Lør", -"Søn"); - -// full month names -Calendar._MN = new Array -("Januar", -"Februar", -"Marts", -"April", -"Maj", -"Juni", -"Juli", -"August", -"September", -"Oktober", -"November", -"December"); - -// short month names -Calendar._SMN = new Array -("Jan", -"Feb", -"Mar", -"Apr", -"Maj", -"Jun", -"Jul", -"Aug", -"Sep", -"Okt", -"Nov", -"Dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Om Kalenderen"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For den seneste version besøg: http://www.dynarch.com/projects/calendar/\n"; + -"Distribueret under GNU LGPL. Se http://gnu.org/licenses/lgpl.html for detajler." + -"\n\n" + -"Valg af dato:\n" + -"- Brug \xab, \xbb knapperne for at vælge Ã¥r\n" + -"- Brug " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " knapperne for at vælge mÃ¥ned\n" + -"- Hold knappen pÃ¥ musen nede pÃ¥ knapperne ovenfor for hurtigere valg."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Valg af tid:\n" + -"- Klik pÃ¥ en vilkÃ¥rlig del for større værdi\n" + -"- eller Shift-klik for for mindre værdi\n" + -"- eller klik og træk for hurtigere valg."; - -Calendar._TT["PREV_YEAR"] = "Ét Ã¥r tilbage (hold for menu)"; -Calendar._TT["PREV_MONTH"] = "Én mÃ¥ned tilbage (hold for menu)"; -Calendar._TT["GO_TODAY"] = "GÃ¥ til i dag"; -Calendar._TT["NEXT_MONTH"] = "Én mÃ¥ned frem (hold for menu)"; -Calendar._TT["NEXT_YEAR"] = "Ét Ã¥r frem (hold for menu)"; -Calendar._TT["SEL_DATE"] = "Vælg dag"; -Calendar._TT["DRAG_TO_MOVE"] = "Træk vinduet"; -Calendar._TT["PART_TODAY"] = " (i dag)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Vis %s først"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Luk"; -Calendar._TT["TODAY"] = "I dag"; -Calendar._TT["TIME_PART"] = "(Shift-)klik eller træk for at ændre værdi"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d-%m-%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "Uge"; -Calendar._TT["TIME"] = "Tid:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-de.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-de.js deleted file mode 100644 index 4bc1137cc1..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-de.js +++ /dev/null @@ -1,124 +0,0 @@ -// ** I18N - -// Calendar DE language -// Author: Jack (tR), -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Sonntag", - "Montag", - "Dienstag", - "Mittwoch", - "Donnerstag", - "Freitag", - "Samstag", - "Sonntag"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("So", - "Mo", - "Di", - "Mi", - "Do", - "Fr", - "Sa", - "So"); - -// full month names -Calendar._MN = new Array -("Januar", - "Februar", - "M\u00e4rz", - "April", - "Mai", - "Juni", - "Juli", - "August", - "September", - "Oktober", - "November", - "Dezember"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "M\u00e4r", - "Apr", - "May", - "Jun", - "Jul", - "Aug", - "Sep", - "Okt", - "Nov", - "Dez"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "\u00DCber dieses Kalendarmodul"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Datum ausw\u00e4hlen:\n" + -"- Benutzen Sie die \xab, \xbb Buttons um das Jahr zu w\u00e4hlen\n" + -"- Benutzen Sie die " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " Buttons um den Monat zu w\u00e4hlen\n" + -"- F\u00fcr eine Schnellauswahl halten Sie die Maustaste \u00fcber diesen Buttons fest."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Zeit ausw\u00e4hlen:\n" + -"- Klicken Sie auf die Teile der Uhrzeit, um diese zu erh\u00F6hen\n" + -"- oder klicken Sie mit festgehaltener Shift-Taste um diese zu verringern\n" + -"- oder klicken und festhalten f\u00fcr Schnellauswahl."; - -Calendar._TT["TOGGLE"] = "Ersten Tag der Woche w\u00e4hlen"; -Calendar._TT["PREV_YEAR"] = "Voriges Jahr (Festhalten f\u00fcr Schnellauswahl)"; -Calendar._TT["PREV_MONTH"] = "Voriger Monat (Festhalten f\u00fcr Schnellauswahl)"; -Calendar._TT["GO_TODAY"] = "Heute ausw\u00e4hlen"; -Calendar._TT["NEXT_MONTH"] = "N\u00e4chst. Monat (Festhalten f\u00fcr Schnellauswahl)"; -Calendar._TT["NEXT_YEAR"] = "N\u00e4chst. Jahr (Festhalten f\u00fcr Schnellauswahl)"; -Calendar._TT["SEL_DATE"] = "Datum ausw\u00e4hlen"; -Calendar._TT["DRAG_TO_MOVE"] = "Zum Bewegen festhalten"; -Calendar._TT["PART_TODAY"] = " (Heute)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Woche beginnt mit %s "; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Schlie\u00dfen"; -Calendar._TT["TODAY"] = "Heute"; -Calendar._TT["TIME_PART"] = "(Shift-)Klick oder Festhalten und Ziehen um den Wert zu \u00e4ndern"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d.%m.%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "Zeit:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-du.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-du.js deleted file mode 100644 index 2200448051..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-du.js +++ /dev/null @@ -1,45 +0,0 @@ -// ** I18N -Calendar._DN = new Array -("Zondag", - "Maandag", - "Dinsdag", - "Woensdag", - "Donderdag", - "Vrijdag", - "Zaterdag", - "Zondag"); -Calendar._MN = new Array -("Januari", - "Februari", - "Maart", - "April", - "Mei", - "Juni", - "Juli", - "Augustus", - "September", - "Oktober", - "November", - "December"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["TOGGLE"] = "Toggle startdag van de week"; -Calendar._TT["PREV_YEAR"] = "Vorig jaar (indrukken voor menu)"; -Calendar._TT["PREV_MONTH"] = "Vorige month (indrukken voor menu)"; -Calendar._TT["GO_TODAY"] = "Naar Vandaag"; -Calendar._TT["NEXT_MONTH"] = "Volgende Maand (indrukken voor menu)"; -Calendar._TT["NEXT_YEAR"] = "Volgend jaar (indrukken voor menu)"; -Calendar._TT["SEL_DATE"] = "Selecteer datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Sleep om te verplaatsen"; -Calendar._TT["PART_TODAY"] = " (vandaag)"; -Calendar._TT["MON_FIRST"] = "Toon Maandag eerst"; -Calendar._TT["SUN_FIRST"] = "Toon Zondag eerst"; -Calendar._TT["CLOSE"] = "Sluiten"; -Calendar._TT["TODAY"] = "Vandaag"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "y-mm-dd"; -Calendar._TT["TT_DATE_FORMAT"] = "D, M d"; - -Calendar._TT["WK"] = "wk"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-el.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-el.js deleted file mode 100644 index 43a9b2ceaf..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-el.js +++ /dev/null @@ -1,89 +0,0 @@ -// ** I18N -Calendar._DN = new Array -("ΚυÏιακή", - "ΔευτέÏα", - "ΤÏίτη", - "ΤετάÏτη", - "Πέμπτη", - "ΠαÏασκευή", - "Σάββατο", - "ΚυÏιακή"); - -Calendar._SDN = new Array -("Κυ", - "Δε", - "TÏ", - "Τε", - "Πε", - "Πα", - "Σα", - "Κυ"); - -Calendar._MN = new Array -("ΙανουάÏιος", - "ΦεβÏουάÏιος", - "ΜάÏτιος", - "ΑπÏίλιος", - "Μάϊος", - "ΙοÏνιος", - "ΙοÏλιος", - "ΑÏγουστος", - "ΣεπτέμβÏιος", - "ΟκτώβÏιος", - "ÎοέμβÏιος", - "ΔεκέμβÏιος"); - -Calendar._SMN = new Array -("Ιαν", - "Φεβ", - "ΜαÏ", - "ΑπÏ", - "Μαι", - "Ιουν", - "Ιουλ", - "Αυγ", - "Σεπ", - "Οκτ", - "Îοε", - "Δεκ"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Για το ημεÏολόγιο"; - -Calendar._TT["ABOUT"] = -"Επιλογέας ημεÏομηνίας/ÏŽÏας σε DHTML\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Για τελευταία έκδοση: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Επιλογή ημεÏομηνίας:\n" + -"- ΧÏησιμοποιείστε τα κουμπιά \xab, \xbb για επιλογή έτους\n" + -"- ΧÏησιμοποιείστε τα κουμπιά " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " για επιλογή μήνα\n" + -"- ΚÏατήστε κουμπί Ï€Î¿Î½Ï„Î¹ÎºÎ¿Ï Ï€Î±Ï„Î·Î¼Î­Î½Î¿ στα παÏαπάνω κουμπιά για πιο γÏήγοÏη επιλογή."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Επιλογή ÏŽÏας:\n" + -"- Κάντε κλικ σε ένα από τα μέÏη της ÏŽÏας για αÏξηση\n" + -"- ή Shift-κλικ για μείωση\n" + -"- ή κλικ και μετακίνηση για πιο γÏήγοÏη επιλογή."; -Calendar._TT["TOGGLE"] = "ΜπάÏα Ï€Ïώτης ημέÏας της εβδομάδας"; -Calendar._TT["PREV_YEAR"] = "ΠÏοηγ. έτος (κÏατήστε για το μενοÏ)"; -Calendar._TT["PREV_MONTH"] = "ΠÏοηγ. μήνας (κÏατήστε για το μενοÏ)"; -Calendar._TT["GO_TODAY"] = "ΣήμεÏα"; -Calendar._TT["NEXT_MONTH"] = "Επόμενος μήνας (κÏατήστε για το μενοÏ)"; -Calendar._TT["NEXT_YEAR"] = "Επόμενο έτος (κÏατήστε για το μενοÏ)"; -Calendar._TT["SEL_DATE"] = "Επιλέξτε ημεÏομηνία"; -Calendar._TT["DRAG_TO_MOVE"] = "ΣÏÏτε για να μετακινήσετε"; -Calendar._TT["PART_TODAY"] = " (σήμεÏα)"; -Calendar._TT["MON_FIRST"] = "Εμφάνιση ΔευτέÏας Ï€Ïώτα"; -Calendar._TT["SUN_FIRST"] = "Εμφάνιση ΚυÏιακής Ï€Ïώτα"; -Calendar._TT["CLOSE"] = "Κλείσιμο"; -Calendar._TT["TODAY"] = "ΣήμεÏα"; -Calendar._TT["TIME_PART"] = "(Shift-)κλικ ή μετακίνηση για αλλαγή"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "dd-mm-y"; -Calendar._TT["TT_DATE_FORMAT"] = "D, d M"; - -Calendar._TT["WK"] = "εβδ"; - diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-en.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-en.js deleted file mode 100644 index 0dbde793d8..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-en.js +++ /dev/null @@ -1,127 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Sunday", - "Monday", - "Tuesday", - "Wednesday", - "Thursday", - "Friday", - "Saturday", - "Sunday"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Sun", - "Mon", - "Tue", - "Wed", - "Thu", - "Fri", - "Sat", - "Sun"); - -// First day of the week. "0" means display Sunday first, "1" means display -// Monday first, etc. -Calendar._FD = 0; - -// full month names -Calendar._MN = new Array -("January", - "February", - "March", - "April", - "May", - "June", - "July", - "August", - "September", - "October", - "November", - "December"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "Mar", - "Apr", - "May", - "Jun", - "Jul", - "Aug", - "Sep", - "Oct", - "Nov", - "Dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "About the calendar"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Date selection:\n" + -"- Use the \xab, \xbb buttons to select year\n" + -"- Use the " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " buttons to select month\n" + -"- Hold mouse button on any of the above buttons for faster selection."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Time selection:\n" + -"- Click on any of the time parts to increase it\n" + -"- or Shift-click to decrease it\n" + -"- or click and drag for faster selection."; - -Calendar._TT["PREV_YEAR"] = "Prev. year (hold for menu)"; -Calendar._TT["PREV_MONTH"] = "Prev. month (hold for menu)"; -Calendar._TT["GO_TODAY"] = "Go Today"; -Calendar._TT["NEXT_MONTH"] = "Next month (hold for menu)"; -Calendar._TT["NEXT_YEAR"] = "Next year (hold for menu)"; -Calendar._TT["SEL_DATE"] = "Select date"; -Calendar._TT["DRAG_TO_MOVE"] = "Drag to move"; -Calendar._TT["PART_TODAY"] = " (today)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Display %s first"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Close"; -Calendar._TT["TODAY"] = "Today"; -Calendar._TT["TIME_PART"] = "(Shift-)Click or drag to change value"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "Time:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-es.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-es.js deleted file mode 100644 index 19c1b30bdc..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-es.js +++ /dev/null @@ -1,129 +0,0 @@ -// ** I18N - -// Calendar ES (spanish) language -// Author: Mihai Bazon, -// Updater: Servilio Afre Puentes -// Updated: 2004-06-03 -// Encoding: utf-8 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Domingo", - "Lunes", - "Martes", - "Miércoles", - "Jueves", - "Viernes", - "Sábado", - "Domingo"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Dom", - "Lun", - "Mar", - "Mié", - "Jue", - "Vie", - "Sáb", - "Dom"); - -// First day of the week. "0" means display Sunday first, "1" means display -// Monday first, etc. -Calendar._FD = 1; - -// full month names -Calendar._MN = new Array -("Enero", - "Febrero", - "Marzo", - "Abril", - "Mayo", - "Junio", - "Julio", - "Agosto", - "Septiembre", - "Octubre", - "Noviembre", - "Diciembre"); - -// short month names -Calendar._SMN = new Array -("Ene", - "Feb", - "Mar", - "Abr", - "May", - "Jun", - "Jul", - "Ago", - "Sep", - "Oct", - "Nov", - "Dic"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Acerca del calendario"; - -Calendar._TT["ABOUT"] = -"Selector DHTML de Fecha/Hora\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Para conseguir la última versión visite: http://www.dynarch.com/projects/calendar/\n" + -"Distribuido bajo licencia GNU LGPL. Visite http://gnu.org/licenses/lgpl.html para más detalles." + -"\n\n" + -"Selección de fecha:\n" + -"- Use los botones \xab, \xbb para seleccionar el año\n" + -"- Use los botones " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " para seleccionar el mes\n" + -"- Mantenga pulsado el ratón en cualquiera de estos botones para una selección rápida."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selección de hora:\n" + -"- Pulse en cualquiera de las partes de la hora para incrementarla\n" + -"- o pulse las mayúsculas mientras hace clic para decrementarla\n" + -"- o haga clic y arrastre el ratón para una selección más rápida."; - -Calendar._TT["PREV_YEAR"] = "Año anterior (mantener para menú)"; -Calendar._TT["PREV_MONTH"] = "Mes anterior (mantener para menú)"; -Calendar._TT["GO_TODAY"] = "Ir a hoy"; -Calendar._TT["NEXT_MONTH"] = "Mes siguiente (mantener para menú)"; -Calendar._TT["NEXT_YEAR"] = "Año siguiente (mantener para menú)"; -Calendar._TT["SEL_DATE"] = "Seleccionar fecha"; -Calendar._TT["DRAG_TO_MOVE"] = "Arrastrar para mover"; -Calendar._TT["PART_TODAY"] = " (hoy)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Hacer %s primer día de la semana"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Cerrar"; -Calendar._TT["TODAY"] = "Hoy"; -Calendar._TT["TIME_PART"] = "(Mayúscula-)Clic o arrastre para cambiar valor"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d/%m/%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %e de %B de %Y"; - -Calendar._TT["WK"] = "sem"; -Calendar._TT["TIME"] = "Hora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fi.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fi.js deleted file mode 100644 index 328eabb3bd..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fi.js +++ /dev/null @@ -1,98 +0,0 @@ -// ** I18N - -// Calendar FI language (Finnish, Suomi) -// Author: Jarno Käyhkö, -// Encoding: UTF-8 -// Distributed under the same terms as the calendar itself. - -// full day names -Calendar._DN = new Array -("Sunnuntai", - "Maanantai", - "Tiistai", - "Keskiviikko", - "Torstai", - "Perjantai", - "Lauantai", - "Sunnuntai"); - -// short day names -Calendar._SDN = new Array -("Su", - "Ma", - "Ti", - "Ke", - "To", - "Pe", - "La", - "Su"); - -// full month names -Calendar._MN = new Array -("Tammikuu", - "Helmikuu", - "Maaliskuu", - "Huhtikuu", - "Toukokuu", - "Kesäkuu", - "Heinäkuu", - "Elokuu", - "Syyskuu", - "Lokakuu", - "Marraskuu", - "Joulukuu"); - -// short month names -Calendar._SMN = new Array -("Tam", - "Hel", - "Maa", - "Huh", - "Tou", - "Kes", - "Hei", - "Elo", - "Syy", - "Lok", - "Mar", - "Jou"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Tietoja kalenterista"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Uusin versio osoitteessa: http://www.dynarch.com/projects/calendar/\n" + -"Julkaistu GNU LGPL lisenssin alaisuudessa. Lisätietoja osoitteessa http://gnu.org/licenses/lgpl.html" + -"\n\n" + -"Päivämäärä valinta:\n" + -"- Käytä \xab, \xbb painikkeita valitaksesi vuosi\n" + -"- Käytä " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " painikkeita valitaksesi kuukausi\n" + -"- Pitämällä hiiren painiketta minkä tahansa yllä olevan painikkeen kohdalla, saat näkyviin valikon nopeampaan siirtymiseen."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Ajan valinta:\n" + -"- Klikkaa kellonajan numeroita lisätäksesi aikaa\n" + -"- tai pitämällä Shift-näppäintä pohjassa saat aikaa taaksepäin\n" + -"- tai klikkaa ja pidä hiiren painike pohjassa sekä liikuta hiirtä muuttaaksesi aikaa nopeasti eteen- ja taaksepäin."; - -Calendar._TT["PREV_YEAR"] = "Edell. vuosi (paina hetki, näet valikon)"; -Calendar._TT["PREV_MONTH"] = "Edell. kuukausi (paina hetki, näet valikon)"; -Calendar._TT["GO_TODAY"] = "Siirry tähän päivään"; -Calendar._TT["NEXT_MONTH"] = "Seur. kuukausi (paina hetki, näet valikon)"; -Calendar._TT["NEXT_YEAR"] = "Seur. vuosi (paina hetki, näet valikon)"; -Calendar._TT["SEL_DATE"] = "Valitse päivämäärä"; -Calendar._TT["DRAG_TO_MOVE"] = "Siirrä kalenterin paikkaa"; -Calendar._TT["PART_TODAY"] = " (tänään)"; -Calendar._TT["MON_FIRST"] = "Näytä maanantai ensimmäisenä"; -Calendar._TT["SUN_FIRST"] = "Näytä sunnuntai ensimmäisenä"; -Calendar._TT["CLOSE"] = "Sulje"; -Calendar._TT["TODAY"] = "Tänään"; -Calendar._TT["TIME_PART"] = "(Shift-) Klikkaa tai liikuta muuttaaksesi aikaa"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d.%m.%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%d.%m.%Y"; - -Calendar._TT["WK"] = "Vko"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fr.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fr.js deleted file mode 100644 index 2a9e0b20bb..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-fr.js +++ /dev/null @@ -1,125 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// Translator: David Duret, from previous french version - -// full day names -Calendar._DN = new Array -("Dimanche", - "Lundi", - "Mardi", - "Mercredi", - "Jeudi", - "Vendredi", - "Samedi", - "Dimanche"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Dim", - "Lun", - "Mar", - "Mar", - "Jeu", - "Ven", - "Sam", - "Dim"); - -// full month names -Calendar._MN = new Array -("Janvier", - "Février", - "Mars", - "Avril", - "Mai", - "Juin", - "Juillet", - "Août", - "Septembre", - "Octobre", - "Novembre", - "Décembre"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Fev", - "Mar", - "Avr", - "Mai", - "Juin", - "Juil", - "Aout", - "Sep", - "Oct", - "Nov", - "Dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "A propos du calendrier"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Heure Selecteur\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Pour la derniere version visitez : http://www.dynarch.com/projects/calendar/\n" + -"Distribué par GNU LGPL. Voir http://gnu.org/licenses/lgpl.html pour les details." + -"\n\n" + -"Selection de la date :\n" + -"- Utiliser les bouttons \xab, \xbb pour selectionner l\'annee\n" + -"- Utiliser les bouttons " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " pour selectionner les mois\n" + -"- Garder la souris sur n'importe quels boutons pour une selection plus rapide"; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selection de l\'heure :\n" + -"- Cliquer sur heures ou minutes pour incrementer\n" + -"- ou Maj-clic pour decrementer\n" + -"- ou clic et glisser-deplacer pour une selection plus rapide"; - -Calendar._TT["PREV_YEAR"] = "Année préc. (maintenir pour menu)"; -Calendar._TT["PREV_MONTH"] = "Mois préc. (maintenir pour menu)"; -Calendar._TT["GO_TODAY"] = "Atteindre la date du jour"; -Calendar._TT["NEXT_MONTH"] = "Mois suiv. (maintenir pour menu)"; -Calendar._TT["NEXT_YEAR"] = "Année suiv. (maintenir pour menu)"; -Calendar._TT["SEL_DATE"] = "Sélectionner une date"; -Calendar._TT["DRAG_TO_MOVE"] = "Déplacer"; -Calendar._TT["PART_TODAY"] = " (Aujourd'hui)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Afficher %s en premier"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Fermer"; -Calendar._TT["TODAY"] = "Aujourd'hui"; -Calendar._TT["TIME_PART"] = "(Maj-)Clic ou glisser pour modifier la valeur"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d/%m/%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "Sem."; -Calendar._TT["TIME"] = "Heure :"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-he-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-he-utf8.js deleted file mode 100644 index 7861217bae..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-he-utf8.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Idan Sofer, -// Encoding: UTF-8 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("ר×שון", - "שני", - "שלישי", - "רביעי", - "חמישי", - "שישי", - "שבת", - "ר×שון"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("×", - "ב", - "×’", - "ד", - "×”", - "ו", - "ש", - "×"); - -// full month names -Calendar._MN = new Array -("ינו×ר", - "פברו×ר", - "מרץ", - "×פריל", - "מ××™", - "יוני", - "יולי", - "×וגוסט", - "ספטמבר", - "×וקטובר", - "נובמבר", - "דצמבר"); - -// short month names -Calendar._SMN = new Array -("×™× ×", - "פבר", - "מרץ", - "×פר", - "מ××™", - "יונ", - "יול", - "×וג", - "ספט", - "×וק", - "נוב", - "דצמ"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "×ודות השנתון"; - -Calendar._TT["ABOUT"] = -"בחרן ת×ריך/שעה DHTML\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"×”×’×™×¨×¡× ×”×חרונה זמינה ב: http://www.dynarch.com/projects/calendar/\n" + -"מופץ תחת זיכיון ×” GNU LGPL. עיין ב http://gnu.org/licenses/lgpl.html ×œ×¤×¨×˜×™× × ×•×¡×¤×™×." + -"\n\n" + -בחירת ת×ריך:\n" + -"- השתמש ×‘×›×¤×ª×•×¨×™× \xab, \xbb לבחירת שנה\n" + -"- השתמש ×‘×›×¤×ª×•×¨×™× " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " לבחירת חודש\n" + -"- החזק העכבר לחוץ מעל ×”×›×¤×ª×•×¨×™× ×”×ž×•×–×›×¨×™× ×œ×¢×™×œ לבחירה מהירה יותר."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"בחירת זמן:\n" + -"- לחץ על כל ×חד מחלקי הזמן כדי להוסיף\n" + -"- ×ו shift בשילוב ×¢× ×œ×—×™×¦×” כדי להחסיר\n" + -"- ×ו לחץ וגרור לפעולה מהירה יותר."; - -Calendar._TT["PREV_YEAR"] = "שנה קודמת - החזק לקבלת תפריט"; -Calendar._TT["PREV_MONTH"] = "חודש ×§×•×“× - החזק לקבלת תפריט"; -Calendar._TT["GO_TODAY"] = "עבור להיו×"; -Calendar._TT["NEXT_MONTH"] = "חודש ×”×‘× - החזק לתפריט"; -Calendar._TT["NEXT_YEAR"] = "שנה הב××” - החזק לתפריט"; -Calendar._TT["SEL_DATE"] = "בחר ת×ריך"; -Calendar._TT["DRAG_TO_MOVE"] = "גרור להזזה"; -Calendar._TT["PART_TODAY"] = " )היו×("; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "הצג %s קוד×"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "6"; - -Calendar._TT["CLOSE"] = "סגור"; -Calendar._TT["TODAY"] = "היו×"; -Calendar._TT["TIME_PART"] = "(שיפט-)לחץ וגרור כדי לשנות ערך"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "שעה::"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr-utf8.js deleted file mode 100644 index d569cfd924..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr-utf8.js +++ /dev/null @@ -1,49 +0,0 @@ -/* Croatian language file for the DHTML Calendar version 0.9.2 -* Author Krunoslav Zubrinic , June 2003. -* Feel free to use this script under the terms of the GNU Lesser General -* Public License, as long as you do not remove or alter this notice. -*/ -Calendar._DN = new Array -("Nedjelja", - "Ponedjeljak", - "Utorak", - "Srijeda", - "ÄŒetvrtak", - "Petak", - "Subota", - "Nedjelja"); -Calendar._MN = new Array -("SijeÄanj", - "VeljaÄa", - "Ožujak", - "Travanj", - "Svibanj", - "Lipanj", - "Srpanj", - "Kolovoz", - "Rujan", - "Listopad", - "Studeni", - "Prosinac"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["TOGGLE"] = "Promjeni dan s kojim poÄinje tjedan"; -Calendar._TT["PREV_YEAR"] = "Prethodna godina (dugi pritisak za meni)"; -Calendar._TT["PREV_MONTH"] = "Prethodni mjesec (dugi pritisak za meni)"; -Calendar._TT["GO_TODAY"] = "Idi na tekući dan"; -Calendar._TT["NEXT_MONTH"] = "Slijedeći mjesec (dugi pritisak za meni)"; -Calendar._TT["NEXT_YEAR"] = "Slijedeća godina (dugi pritisak za meni)"; -Calendar._TT["SEL_DATE"] = "Izaberite datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Pritisni i povuci za promjenu pozicije"; -Calendar._TT["PART_TODAY"] = " (today)"; -Calendar._TT["MON_FIRST"] = "Prikaži ponedjeljak kao prvi dan"; -Calendar._TT["SUN_FIRST"] = "Prikaži nedjelju kao prvi dan"; -Calendar._TT["CLOSE"] = "Zatvori"; -Calendar._TT["TODAY"] = "Danas"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "dd-mm-y"; -Calendar._TT["TT_DATE_FORMAT"] = "DD, dd.mm.y"; - -Calendar._TT["WK"] = "Tje"; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-hr.js deleted file mode 100644 index 6c27f60c4f8d416145e316bdb92e455a04a26fc4..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 3088 zcmcJRZEq4$5QV3oOpN^xn|@MLX``QvFOd|BwX`K&TD8VBv|!x=g_MG!Mt{2coVhHp zKpTvj4cxc6GiS~{b9aCJT(gH3*@j(O+p2bD3I7+&G`&5u9_^Xcnfc6GbJ%NRA7TB) z#|3+172C0rd#bwCh1J+8t3EcD)@66wJ+E8Np7MLl+OpmC_<7>UTkyM$eGl6lj3p>PheZ0=Ww2=H?b(l|o^zMwpyIsrK|Sp&cKx5sS&@!9bLPe8y!ma|m&W@1t~03i zVNK_Gk(rhME=;!FTP?E|GvDK^rJ*FVQYO0UUUgnYdn=YQt!h}~kw)7*(yTJ*-gpib zZl$2fZ}$C`^OD_1B2{e9iaaHI&FIr`ue2#lE!UXvs;0s%sav4I+Bvf=`W^bqOTsRd z3#r;*y|Ms;vh5T5kb3$+n`bnQL#ow1S#y3O?q>A^Tan$T-(yY~JD^USqb_J0%v{q( z;0&xk!1v7>PB|GP+JT*2IC^s{CPfZR>2^A0^zShhL2~S;Re+-p89ZCghHfF{s#~oA zBX>BH^wbu~dKdQJ6XBS*+Pth|)R*2l^`ZCwo%I;gJZ(%PQuhB_8!;@E{O-@gRkmif zTx}=tA5^GnP#vi5TMH?#fco=PV>sz>5{FY!RGF#9LuCf#>z3-FK8=FvRSn}B)_YO4 zdX0swRHcjPqU<#(UFfcuRiD(Z+ew)YxVaYb85DMGo3=&9F`lPuK0(7(ZvHg4+4rPw zp(=4h)$5DrPt+dsC9+FSiy_EH7n6SzdjkdSk#$x*N3ImTX>`7eusHub3i#1Y&>i_0 zzeR!?rOVGAr{ytkf1BtnQ2^`agzClH9w)bhHnL||LkEvgdyD_U2*JFsr}VZ}t8b}L hPd9rmV52WTMaX%C+(ZQBcw3Zrwhfx``>it4|8LNz+ -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Vasárnap", - "Hétfõ", - "Kedd", - "Szerda", - "Csütörtök", - "Péntek", - "Szombat", - "Vasárnap"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("v", - "h", - "k", - "sze", - "cs", - "p", - "szo", - "v"); - -// full month names -Calendar._MN = new Array -("január", - "február", - "március", - "április", - "május", - "június", - "július", - "augusztus", - "szeptember", - "október", - "november", - "december"); - -// short month names -Calendar._SMN = new Array -("jan", - "feb", - "már", - "ápr", - "máj", - "jún", - "júl", - "aug", - "sze", - "okt", - "nov", - "dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "A kalendáriumról"; - -Calendar._TT["ABOUT"] = -"DHTML dátum/idõ kiválasztó\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"a legfrissebb verzió megtalálható: http://www.dynarch.com/projects/calendar/\n" + -"GNU LGPL alatt terjesztve. Lásd a http://gnu.org/licenses/lgpl.html oldalt a részletekhez." + -"\n\n" + -"Dátum választás:\n" + -"- használja a \xab, \xbb gombokat az év kiválasztásához\n" + -"- használja a " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " gombokat a hónap kiválasztásához\n" + -"- tartsa lenyomva az egérgombot a gyors választáshoz."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Idõ választás:\n" + -"- kattintva növelheti az idõt\n" + -"- shift-tel kattintva csökkentheti\n" + -"- lenyomva tartva és húzva gyorsabban kiválaszthatja."; - -Calendar._TT["PREV_YEAR"] = "Elõzõ év (tartsa nyomva a menühöz)"; -Calendar._TT["PREV_MONTH"] = "Elõzõ hónap (tartsa nyomva a menühöz)"; -Calendar._TT["GO_TODAY"] = "Mai napra ugrás"; -Calendar._TT["NEXT_MONTH"] = "Köv. hónap (tartsa nyomva a menühöz)"; -Calendar._TT["NEXT_YEAR"] = "Köv. év (tartsa nyomva a menühöz)"; -Calendar._TT["SEL_DATE"] = "Válasszon dátumot"; -Calendar._TT["DRAG_TO_MOVE"] = "Húzza a mozgatáshoz"; -Calendar._TT["PART_TODAY"] = " (ma)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "%s legyen a hét elsõ napja"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Bezár"; -Calendar._TT["TODAY"] = "Ma"; -Calendar._TT["TIME_PART"] = "(Shift-)Klikk vagy húzás az érték változtatásához"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%b %e, %a"; - -Calendar._TT["WK"] = "hét"; -Calendar._TT["TIME"] = "idõ:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-it.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-it.js deleted file mode 100644 index 7f84cde01f..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-it.js +++ /dev/null @@ -1,124 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Translator: Fabio Di Bernardini, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Domenica", - "Lunedì", - "Martedì", - "Mercoledì", - "Giovedì", - "Venerdì", - "Sabato", - "Domenica"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Dom", - "Lun", - "Mar", - "Mer", - "Gio", - "Ven", - "Sab", - "Dom"); - -// full month names -Calendar._MN = new Array -("Gennaio", - "Febbraio", - "Marzo", - "Aprile", - "Maggio", - "Giugno", - "Luglio", - "Augosto", - "Settembre", - "Ottobre", - "Novembre", - "Dicembre"); - -// short month names -Calendar._SMN = new Array -("Gen", - "Feb", - "Mar", - "Apr", - "Mag", - "Giu", - "Lug", - "Ago", - "Set", - "Ott", - "Nov", - "Dic"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Informazioni sul calendario"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Per gli aggiornamenti: http://www.dynarch.com/projects/calendar/\n" + -"Distribuito sotto licenza GNU LGPL. Vedi http://gnu.org/licenses/lgpl.html per i dettagli." + -"\n\n" + -"Selezione data:\n" + -"- Usa \xab, \xbb per selezionare l'anno\n" + -"- Usa " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " per i mesi\n" + -"- Tieni premuto a lungo il mouse per accedere alle funzioni di selezione veloce."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selezione orario:\n" + -"- Clicca sul numero per incrementarlo\n" + -"- o Shift+click per decrementarlo\n" + -"- o click e sinistra o destra per variarlo."; - -Calendar._TT["PREV_YEAR"] = "Anno prec.(clicca a lungo per il menù)"; -Calendar._TT["PREV_MONTH"] = "Mese prec. (clicca a lungo per il menù)"; -Calendar._TT["GO_TODAY"] = "Oggi"; -Calendar._TT["NEXT_MONTH"] = "Pross. mese (clicca a lungo per il menù)"; -Calendar._TT["NEXT_YEAR"] = "Pross. anno (clicca a lungo per il menù)"; -Calendar._TT["SEL_DATE"] = "Seleziona data"; -Calendar._TT["DRAG_TO_MOVE"] = "Trascina per spostarlo"; -Calendar._TT["PART_TODAY"] = " (oggi)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Mostra prima %s"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Chiudi"; -Calendar._TT["TODAY"] = "Oggi"; -Calendar._TT["TIME_PART"] = "(Shift-)Click o trascina per cambiare il valore"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d-%m-%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a:%b:%e"; - -Calendar._TT["WK"] = "set"; -Calendar._TT["TIME"] = "Ora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-jp.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-jp.js deleted file mode 100644 index 3bca7ebf60..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-jp.js +++ /dev/null @@ -1,45 +0,0 @@ -// ** I18N -Calendar._DN = new Array -("“ú", - "ŒŽ", - "‰Î", - "…", - "–Ø", - "‹à", - "“y", - "“ú"); -Calendar._MN = new Array -("1ŒŽ", - "2ŒŽ", - "3ŒŽ", - "4ŒŽ", - "5ŒŽ", - "6ŒŽ", - "7ŒŽ", - "8ŒŽ", - "9ŒŽ", - "10ŒŽ", - "11ŒŽ", - "12ŒŽ"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["TOGGLE"] = "T‚Ìʼn‚Ì—j“ú‚ðØ‚è‘Ö‚¦"; -Calendar._TT["PREV_YEAR"] = "‘O”N"; -Calendar._TT["PREV_MONTH"] = "‘OŒŽ"; -Calendar._TT["GO_TODAY"] = "¡“ú"; -Calendar._TT["NEXT_MONTH"] = "—‚ŒŽ"; -Calendar._TT["NEXT_YEAR"] = "—‚”N"; -Calendar._TT["SEL_DATE"] = "“ú•t‘I‘ð"; -Calendar._TT["DRAG_TO_MOVE"] = "ƒEƒBƒ“ƒhƒE‚̈ړ®"; -Calendar._TT["PART_TODAY"] = " (¡“ú)"; -Calendar._TT["MON_FIRST"] = "ŒŽ—j“ú‚ð擪‚É"; -Calendar._TT["SUN_FIRST"] = "“ú—j“ú‚ð擪‚É"; -Calendar._TT["CLOSE"] = "•Â‚¶‚é"; -Calendar._TT["TODAY"] = "¡“ú"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "y-mm-dd"; -Calendar._TT["TT_DATE_FORMAT"] = "%mŒŽ %d“ú (%a)"; - -Calendar._TT["WK"] = "T"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko-utf8.js deleted file mode 100644 index 035dd748d3..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko-utf8.js +++ /dev/null @@ -1,120 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Translation: Yourim Yi -// Encoding: EUC-KR -// lang : ko -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names - -Calendar._DN = new Array -("ì¼ìš”ì¼", - "월요ì¼", - "화요ì¼", - "수요ì¼", - "목요ì¼", - "금요ì¼", - "토요ì¼", - "ì¼ìš”ì¼"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("ì¼", - "ì›”", - "í™”", - "수", - "목", - "금", - "토", - "ì¼"); - -// full month names -Calendar._MN = new Array -("1ì›”", - "2ì›”", - "3ì›”", - "4ì›”", - "5ì›”", - "6ì›”", - "7ì›”", - "8ì›”", - "9ì›”", - "10ì›”", - "11ì›”", - "12ì›”"); - -// short month names -Calendar._SMN = new Array -("1", - "2", - "3", - "4", - "5", - "6", - "7", - "8", - "9", - "10", - "11", - "12"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "calendar ì— ëŒ€í•´ì„œ"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"\n"+ -"최신 ë²„ì „ì„ ë°›ìœ¼ì‹œë ¤ë©´ http://www.dynarch.com/projects/calendar/ ì— ë°©ë¬¸í•˜ì„¸ìš”\n" + -"\n"+ -"GNU LGPL ë¼ì´ì„¼ìŠ¤ë¡œ ë°°í¬ë©ë‹ˆë‹¤. \n"+ -"ë¼ì´ì„¼ìŠ¤ì— 대한 ìžì„¸í•œ ë‚´ìš©ì€ http://gnu.org/licenses/lgpl.html ì„ ì½ìœ¼ì„¸ìš”." + -"\n\n" + -"날짜 ì„ íƒ:\n" + -"- ì—°ë„를 ì„ íƒí•˜ë ¤ë©´ \xab, \xbb ë²„íŠ¼ì„ ì‚¬ìš©í•©ë‹ˆë‹¤\n" + -"- ë‹¬ì„ ì„ íƒí•˜ë ¤ë©´ " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " ë²„íŠ¼ì„ ëˆ„ë¥´ì„¸ìš”\n" + -"- ê³„ì† ëˆ„ë¥´ê³  있으면 위 ê°’ë“¤ì„ ë¹ ë¥´ê²Œ ì„ íƒí•˜ì‹¤ 수 있습니다."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"시간 ì„ íƒ:\n" + -"- 마우스로 누르면 ì‹œê°„ì´ ì¦ê°€í•©ë‹ˆë‹¤\n" + -"- Shift 키와 함께 누르면 ê°ì†Œí•©ë‹ˆë‹¤\n" + -"- 누른 ìƒíƒœì—ì„œ 마우스를 움ì§ì´ë©´ 좀 ë” ë¹ ë¥´ê²Œ ê°’ì´ ë³€í•©ë‹ˆë‹¤.\n"; - -Calendar._TT["PREV_YEAR"] = "지난 í•´ (길게 누르면 목ë¡)"; -Calendar._TT["PREV_MONTH"] = "지난 달 (길게 누르면 목ë¡)"; -Calendar._TT["GO_TODAY"] = "오늘 날짜로"; -Calendar._TT["NEXT_MONTH"] = "ë‹¤ìŒ ë‹¬ (길게 누르면 목ë¡)"; -Calendar._TT["NEXT_YEAR"] = "ë‹¤ìŒ í•´ (길게 누르면 목ë¡)"; -Calendar._TT["SEL_DATE"] = "날짜를 ì„ íƒí•˜ì„¸ìš”"; -Calendar._TT["DRAG_TO_MOVE"] = "마우스 드래그로 ì´ë™ 하세요"; -Calendar._TT["PART_TODAY"] = " (오늘)"; -Calendar._TT["MON_FIRST"] = "월요ì¼ì„ í•œ ì£¼ì˜ ì‹œìž‘ ìš”ì¼ë¡œ"; -Calendar._TT["SUN_FIRST"] = "ì¼ìš”ì¼ì„ í•œ ì£¼ì˜ ì‹œìž‘ ìš”ì¼ë¡œ"; -Calendar._TT["CLOSE"] = "닫기"; -Calendar._TT["TODAY"] = "오늘"; -Calendar._TT["TIME_PART"] = "(Shift-)í´ë¦­ ë˜ëŠ” 드래그 하세요"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%b/%e [%a]"; - -Calendar._TT["WK"] = "주"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko.js deleted file mode 100644 index 8cddf58645..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ko.js +++ /dev/null @@ -1,120 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Translation: Yourim Yi -// Encoding: EUC-KR -// lang : ko -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names - -Calendar._DN = new Array -("ÀÏ¿äÀÏ", - "¿ù¿äÀÏ", - "È­¿äÀÏ", - "¼ö¿äÀÏ", - "¸ñ¿äÀÏ", - "±Ý¿äÀÏ", - "Åä¿äÀÏ", - "ÀÏ¿äÀÏ"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("ÀÏ", - "¿ù", - "È­", - "¼ö", - "¸ñ", - "±Ý", - "Åä", - "ÀÏ"); - -// full month names -Calendar._MN = new Array -("1¿ù", - "2¿ù", - "3¿ù", - "4¿ù", - "5¿ù", - "6¿ù", - "7¿ù", - "8¿ù", - "9¿ù", - "10¿ù", - "11¿ù", - "12¿ù"); - -// short month names -Calendar._SMN = new Array -("1", - "2", - "3", - "4", - "5", - "6", - "7", - "8", - "9", - "10", - "11", - "12"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "calendar ¿¡ ´ëÇؼ­"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"\n"+ -"ÃֽŠ¹öÀüÀ» ¹ÞÀ¸½Ã·Á¸é http://www.dynarch.com/projects/calendar/ ¿¡ ¹æ¹®Çϼ¼¿ä\n" + -"\n"+ -"GNU LGPL ¶óÀ̼¾½º·Î ¹èÆ÷µË´Ï´Ù. \n"+ -"¶óÀ̼¾½º¿¡ ´ëÇÑ ÀÚ¼¼ÇÑ ³»¿ëÀº http://gnu.org/licenses/lgpl.html À» ÀÐÀ¸¼¼¿ä." + -"\n\n" + -"³¯Â¥ ¼±ÅÃ:\n" + -"- ¿¬µµ¸¦ ¼±ÅÃÇÏ·Á¸é \xab, \xbb ¹öÆ°À» »ç¿ëÇÕ´Ï´Ù\n" + -"- ´ÞÀ» ¼±ÅÃÇÏ·Á¸é " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " ¹öÆ°À» ´©¸£¼¼¿ä\n" + -"- °è¼Ó ´©¸£°í ÀÖÀ¸¸é À§ °ªµéÀ» ºü¸£°Ô ¼±ÅÃÇÏ½Ç ¼ö ÀÖ½À´Ï´Ù."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"½Ã°£ ¼±ÅÃ:\n" + -"- ¸¶¿ì½º·Î ´©¸£¸é ½Ã°£ÀÌ Áõ°¡ÇÕ´Ï´Ù\n" + -"- Shift Å°¿Í ÇÔ²² ´©¸£¸é °¨¼ÒÇÕ´Ï´Ù\n" + -"- ´©¸¥ »óÅ¿¡¼­ ¸¶¿ì½º¸¦ ¿òÁ÷À̸é Á» ´õ ºü¸£°Ô °ªÀÌ º¯ÇÕ´Ï´Ù.\n"; - -Calendar._TT["PREV_YEAR"] = "Áö³­ ÇØ (±æ°Ô ´©¸£¸é ¸ñ·Ï)"; -Calendar._TT["PREV_MONTH"] = "Áö³­ ´Þ (±æ°Ô ´©¸£¸é ¸ñ·Ï)"; -Calendar._TT["GO_TODAY"] = "¿À´Ã ³¯Â¥·Î"; -Calendar._TT["NEXT_MONTH"] = "´ÙÀ½ ´Þ (±æ°Ô ´©¸£¸é ¸ñ·Ï)"; -Calendar._TT["NEXT_YEAR"] = "´ÙÀ½ ÇØ (±æ°Ô ´©¸£¸é ¸ñ·Ï)"; -Calendar._TT["SEL_DATE"] = "³¯Â¥¸¦ ¼±ÅÃÇϼ¼¿ä"; -Calendar._TT["DRAG_TO_MOVE"] = "¸¶¿ì½º µå·¡±×·Î À̵¿ Çϼ¼¿ä"; -Calendar._TT["PART_TODAY"] = " (¿À´Ã)"; -Calendar._TT["MON_FIRST"] = "¿ù¿äÀÏÀ» ÇÑ ÁÖÀÇ ½ÃÀÛ ¿äÀÏ·Î"; -Calendar._TT["SUN_FIRST"] = "ÀÏ¿äÀÏÀ» ÇÑ ÁÖÀÇ ½ÃÀÛ ¿äÀÏ·Î"; -Calendar._TT["CLOSE"] = "´Ý±â"; -Calendar._TT["TODAY"] = "¿À´Ã"; -Calendar._TT["TIME_PART"] = "(Shift-)Ŭ¸¯ ¶Ç´Â µå·¡±× Çϼ¼¿ä"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%b/%e [%a]"; - -Calendar._TT["WK"] = "ÁÖ"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt-utf8.js deleted file mode 100644 index d39653be27..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt-utf8.js +++ /dev/null @@ -1,114 +0,0 @@ -// ** I18N - -// Calendar LT language -// Author: Martynas Majeris, -// Encoding: UTF-8 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Sekmadienis", - "Pirmadienis", - "Antradienis", - "TreÄiadienis", - "Ketvirtadienis", - "Pentadienis", - "Å eÅ¡tadienis", - "Sekmadienis"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Sek", - "Pir", - "Ant", - "Tre", - "Ket", - "Pen", - "Å eÅ¡", - "Sek"); - -// full month names -Calendar._MN = new Array -("Sausis", - "Vasaris", - "Kovas", - "Balandis", - "Gegužė", - "Birželis", - "Liepa", - "RugpjÅ«tis", - "RugsÄ—jis", - "Spalis", - "Lapkritis", - "Gruodis"); - -// short month names -Calendar._SMN = new Array -("Sau", - "Vas", - "Kov", - "Bal", - "Geg", - "Bir", - "Lie", - "Rgp", - "Rgs", - "Spa", - "Lap", - "Gru"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Apie kalendorių"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"NaujausiÄ… versijÄ… rasite: http://www.dynarch.com/projects/calendar/\n" + -"Platinamas pagal GNU LGPL licencijÄ…. Aplankykite http://gnu.org/licenses/lgpl.html" + -"\n\n" + -"Datos pasirinkimas:\n" + -"- Metų pasirinkimas: \xab, \xbb\n" + -"- MÄ—nesio pasirinkimas: " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + "\n" + -"- Nuspauskite ir laikykite pelÄ—s klaviÅ¡Ä… greitesniam pasirinkimui."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Laiko pasirinkimas:\n" + -"- Spustelkite ant valandų arba minuÄių - skaiÄius padidÄ—s vienetu.\n" + -"- Jei spausite kartu su Shift, skaiÄius sumažės.\n" + -"- Greitam pasirinkimui spustelkite ir pajudinkite pelÄ™."; - -Calendar._TT["PREV_YEAR"] = "Ankstesni metai (laikykite, jei norite meniu)"; -Calendar._TT["PREV_MONTH"] = "Ankstesnis mÄ—nuo (laikykite, jei norite meniu)"; -Calendar._TT["GO_TODAY"] = "Pasirinkti Å¡iandienÄ…"; -Calendar._TT["NEXT_MONTH"] = "Kitas mÄ—nuo (laikykite, jei norite meniu)"; -Calendar._TT["NEXT_YEAR"] = "Kiti metai (laikykite, jei norite meniu)"; -Calendar._TT["SEL_DATE"] = "Pasirinkite datÄ…"; -Calendar._TT["DRAG_TO_MOVE"] = "Tempkite"; -Calendar._TT["PART_TODAY"] = " (Å¡iandien)"; -Calendar._TT["MON_FIRST"] = "Pirma savaitÄ—s diena - pirmadienis"; -Calendar._TT["SUN_FIRST"] = "Pirma savaitÄ—s diena - sekmadienis"; -Calendar._TT["CLOSE"] = "Uždaryti"; -Calendar._TT["TODAY"] = "Å iandien"; -Calendar._TT["TIME_PART"] = "Spustelkite arba tempkite jei norite pakeisti"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %Y-%m-%d"; - -Calendar._TT["WK"] = "sav"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt.js deleted file mode 100644 index 43b93d6810..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lt.js +++ /dev/null @@ -1,114 +0,0 @@ -// ** I18N - -// Calendar LT language -// Author: Martynas Majeris, -// Encoding: Windows-1257 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Sekmadienis", - "Pirmadienis", - "Antradienis", - "Treèiadienis", - "Ketvirtadienis", - "Pentadienis", - "Ðeðtadienis", - "Sekmadienis"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Sek", - "Pir", - "Ant", - "Tre", - "Ket", - "Pen", - "Ðeð", - "Sek"); - -// full month names -Calendar._MN = new Array -("Sausis", - "Vasaris", - "Kovas", - "Balandis", - "Geguþë", - "Birþelis", - "Liepa", - "Rugpjûtis", - "Rugsëjis", - "Spalis", - "Lapkritis", - "Gruodis"); - -// short month names -Calendar._SMN = new Array -("Sau", - "Vas", - "Kov", - "Bal", - "Geg", - "Bir", - "Lie", - "Rgp", - "Rgs", - "Spa", - "Lap", - "Gru"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Apie kalendoriø"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Naujausià versijà rasite: http://www.dynarch.com/projects/calendar/\n" + -"Platinamas pagal GNU LGPL licencijà. Aplankykite http://gnu.org/licenses/lgpl.html" + -"\n\n" + -"Datos pasirinkimas:\n" + -"- Metø pasirinkimas: \xab, \xbb\n" + -"- Mënesio pasirinkimas: " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + "\n" + -"- Nuspauskite ir laikykite pelës klaviðà greitesniam pasirinkimui."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Laiko pasirinkimas:\n" + -"- Spustelkite ant valandø arba minuèiø - skaièus padidës vienetu.\n" + -"- Jei spausite kartu su Shift, skaièius sumaþës.\n" + -"- Greitam pasirinkimui spustelkite ir pajudinkite pelæ."; - -Calendar._TT["PREV_YEAR"] = "Ankstesni metai (laikykite, jei norite meniu)"; -Calendar._TT["PREV_MONTH"] = "Ankstesnis mënuo (laikykite, jei norite meniu)"; -Calendar._TT["GO_TODAY"] = "Pasirinkti ðiandienà"; -Calendar._TT["NEXT_MONTH"] = "Kitas mënuo (laikykite, jei norite meniu)"; -Calendar._TT["NEXT_YEAR"] = "Kiti metai (laikykite, jei norite meniu)"; -Calendar._TT["SEL_DATE"] = "Pasirinkite datà"; -Calendar._TT["DRAG_TO_MOVE"] = "Tempkite"; -Calendar._TT["PART_TODAY"] = " (ðiandien)"; -Calendar._TT["MON_FIRST"] = "Pirma savaitës diena - pirmadienis"; -Calendar._TT["SUN_FIRST"] = "Pirma savaitës diena - sekmadienis"; -Calendar._TT["CLOSE"] = "Uþdaryti"; -Calendar._TT["TODAY"] = "Ðiandien"; -Calendar._TT["TIME_PART"] = "Spustelkite arba tempkite jei norite pakeisti"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %Y-%m-%d"; - -Calendar._TT["WK"] = "sav"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lv.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lv.js deleted file mode 100644 index 407699d36d..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-lv.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar LV language -// Author: Juris Valdovskis, -// Encoding: cp1257 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Svçtdiena", - "Pirmdiena", - "Otrdiena", - "Treðdiena", - "Ceturdiena", - "Piektdiena", - "Sestdiena", - "Svçtdiena"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Sv", - "Pr", - "Ot", - "Tr", - "Ce", - "Pk", - "Se", - "Sv"); - -// full month names -Calendar._MN = new Array -("Janvâris", - "Februâris", - "Marts", - "Aprîlis", - "Maijs", - "Jûnijs", - "Jûlijs", - "Augusts", - "Septembris", - "Oktobris", - "Novembris", - "Decembris"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "Mar", - "Apr", - "Mai", - "Jûn", - "Jûl", - "Aug", - "Sep", - "Okt", - "Nov", - "Dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Par kalendâru"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Datuma izvçle:\n" + -"- Izmanto \xab, \xbb pogas, lai izvçlçtos gadu\n" + -"- Izmanto " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + "pogas, lai izvçlçtos mçnesi\n" + -"- Turi nospiestu peles pogu uz jebkuru no augstâk minçtajâm pogâm, lai paâtrinâtu izvçli."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Laika izvçle:\n" + -"- Uzklikðíini uz jebkuru no laika daïâm, lai palielinâtu to\n" + -"- vai Shift-klikðíis, lai samazinâtu to\n" + -"- vai noklikðíini un velc uz attiecîgo virzienu lai mainîtu âtrâk."; - -Calendar._TT["PREV_YEAR"] = "Iepr. gads (turi izvçlnei)"; -Calendar._TT["PREV_MONTH"] = "Iepr. mçnesis (turi izvçlnei)"; -Calendar._TT["GO_TODAY"] = "Ðodien"; -Calendar._TT["NEXT_MONTH"] = "Nâkoðais mçnesis (turi izvçlnei)"; -Calendar._TT["NEXT_YEAR"] = "Nâkoðais gads (turi izvçlnei)"; -Calendar._TT["SEL_DATE"] = "Izvçlies datumu"; -Calendar._TT["DRAG_TO_MOVE"] = "Velc, lai pârvietotu"; -Calendar._TT["PART_TODAY"] = " (ðodien)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Attçlot %s kâ pirmo"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "1,7"; - -Calendar._TT["CLOSE"] = "Aizvçrt"; -Calendar._TT["TODAY"] = "Ðodien"; -Calendar._TT["TIME_PART"] = "(Shift-)Klikðíis vai pârvieto, lai mainîtu"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d-%m-%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %e %b"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "Laiks:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-nl.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-nl.js deleted file mode 100644 index a1dea94bdb..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-nl.js +++ /dev/null @@ -1,73 +0,0 @@ -// ** I18N -Calendar._DN = new Array -("Zondag", - "Maandag", - "Dinsdag", - "Woensdag", - "Donderdag", - "Vrijdag", - "Zaterdag", - "Zondag"); - -Calendar._SDN_len = 2; - -Calendar._MN = new Array -("Januari", - "Februari", - "Maart", - "April", - "Mei", - "Juni", - "Juli", - "Augustus", - "September", - "Oktober", - "November", - "December"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Info"; - -Calendar._TT["ABOUT"] = -"DHTML Datum/Tijd Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + -"Ga voor de meest recente versie naar: http://www.dynarch.com/projects/calendar/\n" + -"Verspreid onder de GNU LGPL. Zie http://gnu.org/licenses/lgpl.html voor details." + -"\n\n" + -"Datum selectie:\n" + -"- Gebruik de \xab \xbb knoppen om een jaar te selecteren\n" + -"- Gebruik de " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " knoppen om een maand te selecteren\n" + -"- Houd de muis ingedrukt op de genoemde knoppen voor een snellere selectie."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Tijd selectie:\n" + -"- Klik op een willekeurig onderdeel van het tijd gedeelte om het te verhogen\n" + -"- of Shift-klik om het te verlagen\n" + -"- of klik en sleep voor een snellere selectie."; - -//Calendar._TT["TOGGLE"] = "Selecteer de eerste week-dag"; -Calendar._TT["PREV_YEAR"] = "Vorig jaar (ingedrukt voor menu)"; -Calendar._TT["PREV_MONTH"] = "Vorige maand (ingedrukt voor menu)"; -Calendar._TT["GO_TODAY"] = "Ga naar Vandaag"; -Calendar._TT["NEXT_MONTH"] = "Volgende maand (ingedrukt voor menu)"; -Calendar._TT["NEXT_YEAR"] = "Volgend jaar (ingedrukt voor menu)"; -Calendar._TT["SEL_DATE"] = "Selecteer datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Klik en sleep om te verplaatsen"; -Calendar._TT["PART_TODAY"] = " (vandaag)"; -//Calendar._TT["MON_FIRST"] = "Toon Maandag eerst"; -//Calendar._TT["SUN_FIRST"] = "Toon Zondag eerst"; - -Calendar._TT["DAY_FIRST"] = "Toon %s eerst"; - -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Sluiten"; -Calendar._TT["TODAY"] = "(vandaag)"; -Calendar._TT["TIME_PART"] = "(Shift-)Klik of sleep om de waarde te veranderen"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d-%m-%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %e %b %Y"; - -Calendar._TT["WK"] = "wk"; -Calendar._TT["TIME"] = "Tijd:"; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-no.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-no.js deleted file mode 100644 index d9297d179a..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-no.js +++ /dev/null @@ -1,114 +0,0 @@ -// ** I18N - -// Calendar NO language -// Author: Daniel Holmen, -// Encoding: UTF-8 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Søndag", - "Mandag", - "Tirsdag", - "Onsdag", - "Torsdag", - "Fredag", - "Lørdag", - "Søndag"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Søn", - "Man", - "Tir", - "Ons", - "Tor", - "Fre", - "Lør", - "Søn"); - -// full month names -Calendar._MN = new Array -("Januar", - "Februar", - "Mars", - "April", - "Mai", - "Juni", - "Juli", - "August", - "September", - "Oktober", - "November", - "Desember"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "Mar", - "Apr", - "Mai", - "Jun", - "Jul", - "Aug", - "Sep", - "Okt", - "Nov", - "Des"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Om kalenderen"; - -Calendar._TT["ABOUT"] = -"DHTML Dato-/Tidsvelger\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For nyeste versjon, gÃ¥ til: http://www.dynarch.com/projects/calendar/\n" + -"Distribuert under GNU LGPL. Se http://gnu.org/licenses/lgpl.html for detaljer." + -"\n\n" + -"Datovalg:\n" + -"- Bruk knappene \xab og \xbb for Ã¥ velge Ã¥r\n" + -"- Bruk knappene " + String.fromCharCode(0x2039) + " og " + String.fromCharCode(0x203a) + " for Ã¥ velge mÃ¥ned\n" + -"- Hold inne musknappen eller knappene over for raskere valg."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Tidsvalg:\n" + -"- Klikk pÃ¥ en av tidsdelene for Ã¥ øke den\n" + -"- eller Shift-klikk for Ã¥ senke verdien\n" + -"- eller klikk-og-dra for raskere valg.."; - -Calendar._TT["PREV_YEAR"] = "Forrige. Ã¥r (hold for meny)"; -Calendar._TT["PREV_MONTH"] = "Forrige. mÃ¥ned (hold for meny)"; -Calendar._TT["GO_TODAY"] = "GÃ¥ til idag"; -Calendar._TT["NEXT_MONTH"] = "Neste mÃ¥ned (hold for meny)"; -Calendar._TT["NEXT_YEAR"] = "Neste Ã¥r (hold for meny)"; -Calendar._TT["SEL_DATE"] = "Velg dato"; -Calendar._TT["DRAG_TO_MOVE"] = "Dra for Ã¥ flytte"; -Calendar._TT["PART_TODAY"] = " (idag)"; -Calendar._TT["MON_FIRST"] = "Vis mandag først"; -Calendar._TT["SUN_FIRST"] = "Vis søndag først"; -Calendar._TT["CLOSE"] = "Lukk"; -Calendar._TT["TODAY"] = "Idag"; -Calendar._TT["TIME_PART"] = "(Shift-)Klikk eller dra for Ã¥ endre verdi"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d.%m.%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "uke"; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl-utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl-utf8.js deleted file mode 100644 index 6b8ca67aa2..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl-utf8.js +++ /dev/null @@ -1,93 +0,0 @@ -// ** I18N - -// Calendar PL language -// Author: Dariusz Pietrzak, -// Author: Janusz Piwowarski, -// Encoding: utf-8 -// Distributed under the same terms as the calendar itself. - -Calendar._DN = new Array -("Niedziela", - "PoniedziaÅ‚ek", - "Wtorek", - "Åšroda", - "Czwartek", - "PiÄ…tek", - "Sobota", - "Niedziela"); -Calendar._SDN = new Array -("Nie", - "Pn", - "Wt", - "Åšr", - "Cz", - "Pt", - "So", - "Nie"); -Calendar._MN = new Array -("StyczeÅ„", - "Luty", - "Marzec", - "KwiecieÅ„", - "Maj", - "Czerwiec", - "Lipiec", - "SierpieÅ„", - "WrzesieÅ„", - "Październik", - "Listopad", - "GrudzieÅ„"); -Calendar._SMN = new Array -("Sty", - "Lut", - "Mar", - "Kwi", - "Maj", - "Cze", - "Lip", - "Sie", - "Wrz", - "Paź", - "Lis", - "Gru"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O kalendarzu"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Aby pobrać najnowszÄ… wersjÄ™, odwiedź: http://www.dynarch.com/projects/calendar/\n" + -"DostÄ™pny na licencji GNU LGPL. Zobacz szczegóły na http://gnu.org/licenses/lgpl.html." + -"\n\n" + -"Wybór daty:\n" + -"- Użyj przycisków \xab, \xbb by wybrać rok\n" + -"- Użyj przycisków " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " by wybrać miesiÄ…c\n" + -"- Przytrzymaj klawisz myszy nad jednym z powyższych przycisków dla szybszego wyboru."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Wybór czasu:\n" + -"- Kliknij na jednym z pól czasu by zwiÄ™kszyć jego wartość\n" + -"- lub kliknij trzymajÄ…c Shift by zmiejszyć jego wartość\n" + -"- lub kliknij i przeciÄ…gnij dla szybszego wyboru."; - -//Calendar._TT["TOGGLE"] = "ZmieÅ„ pierwszy dzieÅ„ tygodnia"; -Calendar._TT["PREV_YEAR"] = "Poprzedni rok (przytrzymaj dla menu)"; -Calendar._TT["PREV_MONTH"] = "Poprzedni miesiÄ…c (przytrzymaj dla menu)"; -Calendar._TT["GO_TODAY"] = "Idź do dzisiaj"; -Calendar._TT["NEXT_MONTH"] = "NastÄ™pny miesiÄ…c (przytrzymaj dla menu)"; -Calendar._TT["NEXT_YEAR"] = "NastÄ™pny rok (przytrzymaj dla menu)"; -Calendar._TT["SEL_DATE"] = "Wybierz datÄ™"; -Calendar._TT["DRAG_TO_MOVE"] = "PrzeciÄ…gnij by przesunąć"; -Calendar._TT["PART_TODAY"] = " (dzisiaj)"; -Calendar._TT["MON_FIRST"] = "WyÅ›wietl poniedziaÅ‚ek jako pierwszy"; -Calendar._TT["SUN_FIRST"] = "WyÅ›wietl niedzielÄ™ jako pierwszÄ…"; -Calendar._TT["CLOSE"] = "Zamknij"; -Calendar._TT["TODAY"] = "Dzisiaj"; -Calendar._TT["TIME_PART"] = "(Shift-)Kliknij lub przeciÄ…gnij by zmienić wartość"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%e %B, %A"; - -Calendar._TT["WK"] = "ty"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl.js deleted file mode 100644 index 76e0551ab6..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pl.js +++ /dev/null @@ -1,56 +0,0 @@ -// ** I18N -// Calendar PL language -// Author: Artur Filipiak, -// January, 2004 -// Encoding: UTF-8 -Calendar._DN = new Array -("Niedziela", "PoniedziaÅ‚ek", "Wtorek", "Åšroda", "Czwartek", "PiÄ…tek", "Sobota", "Niedziela"); - -Calendar._SDN = new Array -("N", "Pn", "Wt", "Åšr", "Cz", "Pt", "So", "N"); - -Calendar._MN = new Array -("StyczeÅ„", "Luty", "Marzec", "KwiecieÅ„", "Maj", "Czerwiec", "Lipiec", "SierpieÅ„", "WrzesieÅ„", "Październik", "Listopad", "GrudzieÅ„"); - -Calendar._SMN = new Array -("Sty", "Lut", "Mar", "Kwi", "Maj", "Cze", "Lip", "Sie", "Wrz", "Paź", "Lis", "Gru"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O kalendarzu"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Wybór daty:\n" + -"- aby wybrać rok użyj przycisków \xab, \xbb\n" + -"- aby wybrać miesiÄ…c użyj przycisków " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + "\n" + -"- aby przyspieszyć wybór przytrzymaj wciÅ›niÄ™ty przycisk myszy nad ww. przyciskami."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Wybór czasu:\n" + -"- aby zwiÄ™kszyć wartość kliknij na dowolnym elemencie selekcji czasu\n" + -"- aby zmniejszyć wartość użyj dodatkowo klawisza Shift\n" + -"- możesz również poruszać myszkÄ™ w lewo i prawo wraz z wciÅ›niÄ™tym lewym klawiszem."; - -Calendar._TT["PREV_YEAR"] = "Poprz. rok (przytrzymaj dla menu)"; -Calendar._TT["PREV_MONTH"] = "Poprz. miesiÄ…c (przytrzymaj dla menu)"; -Calendar._TT["GO_TODAY"] = "Pokaż dziÅ›"; -Calendar._TT["NEXT_MONTH"] = "Nast. miesiÄ…c (przytrzymaj dla menu)"; -Calendar._TT["NEXT_YEAR"] = "Nast. rok (przytrzymaj dla menu)"; -Calendar._TT["SEL_DATE"] = "Wybierz datÄ™"; -Calendar._TT["DRAG_TO_MOVE"] = "PrzesuÅ„ okienko"; -Calendar._TT["PART_TODAY"] = " (dziÅ›)"; -Calendar._TT["MON_FIRST"] = "Pokaż PoniedziaÅ‚ek jako pierwszy"; -Calendar._TT["SUN_FIRST"] = "Pokaż NiedzielÄ™ jako pierwszÄ…"; -Calendar._TT["CLOSE"] = "Zamknij"; -Calendar._TT["TODAY"] = "DziÅ›"; -Calendar._TT["TIME_PART"] = "(Shift-)klik | drag, aby zmienić wartość"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y.%m.%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "wk"; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pt.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pt.js deleted file mode 100644 index deee8a19ed..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-pt.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar pt_BR language -// Author: Adalberto Machado, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Domingo", - "Segunda", - "Terca", - "Quarta", - "Quinta", - "Sexta", - "Sabado", - "Domingo"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("Dom", - "Seg", - "Ter", - "Qua", - "Qui", - "Sex", - "Sab", - "Dom"); - -// full month names -Calendar._MN = new Array -("Janeiro", - "Fevereiro", - "Marco", - "Abril", - "Maio", - "Junho", - "Julho", - "Agosto", - "Setembro", - "Outubro", - "Novembro", - "Dezembro"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Fev", - "Mar", - "Abr", - "Mai", - "Jun", - "Jul", - "Ago", - "Set", - "Out", - "Nov", - "Dez"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Sobre o calendario"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Ultima versao visite: http://www.dynarch.com/projects/calendar/\n" + -"Distribuido sobre GNU LGPL. Veja http://gnu.org/licenses/lgpl.html para detalhes." + -"\n\n" + -"Selecao de data:\n" + -"- Use os botoes \xab, \xbb para selecionar o ano\n" + -"- Use os botoes " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " para selecionar o mes\n" + -"- Segure o botao do mouse em qualquer um desses botoes para selecao rapida."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selecao de hora:\n" + -"- Clique em qualquer parte da hora para incrementar\n" + -"- ou Shift-click para decrementar\n" + -"- ou clique e segure para selecao rapida."; - -Calendar._TT["PREV_YEAR"] = "Ant. ano (segure para menu)"; -Calendar._TT["PREV_MONTH"] = "Ant. mes (segure para menu)"; -Calendar._TT["GO_TODAY"] = "Hoje"; -Calendar._TT["NEXT_MONTH"] = "Prox. mes (segure para menu)"; -Calendar._TT["NEXT_YEAR"] = "Prox. ano (segure para menu)"; -Calendar._TT["SEL_DATE"] = "Selecione a data"; -Calendar._TT["DRAG_TO_MOVE"] = "Arraste para mover"; -Calendar._TT["PART_TODAY"] = " (hoje)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Mostre %s primeiro"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Fechar"; -Calendar._TT["TODAY"] = "Hoje"; -Calendar._TT["TIME_PART"] = "(Shift-)Click ou arraste para mudar valor"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d/%m/%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %e %b"; - -Calendar._TT["WK"] = "sm"; -Calendar._TT["TIME"] = "Hora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ro.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ro.js deleted file mode 100644 index 116e358ba2..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ro.js +++ /dev/null @@ -1,66 +0,0 @@ -// ** I18N -Calendar._DN = new Array -("Duminică", - "Luni", - "MarÅ£i", - "Miercuri", - "Joi", - "Vineri", - "Sâmbătă", - "Duminică"); -Calendar._SDN_len = 2; -Calendar._MN = new Array -("Ianuarie", - "Februarie", - "Martie", - "Aprilie", - "Mai", - "Iunie", - "Iulie", - "August", - "Septembrie", - "Octombrie", - "Noiembrie", - "Decembrie"); - -// tooltips -Calendar._TT = {}; - -Calendar._TT["INFO"] = "Despre calendar"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Pentru ultima versiune vizitaÅ£i: http://www.dynarch.com/projects/calendar/\n" + -"Distribuit sub GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"SelecÅ£ia datei:\n" + -"- FolosiÅ£i butoanele \xab, \xbb pentru a selecta anul\n" + -"- FolosiÅ£i butoanele " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " pentru a selecta luna\n" + -"- TineÅ£i butonul mouse-ului apăsat pentru selecÅ£ie mai rapidă."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"SelecÅ£ia orei:\n" + -"- Click pe ora sau minut pentru a mări valoarea cu 1\n" + -"- Sau Shift-Click pentru a micÅŸora valoarea cu 1\n" + -"- Sau Click ÅŸi drag pentru a selecta mai repede."; - -Calendar._TT["PREV_YEAR"] = "Anul precedent (lung pt menu)"; -Calendar._TT["PREV_MONTH"] = "Luna precedentă (lung pt menu)"; -Calendar._TT["GO_TODAY"] = "Data de azi"; -Calendar._TT["NEXT_MONTH"] = "Luna următoare (lung pt menu)"; -Calendar._TT["NEXT_YEAR"] = "Anul următor (lung pt menu)"; -Calendar._TT["SEL_DATE"] = "Selectează data"; -Calendar._TT["DRAG_TO_MOVE"] = "Trage pentru a miÅŸca"; -Calendar._TT["PART_TODAY"] = " (astăzi)"; -Calendar._TT["DAY_FIRST"] = "AfiÅŸează %s prima zi"; -Calendar._TT["WEEKEND"] = "0,6"; -Calendar._TT["CLOSE"] = "ÃŽnchide"; -Calendar._TT["TODAY"] = "Astăzi"; -Calendar._TT["TIME_PART"] = "(Shift-)Click sau drag pentru a selecta"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%d-%m-%Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %d %B"; - -Calendar._TT["WK"] = "spt"; -Calendar._TT["TIME"] = "Ora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru.js deleted file mode 100644 index 9f75a6a432..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar RU language -// Translation: Sly Golovanov, http://golovanov.net, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("воÑкреÑенье", - "понедельник", - "вторник", - "Ñреда", - "четверг", - "пÑтница", - "Ñуббота", - "воÑкреÑенье"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("вÑк", - "пон", - "втр", - "Ñрд", - "чет", - "пÑÑ‚", - "Ñуб", - "вÑк"); - -// full month names -Calendar._MN = new Array -("Ñнварь", - "февраль", - "март", - "апрель", - "май", - "июнь", - "июль", - "авгуÑÑ‚", - "ÑентÑбрь", - "октÑбрь", - "ноÑбрь", - "декабрь"); - -// short month names -Calendar._SMN = new Array -("Ñнв", - "фев", - "мар", - "апр", - "май", - "июн", - "июл", - "авг", - "Ñен", - "окт", - "ноÑ", - "дек"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "О календаре..."; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Как выбрать дату:\n" + -"- При помощи кнопок \xab, \xbb можно выбрать год\n" + -"- При помощи кнопок " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " можно выбрать меÑÑц\n" + -"- Подержите Ñти кнопки нажатыми, чтобы поÑвилоÑÑŒ меню быÑтрого выбора."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Как выбрать времÑ:\n" + -"- При клике на чаÑах или минутах они увеличиваютÑÑ\n" + -"- при клике Ñ Ð½Ð°Ð¶Ð°Ñ‚Ð¾Ð¹ клавишей Shift они уменьшаютÑÑ\n" + -"- еÑли нажать и двигать мышкой влево/вправо, они будут менÑÑ‚ÑŒÑÑ Ð±Ñ‹Ñтрее."; - -Calendar._TT["PREV_YEAR"] = "Ðа год назад (удерживать Ð´Ð»Ñ Ð¼ÐµÐ½ÑŽ)"; -Calendar._TT["PREV_MONTH"] = "Ðа меÑÑц назад (удерживать Ð´Ð»Ñ Ð¼ÐµÐ½ÑŽ)"; -Calendar._TT["GO_TODAY"] = "СегоднÑ"; -Calendar._TT["NEXT_MONTH"] = "Ðа меÑÑц вперед (удерживать Ð´Ð»Ñ Ð¼ÐµÐ½ÑŽ)"; -Calendar._TT["NEXT_YEAR"] = "Ðа год вперед (удерживать Ð´Ð»Ñ Ð¼ÐµÐ½ÑŽ)"; -Calendar._TT["SEL_DATE"] = "Выберите дату"; -Calendar._TT["DRAG_TO_MOVE"] = "ПеретаÑкивайте мышкой"; -Calendar._TT["PART_TODAY"] = " (ÑегоднÑ)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Первый день недели будет %s"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Закрыть"; -Calendar._TT["TODAY"] = "СегоднÑ"; -Calendar._TT["TIME_PART"] = "(Shift-)клик или нажать и двигать"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%e %b, %a"; - -Calendar._TT["WK"] = "нед"; -Calendar._TT["TIME"] = "ВремÑ:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru_win_.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru_win_.js deleted file mode 100644 index de455afa08..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-ru_win_.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar RU language -// Translation: Sly Golovanov, http://golovanov.net, -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("âîñêðåñåíüå", - "ïîíåäåëüíèê", - "âòîðíèê", - "ñðåäà", - "÷åòâåðã", - "ïÿòíèöà", - "ñóááîòà", - "âîñêðåñåíüå"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("âñê", - "ïîí", - "âòð", - "ñðä", - "÷åò", - "ïÿò", - "ñóá", - "âñê"); - -// full month names -Calendar._MN = new Array -("ÿíâàðü", - "ôåâðàëü", - "ìàðò", - "àïðåëü", - "ìàé", - "èþíü", - "èþëü", - "àâãóñò", - "ñåíòÿáðü", - "îêòÿáðü", - "íîÿáðü", - "äåêàáðü"); - -// short month names -Calendar._SMN = new Array -("ÿíâ", - "ôåâ", - "ìàð", - "àïð", - "ìàé", - "èþí", - "èþë", - "àâã", - "ñåí", - "îêò", - "íîÿ", - "äåê"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Î êàëåíäàðå..."; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Êàê âûáðàòü äàòó:\n" + -"- Ïðè ïîìîùè êíîïîê \xab, \xbb ìîæíî âûáðàòü ãîä\n" + -"- Ïðè ïîìîùè êíîïîê " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " ìîæíî âûáðàòü ìåñÿö\n" + -"- Ïîäåðæèòå ýòè êíîïêè íàæàòûìè, ÷òîáû ïîÿâèëîñü ìåíþ áûñòðîãî âûáîðà."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Êàê âûáðàòü âðåìÿ:\n" + -"- Ïðè êëèêå íà ÷àñàõ èëè ìèíóòàõ îíè óâåëè÷èâàþòñÿ\n" + -"- ïðè êëèêå ñ íàæàòîé êëàâèøåé Shift îíè óìåíüøàþòñÿ\n" + -"- åñëè íàæàòü è äâèãàòü ìûøêîé âëåâî/âïðàâî, îíè áóäóò ìåíÿòüñÿ áûñòðåå."; - -Calendar._TT["PREV_YEAR"] = "Íà ãîä íàçàä (óäåðæèâàòü äëÿ ìåíþ)"; -Calendar._TT["PREV_MONTH"] = "Íà ìåñÿö íàçàä (óäåðæèâàòü äëÿ ìåíþ)"; -Calendar._TT["GO_TODAY"] = "Ñåãîäíÿ"; -Calendar._TT["NEXT_MONTH"] = "Íà ìåñÿö âïåðåä (óäåðæèâàòü äëÿ ìåíþ)"; -Calendar._TT["NEXT_YEAR"] = "Íà ãîä âïåðåä (óäåðæèâàòü äëÿ ìåíþ)"; -Calendar._TT["SEL_DATE"] = "Âûáåðèòå äàòó"; -Calendar._TT["DRAG_TO_MOVE"] = "Ïåðåòàñêèâàéòå ìûøêîé"; -Calendar._TT["PART_TODAY"] = " (ñåãîäíÿ)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Ïåðâûé äåíü íåäåëè áóäåò %s"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Çàêðûòü"; -Calendar._TT["TODAY"] = "Ñåãîäíÿ"; -Calendar._TT["TIME_PART"] = "(Shift-)êëèê èëè íàæàòü è äâèãàòü"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%e %b, %a"; - -Calendar._TT["WK"] = "íåä"; -Calendar._TT["TIME"] = "Âðåìÿ:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-si.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-si.js deleted file mode 100644 index cb3dfb9fdf..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-si.js +++ /dev/null @@ -1,94 +0,0 @@ -/* Slovenian language file for the DHTML Calendar version 0.9.2 -* Author David Milost , January 2004. -* Feel free to use this script under the terms of the GNU Lesser General -* Public License, as long as you do not remove or alter this notice. -*/ - // full day names -Calendar._DN = new Array -("Nedelja", - "Ponedeljek", - "Torek", - "Sreda", - "ÄŒetrtek", - "Petek", - "Sobota", - "Nedelja"); - // short day names - Calendar._SDN = new Array -("Ned", - "Pon", - "Tor", - "Sre", - "ÄŒet", - "Pet", - "Sob", - "Ned"); -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "Mar", - "Apr", - "Maj", - "Jun", - "Jul", - "Avg", - "Sep", - "Okt", - "Nov", - "Dec"); - // full month names -Calendar._MN = new Array -("Januar", - "Februar", - "Marec", - "April", - "Maj", - "Junij", - "Julij", - "Avgust", - "September", - "Oktober", - "November", - "December"); - -// tooltips -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O koledarju"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Za zadnjo verzijo pojdine na naslov: http://www.dynarch.com/projects/calendar/\n" + -"Distribuirano pod GNU LGPL. Poglejte http://gnu.org/licenses/lgpl.html za podrobnosti." + -"\n\n" + -"Izbor datuma:\n" + -"- Uporabite \xab, \xbb gumbe za izbor leta\n" + -"- Uporabite " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " gumbe za izbor meseca\n" + -"- Zadržite klik na kateremkoli od zgornjih gumbov za hiter izbor."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Izbor ćasa:\n" + -"- Kliknite na katerikoli del ćasa za poveć. le-tega\n" + -"- ali Shift-click za zmanj. le-tega\n" + -"- ali kliknite in povlecite za hiter izbor."; - -Calendar._TT["TOGGLE"] = "Spremeni dan s katerim se prićne teden"; -Calendar._TT["PREV_YEAR"] = "Predhodnje leto (dolg klik za meni)"; -Calendar._TT["PREV_MONTH"] = "Predhodnji mesec (dolg klik za meni)"; -Calendar._TT["GO_TODAY"] = "Pojdi na tekoći dan"; -Calendar._TT["NEXT_MONTH"] = "Naslednji mesec (dolg klik za meni)"; -Calendar._TT["NEXT_YEAR"] = "Naslednje leto (dolg klik za meni)"; -Calendar._TT["SEL_DATE"] = "Izberite datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Pritisni in povleci za spremembo pozicije"; -Calendar._TT["PART_TODAY"] = " (danes)"; -Calendar._TT["MON_FIRST"] = "Prikaži ponedeljek kot prvi dan"; -Calendar._TT["SUN_FIRST"] = "Prikaži nedeljo kot prvi dan"; -Calendar._TT["CLOSE"] = "Zapri"; -Calendar._TT["TODAY"] = "Danes"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e"; - -Calendar._TT["WK"] = "Ted"; \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sk.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sk.js deleted file mode 100644 index 4fe6a3c8bb..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sk.js +++ /dev/null @@ -1,99 +0,0 @@ -// ** I18N - -// Calendar SK language -// Author: Peter Valach (pvalach@gmx.net) -// Encoding: utf-8 -// Last update: 2003/10/29 -// Distributed under the same terms as the calendar itself. - -// full day names -Calendar._DN = new Array -("NedeÄľa", - "Pondelok", - "Utorok", - "Streda", - "Ĺ tvrtok", - "Piatok", - "Sobota", - "NedeÄľa"); - -// short day names -Calendar._SDN = new Array -("Ned", - "Pon", - "Uto", - "Str", - "Ĺ tv", - "Pia", - "Sob", - "Ned"); - -// full month names -Calendar._MN = new Array -("Január", - "Február", - "Marec", - "AprĂ­l", - "Máj", - "JÄ‚ÅŸn", - "JÄ‚ÅŸl", - "August", - "September", - "OktÄ‚Å‚ber", - "November", - "December"); - -// short month names -Calendar._SMN = new Array -("Jan", - "Feb", - "Mar", - "Apr", - "Máj", - "JÄ‚ÅŸn", - "JÄ‚ÅŸl", - "Aug", - "Sep", - "Okt", - "Nov", - "Dec"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "O kalendári"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + -"PoslednÄ‚ÅŸ verziu nájdete na: http://www.dynarch.com/projects/calendar/\n" + -"DistribuovanĂ© pod GNU LGPL. ViÄŹ http://gnu.org/licenses/lgpl.html pre detaily." + -"\n\n" + -"VÄ‚Ëber dátumu:\n" + -"- PouĹľite tlaÄŤidlá \xab, \xbb pre vÄ‚Ëber roku\n" + -"- PouĹľite tlaÄŤidlá " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " pre vÄ‚Ëber mesiaca\n" + -"- Ak ktorĂ©koÄľvek z tÄ‚Ëchto tlaÄŤidiel podržíte dlhšie, zobrazĂ­ sa rÄ‚Ëchly vÄ‚Ëber."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"VÄ‚Ëber ÄŤasu:\n" + -"- Kliknutie na niektorÄ‚ÅŸ poloĹľku ÄŤasu ju zvÄ‚Ëši\n" + -"- Shift-klik ju znĂ­Ĺľi\n" + -"- Ak podržíte tlaÄŤĂ­tko stlaÄŤenĂ©, posÄ‚ÅŸvanĂ­m menĂ­te hodnotu."; - -Calendar._TT["PREV_YEAR"] = "PredošlÄ‚Ë rok (podrĹľte pre menu)"; -Calendar._TT["PREV_MONTH"] = "PredošlÄ‚Ë mesiac (podrĹľte pre menu)"; -Calendar._TT["GO_TODAY"] = "PrejsĹĄ na dnešok"; -Calendar._TT["NEXT_MONTH"] = "Nasl. mesiac (podrĹľte pre menu)"; -Calendar._TT["NEXT_YEAR"] = "Nasl. rok (podrĹľte pre menu)"; -Calendar._TT["SEL_DATE"] = "ZvoÄľte dátum"; -Calendar._TT["DRAG_TO_MOVE"] = "PodrĹľanĂ­m tlaÄŤĂ­tka zmenĂ­te polohu"; -Calendar._TT["PART_TODAY"] = " (dnes)"; -Calendar._TT["MON_FIRST"] = "ZobraziĹĄ pondelok ako prvÄ‚Ë"; -Calendar._TT["SUN_FIRST"] = "ZobraziĹĄ nedeÄľu ako prvÄ‚ÅŸ"; -Calendar._TT["CLOSE"] = "ZavrieĹĄ"; -Calendar._TT["TODAY"] = "Dnes"; -Calendar._TT["TIME_PART"] = "(Shift-)klik/ĹĄahanie zmenĂ­ hodnotu"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "$d. %m. %Y"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %e. %b"; - -Calendar._TT["WK"] = "tÄ‚ËĹľ"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sp.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sp.js deleted file mode 100644 index 239d1b3be9..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sp.js +++ /dev/null @@ -1,110 +0,0 @@ -// ** I18N - -// Calendar SP language -// Author: Rafael Velasco -// Encoding: any -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("Domingo", - "Lunes", - "Martes", - "Miercoles", - "Jueves", - "Viernes", - "Sabado", - "Domingo"); - -Calendar._SDN = new Array -("Dom", - "Lun", - "Mar", - "Mie", - "Jue", - "Vie", - "Sab", - "Dom"); - -// full month names -Calendar._MN = new Array -("Enero", - "Febrero", - "Marzo", - "Abril", - "Mayo", - "Junio", - "Julio", - "Agosto", - "Septiembre", - "Octubre", - "Noviembre", - "Diciembre"); - -// short month names -Calendar._SMN = new Array -("Ene", - "Feb", - "Mar", - "Abr", - "May", - "Jun", - "Jul", - "Ago", - "Sep", - "Oct", - "Nov", - "Dic"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Información del Calendario"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"Nuevas versiones en: http://www.dynarch.com/projects/calendar/\n" + -"Distribuida bajo licencia GNU LGPL. Para detalles vea http://gnu.org/licenses/lgpl.html ." + -"\n\n" + -"Selección de Fechas:\n" + -"- Use \xab, \xbb para seleccionar el año\n" + -"- Use " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " para seleccionar el mes\n" + -"- Mantenga presionado el botón del ratón en cualquiera de las opciones superiores para un acceso rapido ."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Selección del Reloj:\n" + -"- Seleccione la hora para cambiar el reloj\n" + -"- o presione Shift-click para disminuirlo\n" + -"- o presione click y arrastre del ratón para una selección rapida."; - -Calendar._TT["PREV_YEAR"] = "Año anterior (Presione para menu)"; -Calendar._TT["PREV_MONTH"] = "Mes Anterior (Presione para menu)"; -Calendar._TT["GO_TODAY"] = "Ir a Hoy"; -Calendar._TT["NEXT_MONTH"] = "Mes Siguiente (Presione para menu)"; -Calendar._TT["NEXT_YEAR"] = "Año Siguiente (Presione para menu)"; -Calendar._TT["SEL_DATE"] = "Seleccione fecha"; -Calendar._TT["DRAG_TO_MOVE"] = "Arrastre y mueva"; -Calendar._TT["PART_TODAY"] = " (Hoy)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "Mostrar %s primero"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "Cerrar"; -Calendar._TT["TODAY"] = "Hoy"; -Calendar._TT["TIME_PART"] = "(Shift-)Click o arrastra para cambar el valor"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%dd-%mm-%yy"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %e de %B de %Y"; - -Calendar._TT["WK"] = "Sm"; -Calendar._TT["TIME"] = "Hora:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sv.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sv.js deleted file mode 100644 index db1f4b84c3..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-sv.js +++ /dev/null @@ -1,93 +0,0 @@ -// ** I18N - -// Calendar SV language (Swedish, svenska) -// Author: Mihai Bazon, -// Translation team: -// Translator: Leonard Norrgård -// Last translator: Leonard Norrgård -// Encoding: iso-latin-1 -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("söndag", - "måndag", - "tisdag", - "onsdag", - "torsdag", - "fredag", - "lördag", - "söndag"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. -Calendar._SDN_len = 2; -Calendar._SMN_len = 3; - -// full month names -Calendar._MN = new Array -("januari", - "februari", - "mars", - "april", - "maj", - "juni", - "juli", - "augusti", - "september", - "oktober", - "november", - "december"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "Om kalendern"; - -Calendar._TT["ABOUT"] = -"DHTML Datum/tid-väljare\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"För senaste version gå till: http://www.dynarch.com/projects/calendar/\n" + -"Distribueras under GNU LGPL. Se http://gnu.org/licenses/lgpl.html för detaljer." + -"\n\n" + -"Val av datum:\n" + -"- Använd knapparna \xab, \xbb för att välja år\n" + -"- Använd knapparna " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " för att välja månad\n" + -"- Håll musknappen nedtryckt på någon av ovanstående knappar för snabbare val."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Val av tid:\n" + -"- Klicka på en del av tiden för att öka den delen\n" + -"- eller skift-klicka för att minska den\n" + -"- eller klicka och drag för snabbare val."; - -Calendar._TT["PREV_YEAR"] = "Föregående år (håll för menu)"; -Calendar._TT["PREV_MONTH"] = "Föregående månad (håll för menu)"; -Calendar._TT["GO_TODAY"] = "Gå till dagens datum"; -Calendar._TT["NEXT_MONTH"] = "Följande månad (håll för menu)"; -Calendar._TT["NEXT_YEAR"] = "Följande år (håll för menu)"; -Calendar._TT["SEL_DATE"] = "Välj datum"; -Calendar._TT["DRAG_TO_MOVE"] = "Drag för att flytta"; -Calendar._TT["PART_TODAY"] = " (idag)"; -Calendar._TT["MON_FIRST"] = "Visa måndag först"; -Calendar._TT["SUN_FIRST"] = "Visa söndag först"; -Calendar._TT["CLOSE"] = "Stäng"; -Calendar._TT["TODAY"] = "Idag"; -Calendar._TT["TIME_PART"] = "(Skift-)klicka eller drag för att ändra tid"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%A %d %b %Y"; - -Calendar._TT["WK"] = "vecka"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-tr.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-tr.js deleted file mode 100644 index 2164687fbb..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-tr.js +++ /dev/null @@ -1,58 +0,0 @@ -////////////////////////////////////////////////////////////////////////////////////////////// -// Turkish Translation by Nuri AKMAN -// Location: Ankara/TURKEY -// e-mail : nuriakman@hotmail.com -// Date : April, 9 2003 -// -// Note: if Turkish Characters does not shown on you screen -// please include falowing line your html code: -// -// -// -////////////////////////////////////////////////////////////////////////////////////////////// - -// ** I18N -Calendar._DN = new Array -("Pazar", - "Pazartesi", - "Salý", - "Çarþamba", - "Perþembe", - "Cuma", - "Cumartesi", - "Pazar"); -Calendar._MN = new Array -("Ocak", - "Þubat", - "Mart", - "Nisan", - "Mayýs", - "Haziran", - "Temmuz", - "Aðustos", - "Eylül", - "Ekim", - "Kasým", - "Aralýk"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["TOGGLE"] = "Haftanýn ilk gününü kaydýr"; -Calendar._TT["PREV_YEAR"] = "Önceki Yýl (Menü için basýlý tutunuz)"; -Calendar._TT["PREV_MONTH"] = "Önceki Ay (Menü için basýlý tutunuz)"; -Calendar._TT["GO_TODAY"] = "Bugün'e git"; -Calendar._TT["NEXT_MONTH"] = "Sonraki Ay (Menü için basýlý tutunuz)"; -Calendar._TT["NEXT_YEAR"] = "Sonraki Yýl (Menü için basýlý tutunuz)"; -Calendar._TT["SEL_DATE"] = "Tarih seçiniz"; -Calendar._TT["DRAG_TO_MOVE"] = "Taþýmak için sürükleyiniz"; -Calendar._TT["PART_TODAY"] = " (bugün)"; -Calendar._TT["MON_FIRST"] = "Takvim Pazartesi gününden baþlasýn"; -Calendar._TT["SUN_FIRST"] = "Takvim Pazar gününden baþlasýn"; -Calendar._TT["CLOSE"] = "Kapat"; -Calendar._TT["TODAY"] = "Bugün"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "dd-mm-y"; -Calendar._TT["TT_DATE_FORMAT"] = "d MM y, DD"; - -Calendar._TT["WK"] = "Hafta"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-zh.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-zh.js deleted file mode 100644 index 4a0feb6b73..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/calendar-zh.js +++ /dev/null @@ -1,119 +0,0 @@ -// ** I18N - -// Calendar ZH language -// Author: muziq, -// Encoding: GB2312 or GBK -// Distributed under the same terms as the calendar itself. - -// full day names -Calendar._DN = new Array -("ÐÇÆÚÈÕ", - "ÐÇÆÚÒ»", - "ÐÇÆÚ¶þ", - "ÐÇÆÚÈý", - "ÐÇÆÚËÄ", - "ÐÇÆÚÎå", - "ÐÇÆÚÁù", - "ÐÇÆÚÈÕ"); - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("ÈÕ", - "Ò»", - "¶þ", - "Èý", - "ËÄ", - "Îå", - "Áù", - "ÈÕ"); - -// full month names -Calendar._MN = new Array -("Ò»ÔÂ", - "¶þÔÂ", - "ÈýÔÂ", - "ËÄÔÂ", - "ÎåÔÂ", - "ÁùÔÂ", - "ÆßÔÂ", - "°ËÔÂ", - "¾ÅÔÂ", - "Ê®ÔÂ", - "ʮһÔÂ", - "Ê®¶þÔÂ"); - -// short month names -Calendar._SMN = new Array -("Ò»ÔÂ", - "¶þÔÂ", - "ÈýÔÂ", - "ËÄÔÂ", - "ÎåÔÂ", - "ÁùÔÂ", - "ÆßÔÂ", - "°ËÔÂ", - "¾ÅÔÂ", - "Ê®ÔÂ", - "ʮһÔÂ", - "Ê®¶þÔÂ"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "°ïÖú"; - -Calendar._TT["ABOUT"] = -"DHTML Date/Time Selector\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: http://www.dynarch.com/projects/calendar/\n" + -"Distributed under GNU LGPL. See http://gnu.org/licenses/lgpl.html for details." + -"\n\n" + -"Ñ¡ÔñÈÕÆÚ:\n" + -"- µã»÷ \xab, \xbb °´Å¥Ñ¡ÔñÄê·Ý\n" + -"- µã»÷ " + String.fromCharCode(0x2039) + ", " + String.fromCharCode(0x203a) + " °´Å¥Ñ¡ÔñÔ·Ý\n" + -"- ³¤°´ÒÔÉÏ°´Å¥¿É´Ó²Ëµ¥ÖпìËÙÑ¡ÔñÄê·Ý»òÔ·Ý"; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"Ñ¡Ôñʱ¼ä:\n" + -"- µã»÷Сʱ»ò·ÖÖÓ¿Éʹ¸ÄÊýÖµ¼ÓÒ»\n" + -"- °´×¡Shift¼üµã»÷Сʱ»ò·ÖÖÓ¿Éʹ¸ÄÊýÖµ¼õÒ»\n" + -"- µã»÷Í϶¯Êó±ê¿É½øÐпìËÙÑ¡Ôñ"; - -Calendar._TT["PREV_YEAR"] = "ÉÏÒ»Äê (°´×¡³ö²Ëµ¥)"; -Calendar._TT["PREV_MONTH"] = "ÉÏÒ»Ô (°´×¡³ö²Ëµ¥)"; -Calendar._TT["GO_TODAY"] = "תµ½½ñÈÕ"; -Calendar._TT["NEXT_MONTH"] = "ÏÂÒ»Ô (°´×¡³ö²Ëµ¥)"; -Calendar._TT["NEXT_YEAR"] = "ÏÂÒ»Äê (°´×¡³ö²Ëµ¥)"; -Calendar._TT["SEL_DATE"] = "Ñ¡ÔñÈÕÆÚ"; -Calendar._TT["DRAG_TO_MOVE"] = "Í϶¯"; -Calendar._TT["PART_TODAY"] = " (½ñÈÕ)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "×î×ó±ßÏÔʾ%s"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "¹Ø±Õ"; -Calendar._TT["TODAY"] = "½ñÈÕ"; -Calendar._TT["TIME_PART"] = "(Shift-)µã»÷Êó±ê»òÍ϶¯¸Ä±äÖµ"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%A, %b %eÈÕ"; - -Calendar._TT["WK"] = "ÖÜ"; -Calendar._TT["TIME"] = "ʱ¼ä:"; diff --git a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/cn_utf8.js b/extra/webapps/article-manager/resources/jscalendar-1.0/lang/cn_utf8.js deleted file mode 100644 index a0ef7c6b3a..0000000000 --- a/extra/webapps/article-manager/resources/jscalendar-1.0/lang/cn_utf8.js +++ /dev/null @@ -1,123 +0,0 @@ -// ** I18N - -// Calendar EN language -// Author: Mihai Bazon, -// Encoding: any -// Translator : Niko -// Distributed under the same terms as the calendar itself. - -// For translators: please use UTF-8 if possible. We strongly believe that -// Unicode is the answer to a real internationalized world. Also please -// include your contact information in the header, as can be seen above. - -// full day names -Calendar._DN = new Array -("\u5468\u65e5",//\u5468\u65e5 - "\u5468\u4e00",//\u5468\u4e00 - "\u5468\u4e8c",//\u5468\u4e8c - "\u5468\u4e09",//\u5468\u4e09 - "\u5468\u56db",//\u5468\u56db - "\u5468\u4e94",//\u5468\u4e94 - "\u5468\u516d",//\u5468\u516d - "\u5468\u65e5");//\u5468\u65e5 - -// Please note that the following array of short day names (and the same goes -// for short month names, _SMN) isn't absolutely necessary. We give it here -// for exemplification on how one can customize the short day names, but if -// they are simply the first N letters of the full name you can simply say: -// -// Calendar._SDN_len = N; // short day name length -// Calendar._SMN_len = N; // short month name length -// -// If N = 3 then this is not needed either since we assume a value of 3 if not -// present, to be compatible with translation files that were written before -// this feature. - -// short day names -Calendar._SDN = new Array -("\u5468\u65e5", - "\u5468\u4e00", - "\u5468\u4e8c", - "\u5468\u4e09", - "\u5468\u56db", - "\u5468\u4e94", - "\u5468\u516d", - "\u5468\u65e5"); - -// full month names -Calendar._MN = new Array -("\u4e00\u6708", - "\u4e8c\u6708", - "\u4e09\u6708", - "\u56db\u6708", - "\u4e94\u6708", - "\u516d\u6708", - "\u4e03\u6708", - "\u516b\u6708", - "\u4e5d\u6708", - "\u5341\u6708", - "\u5341\u4e00\u6708", - "\u5341\u4e8c\u6708"); - -// short month names -Calendar._SMN = new Array -("\u4e00\u6708", - "\u4e8c\u6708", - "\u4e09\u6708", - "\u56db\u6708", - "\u4e94\u6708", - "\u516d\u6708", - "\u4e03\u6708", - "\u516b\u6708", - "\u4e5d\u6708", - "\u5341\u6708", - "\u5341\u4e00\u6708", - "\u5341\u4e8c\u6708"); - -// tooltips -Calendar._TT = {}; -Calendar._TT["INFO"] = "\u5173\u4e8e"; - -Calendar._TT["ABOUT"] = -" DHTML \u65e5\u8d77/\u65f6\u95f4\u9009\u62e9\u63a7\u4ef6\n" + -"(c) dynarch.com 2002-2005 / Author: Mihai Bazon\n" + // don't translate this this ;-) -"For latest version visit: \u6700\u65b0\u7248\u672c\u8bf7\u767b\u9646http://www.dynarch.com/projects/calendar/\u5bdf\u770b\n" + -"\u9075\u5faaGNU LGPL. \u7ec6\u8282\u53c2\u9605 http://gnu.org/licenses/lgpl.html" + -"\n\n" + -"\u65e5\u671f\u9009\u62e9:\n" + -"- \u70b9\u51fb\xab(\xbb)\u6309\u94ae\u9009\u62e9\u4e0a(\u4e0b)\u4e00\u5e74\u5ea6.\n" + -"- \u70b9\u51fb" + String.fromCharCode(0x2039) + "(" + String.fromCharCode(0x203a) + ")\u6309\u94ae\u9009\u62e9\u4e0a(\u4e0b)\u4e2a\u6708\u4efd.\n" + -"- \u957f\u65f6\u95f4\u6309\u7740\u6309\u94ae\u5c06\u51fa\u73b0\u66f4\u591a\u9009\u62e9\u9879."; -Calendar._TT["ABOUT_TIME"] = "\n\n" + -"\u65f6\u95f4\u9009\u62e9:\n" + -"-\u5728\u65f6\u95f4\u90e8\u5206(\u5206\u6216\u8005\u79d2)\u4e0a\u5355\u51fb\u9f20\u6807\u5de6\u952e\u6765\u589e\u52a0\u5f53\u524d\u65f6\u95f4\u90e8\u5206(\u5206\u6216\u8005\u79d2)\n" + -"-\u5728\u65f6\u95f4\u90e8\u5206(\u5206\u6216\u8005\u79d2)\u4e0a\u6309\u4f4fShift\u952e\u540e\u5355\u51fb\u9f20\u6807\u5de6\u952e\u6765\u51cf\u5c11\u5f53\u524d\u65f6\u95f4\u90e8\u5206(\u5206\u6216\u8005\u79d2)."; - -Calendar._TT["PREV_YEAR"] = "\u4e0a\u4e00\u5e74"; -Calendar._TT["PREV_MONTH"] = "\u4e0a\u4e2a\u6708"; -Calendar._TT["GO_TODAY"] = "\u5230\u4eca\u5929"; -Calendar._TT["NEXT_MONTH"] = "\u4e0b\u4e2a\u6708"; -Calendar._TT["NEXT_YEAR"] = "\u4e0b\u4e00\u5e74"; -Calendar._TT["SEL_DATE"] = "\u9009\u62e9\u65e5\u671f"; -Calendar._TT["DRAG_TO_MOVE"] = "\u62d6\u52a8"; -Calendar._TT["PART_TODAY"] = " (\u4eca\u5929)"; - -// the following is to inform that "%s" is to be the first day of week -// %s will be replaced with the day name. -Calendar._TT["DAY_FIRST"] = "%s\u4e3a\u8fd9\u5468\u7684\u7b2c\u4e00\u5929"; - -// This may be locale-dependent. It specifies the week-end days, as an array -// of comma-separated numbers. The numbers are from 0 to 6: 0 means Sunday, 1 -// means Monday, etc. -Calendar._TT["WEEKEND"] = "0,6"; - -Calendar._TT["CLOSE"] = "\u5173\u95ed"; -Calendar._TT["TODAY"] = "\u4eca\u5929"; -Calendar._TT["TIME_PART"] = "(\u6309\u7740Shift\u952e)\u5355\u51fb\u6216\u62d6\u52a8\u6539\u53d8\u503c"; - -// date formats -Calendar._TT["DEF_DATE_FORMAT"] = "%Y-%m-%d"; -Calendar._TT["TT_DATE_FORMAT"] = "%a, %b %e\u65e5"; - -Calendar._TT["WK"] = "\u5468"; -Calendar._TT["TIME"] = "\u65f6\u95f4:"; diff --git a/extra/webapps/article-manager/resources/style.css b/extra/webapps/article-manager/resources/style.css deleted file mode 100644 index 301cd38848..0000000000 --- a/extra/webapps/article-manager/resources/style.css +++ /dev/null @@ -1,65 +0,0 @@ -body { -background-color : #cccccc; -color : #000000; -margin:10px 10px 0px 10px; -padding:5px; -} - -#navigation { -position: absolute; -left:10px; -width:160px; -background:#fff; -border:1px solid #000; -} - -#navigation h1 { -font-size: 18px; -text-align: center; -} - -#article { -background:#fff; -margin-left: 159px; -margin-right: 159px; -border:1px solid #000; -voice-family: "\"}\""; -voice-family: inherit; -margin-left: 161px; -margin-right: 159px; -} - -html>body #article { -margin-left: 161px; -margin-right: 159px; -} - -p,h1,pre { -margin:0px 10px 10px 10px; -} - -h1 { -font-size:14px; -padding-top:10px; -} - -#banner h1 { -font-size:24px; -padding:10px 10px 0px 10px; -margin:0px; -text-align: center; -} - -#copyright { -text-align: center; -color: #FFF; -font-size: 65%; -} - - pre { border: 1px dashed black; border-width: 1px; - line-height:1.0em; - background: #ffe; - margin: 0.5em 0.5em 0.5em 0.5em; - padding: 0.5em; - font-size: 70%; - } \ No newline at end of file diff --git a/extra/webapps/article-manager/resources/wiky.css b/extra/webapps/article-manager/resources/wiky.css deleted file mode 100644 index 062f34efd9..0000000000 --- a/extra/webapps/article-manager/resources/wiky.css +++ /dev/null @@ -1,15 +0,0 @@ -/* == wiky == */ -*.wiki blockquote { background:#ddd; border:solid 1px #999; margin-left:1em; padding:0.5em;} -*.wiki table { - border-collapse: collapse; - empty-cells: show; -} - -*.wiki table td { - border: solid 1px black; - padding: 0.25em 0.5em 0.25em 0.5em; - text-align: center; -} - -/*pre { font-size:100%; background: #eed; border:1px dotted #999; padding:0 0.5em; overflow:auto; }*/ -pre { font-family:courier new, monospace; overflow:auto; } diff --git a/extra/webapps/article-manager/resources/wiky.js b/extra/webapps/article-manager/resources/wiky.js deleted file mode 100644 index 002855b859..0000000000 --- a/extra/webapps/article-manager/resources/wiky.js +++ /dev/null @@ -1,373 +0,0 @@ -/* This work is licensed under Creative Commons GNU LGPL License. - - License: http://creativecommons.org/licenses/LGPL/2.1/ - - Author: Stefan Goessner/2005-06 - Web: http://goessner.net/ -*/ -var Wiky = { - version: 0.95, - blocks: null, - rules: { - all: [ - "Wiky.rules.pre", - "Wiky.rules.nonwikiblocks", - "Wiky.rules.wikiblocks", - "Wiky.rules.post", - ], - pre: [ - { rex:/(\r?\n)/g, tmplt:"\xB6" }, // replace line breaks with '¶' .. - ], - post: [ - { rex:/(^\xB6)|(\xB6$)/g, tmplt:"" }, // .. remove linebreaks at BOS and EOS .. - { rex:/@([0-9]+)@/g, tmplt:function($0,$1){return Wiky.restore($1);} }, // resolve blocks .. - { rex:/\xB6/g, tmplt:"\n" } // replace '¶' with line breaks .. - ], - nonwikiblocks: [ - { rex:/\\([%])/g, tmplt:function($0,$1){return Wiky.store($1);} }, - { rex:/\[(?:\{([^}]*)\})?(?:\(([^)]*)\))?%(.*?)%\]/g, tmplt:function($0,$1,$2,$3){return ":p]"+Wiky.store("" + Wiky.apply($3, $2?Wiky.rules.lang[Wiky.attr($2)]:Wiky.rules.code) + "")+"[p:";} } //programm code block - ], - wikiblocks: [ - "Wiky.rules.nonwikiinlines", - "Wiky.rules.escapes", - { rex:/(?:^|\xB6)(={1,6})(.*?)[=]*(?=\xB6|$)/g, tmplt:function($0,$1,$2){ var h=$1.length; return ":p]\xB6"+$2+"\xB6[p:";} }, //

    ..

    - { rex:/(?:^|\xB6)[-]{4}(?:\xB6|$)/g, tmplt:"\xB6
    \xB6" }, // horizontal ruler .. - { rex:/\\\\([ \xB6])/g, tmplt:"
    $1" }, // forced line break .. - { rex:/(^|\xB6)([*01aAiIg]*[\.*])[ ]/g, tmplt:function($0,$1,$2){var state=$2.replace(/([*])/g,"u").replace(/([\.])/,"");return ":"+state+"]"+$1+"["+state+":";}}, - { rex:/(?:^|\xB6);[ ](.*?):[ ]/g, tmplt:"\xB6:l][l:$1:d][d:"}, // ; term : definition - { rex:/\[(?:\{([^}]*)\})?(?:\(([^)]*)\))?\"/g, tmplt:function($0,$1,$2){return ":p][p:"; } }, // block quotation start - { rex:/\"\]/g, tmplt:":p][p:" }, // block quotation end - { rex:/\[(\{[^}]*\})?\|/g, tmplt:":t]$1[r:" }, // .. start table .. - { rex:/\|\]/g, tmplt:":r][t:" }, // .. end table .. - { rex:/\|\xB6[ ]?\|/g, tmplt:":r]\xB6[r:" }, // .. end/start table row .. - { rex:/\|/g, tmplt:":c][c:" }, // .. end/start table cell .. - { rex:/^(.*)$/g, tmplt:"[p:$1:p]" }, // start paragraph '[p:' at BOS .. end paragraph ':p]' at EOS .. - { rex:/(([\xB6])([ \t\f\v\xB6]*?)){2,}/g, tmplt:":p]$1[p:" }, // .. separate paragraphs at blank lines .. - { rex:/\[([01AIacdgilprtu]+)[:](.*?)[:]([01AIacdgilprtu]+)\]/g, tmplt:function($0,$1,$2,$3){return Wiky.sectionRule($1==undefined?"":$1,"",Wiky.apply($2,Wiky.rules.wikiinlines),!$3?"":$3);} }, - { rex:/\[[01AIacdgilprtu]+[:]|[:][01AIacdgilprtu]+\]/g, tmplt:"" }, // .. remove singular section delimiters (they frequently exist with incomplete documents while typing) .. - { rex:/
    		(?:([0-9]*)[>])?([ ]?)(.*?)([ ]?)<\/td>/g, tmplt:function($0,$1,$2,$3,$4){return ""+$2+$3+$4+"\xB6*[ ]?|<\/tr>/mgi, tmplt:"|" }, // ie6 only .. - { rex:/\xB6]*?)>/mgi, tmplt:"\xB6" }, - { rex:/]*?)>/mgi, tmplt:"|$1>" }, - { rex:/]*?)>/mgi, tmplt:"|" }, - { rex://mgi, tmplt:"[" }, - { rex:/<\/table>/mgi, tmplt:"]" }, - { rex:/]*?)>\xB6*|<\/td>\xB6*|\xB6*|<\/tbody>/mgi, tmplt:"" }, - { rex://mgi, tmplt:"----" }, - { rex://mgi, tmplt:"\\\\" }, - { rex:/(

    |<(d|o|u)l[^>]*>|<\/(dl|ol|ul|p)>|<\/(li|dd)>)/mgi, tmplt:"" }, - "Wiky.inverse.shortcuts" - ], - nonwikiinlines: [ - { rex:/(.*?)<\/code>/g, tmplt:function($0,$1){return Wiky.store("%"+Wiky.apply($1, Wiky.inverse["code"])+"%");} } - ], - wikiinlines: [ - { rex:/]*?>(.*?)<\/strong>/mgi, tmplt:"*$1*" }, - { rex:/]*?>(.*?)<\/b>/mgi, tmplt:"*$1*" }, - { rex:/]*?>(.*?)<\/em>/mgi, tmplt:"_$1_" }, - { rex:/]*?>(.*?)<\/i>/mgi, tmplt:"_$1_" }, - { rex:/]*?>(.*?)<\/sup>/mgi, tmplt:"^$1^" }, - { rex:/]*?>(.*?)<\/sub>/mgi, tmplt:"~$1~" }, - { rex:/]*?>(.*?)<\/del>/mgi, tmplt:"(-$1-)" }, - { rex:/(.*?)<\/abbr>/mgi, tmplt:"?$2($1)?" }, - { rex:/]*?>(.*?)<\/a>/mgi, tmplt:function($0,$1,$2){return $1==$2?$1:"["+$1+","+$2+"]";}}, - { rex:/]*)\/?>/mgi, tmplt:function($0,$1){var a=Wiky.attrVal($1,"alt"),h=Wiky.attrVal($1,"src"),t=Wiky.attrVal($1,"title"),s=Wiky.attrVal($1,"style");return s||(t&&h!=t)?("["+Wiky.invStyle($1)+"img:"+h+(t&&(","+t))+"]"):h;}}, - ], - escapes: [ - { rex:/([|*_~%\^])/g, tmplt:"\\$1" }, - { rex:/&/g, tmplt:"\\&" }, - { rex:/>/g, tmplt:"\\>" }, - { rex:/</g, tmplt:"\\<" } - ], - shortcuts: [ - { rex:/–|\u2013/g, tmplt:"--"}, - { rex:/—|\u2014/g, tmplt:"---"}, - { rex:/…|\u2026/g, tmplt:"..."}, - { rex:/↔|\u2194/g, tmplt:"<->"}, - { rex:/←|\u2190/g, tmplt:"<-"}, - { rex:/→|\u2192/g, tmplt:"->"} - ], - code: [ - { rex:/&/g, tmplt:"&"}, - { rex:/</g, tmplt:"<"}, - { rex:/>/g, tmplt:">"} - ], - lang: {} - }, - - toHtml: function(str) { - Wiky.blocks = []; - return Wiky.apply(str, Wiky.rules.all); - }, - - toWiki: function(str) { - Wiky.blocks = []; - return Wiky.apply(str, Wiky.inverse.all); - }, - - apply: function(str, rules) { - if (str && rules) - for (var i in rules) { - if (typeof(rules[i]) == "string") - str = Wiky.apply(str, eval(rules[i])); - else - str = str.replace(rules[i].rex, rules[i].tmplt); - } - return str; - }, - store: function(str, unresolved) { - return unresolved ? "@" + (Wiky.blocks.push(str)-1) + "@" - : "@" + (Wiky.blocks.push(str.replace(/@([0-9]+)@/g, function($0,$1){return Wiky.restore($1);}))-1) + "@"; - }, - restore: function(idx) { - return Wiky.blocks[idx]; - }, - attr: function(str, name, idx) { - var a = str && str.split(",")[idx||0]; - return a ? (name ? (" "+name+"=\""+a+"\"") : a) : ""; - }, - hasAttr: function(str, name) { - return new RegExp(name+"=").test(str); - }, - attrVal: function(str, name) { - return str.replace(new RegExp("^.*?"+name+"=\"(.*?)\".*?$"), "$1"); - }, - invAttr: function(str, names) { - var a=[], x; - for (var i in names) - if (str.indexOf(names[i]+"=")>=0) - a.push(str.replace(new RegExp("^.*?"+names[i]+"=\"(.*?)\".*?$"), "$1")); - return a.length ? ("("+a.join(",")+")") : ""; - }, - style: function(str) { - var s = str && str.split(/,|;/), p, style = ""; - for (var i in s) { - p = s[i].split(":"); - if (p[0] == ">") style += "margin-left:4em;"; - else if (p[0] == "<") style += "margin-right:4em;"; - else if (p[0] == ">>") style += "float:right;"; - else if (p[0] == "<<") style += "float:left;"; - else if (p[0] == "=") style += "display:block;margin:0 auto;"; - else if (p[0] == "_") style += "text-decoration:underline;"; - else if (p[0] == "b") style += "border:solid 1px;"; - else if (p[0] == "c") style += "color:"+p[1]+";"; - else if (p[0] == "C") style += "background:"+p[1]+";"; - else if (p[0] == "w") style += "width:"+p[1]+";"; - else style += p[0]+":"+p[1]+";"; - } - return style ? " style=\""+style+"\"" : ""; - }, - invStyle: function(str) { - var s = /style=/.test(str) ? str.replace(/^.*?style=\"(.*?)\".*?$/, "$1") : "", - p = s && s.split(";"), pi, prop = []; - for (var i in p) { - pi = p[i].split(":"); - if (pi[0] == "margin-left" && pi[1]=="4em") prop.push(">"); - else if (pi[0] == "margin-right" && pi[1]=="4em") prop.push("<"); - else if (pi[0] == "float" && pi[1]=="right") prop.push(">>"); - else if (pi[0] == "float" && pi[1]=="left") prop.push("<<"); - else if (pi[0] == "margin" && pi[1]=="0 auto") prop.push("="); - else if (pi[0] == "display" && pi[1]=="block") ; - else if (pi[0] == "text-decoration" && pi[1]=="underline") prop.push("_"); - else if (pi[0] == "border" && pi[1]=="solid 1px") prop.push("b"); - else if (pi[0] == "color") prop.push("c:"+pi[1]); - else if (pi[0] == "background") prop.push("C:"+pi[1]); - else if (pi[0] == "width") prop.push("w:"+pi[1]); - else if (pi[0]) prop.push(pi[0]+":"+pi[1]); - } - return prop.length ? ("{" + prop.join(",") + "}") : ""; - }, - sectionRule: function(fromLevel, style, content, toLevel) { - var trf = { p_p: "

    $1

    ", - p_u: "

    $1

    ", - p_o: "

    $1

    ", - // p - ul - // ul - p - u_p: "$1", - u_c: "$1", - u_r: "$1", - uu_p: "$1", - uo_p: "$1", - uuu_p: "$1", - uou_p: "$1", - uuo_p: "$1", - uoo_p: "$1", - // ul - ul - u_u: "$1", - uu_u: "$1", - uo_u: "$1", - uuu_u: "$1", - uou_u: "$1", - uuo_u: "$1", - uoo_u: "$1", - u_uu: "$1", - // ul - ol - u_o: "$1", - uu_o: "$1", - uo_o: "$1", - uuu_o: "$1", - uou_o: "$1", - uuo_o: "$1", - uoo_o: "$1", - u_uo: "$1", - // ol - p - o_p: "$1", - oo_p: "$1", - ou_p: "$1", - ooo_p: "$1", - ouo_p: "$1", - oou_p: "$1", - ouu_p: "$1", - // ol - ul - o_u: "$1", - oo_u: "$1", - ou_u: "$1", - ooo_u: "$1", - ouo_u: "$1", - oou_u: "$1", - ouu_u: "$1", - o_ou: "$1", - // -- ol - ol -- - o_o: "$1", - oo_o: "$1", - ou_o: "$1", - ooo_o: "$1", - ouo_o: "$1", - oou_o: "$1", - ouu_o: "$1", - o_oo: "$1", - // -- dl -- - l_d: "
    $1
    ", - d_l: "
    $1
    ", - d_u: "
    $1
      ", - d_o: "
      $1
        ", - p_l: "

        $1

        ", - u_l: "$1
    ", - o_l: "$1
    ", - uu_l: "$1
    ", - uo_l: "$1
    ", - ou_l: "$1
    ", - oo_l: "$1
    ", - d_p: "
    $1
    ", - // -- table -- - p_t: "

    $1

    ", - p_r: "

    $1

    ", - p_c: "

    $1

    ", - t_p: "

    $1

    ", - r_r: "
    $1

    $1

    ", - r_c: "
    $1
    $1
      ", - c_p: "

    $1

    ", - c_r: "    		$1
    $1$1
      ", - u_t: "$1
    ", - o_t: "$1
    ", - d_t: "
    $1
    ", - t_u: "

    $1

      ", - t_o: "

    $1

      ", - t_l: "

      $1

      " - }; - var type = { "0": "decimal-leading-zero", - "1": "decimal", - "a": "lower-alpha", - "A": "upper-alpha", - "i": "lower-roman", - "I": "upper-roman", - "g": "lower-greek" }; - - var from = "", to = "", maxlen = Math.max(fromLevel.length, toLevel.length), sync = true, sectiontype = type[toLevel.charAt(toLevel.length-1)], transition; - - for (var i=0; i<\/p>/, ""); - } -} diff --git a/extra/webapps/article-manager/resources/wiky.lang.css b/extra/webapps/article-manager/resources/wiky.lang.css deleted file mode 100644 index 0d61d75ff1..0000000000 --- a/extra/webapps/article-manager/resources/wiky.lang.css +++ /dev/null @@ -1,9 +0,0 @@ -pre.syntax { font-size:100%; background: #eed; border:1px dotted #999; padding:0 0.5em; overflow:auto; } -span.cmt { font-style: italic; color: green; } -span.str { font-style: italic; color: darkred; } -span.kwd { color: blue; } -span.obj { color: purple; } -span.mbr { color: gray; } -span.xtag { color: blue; } -span.xnam { color: purple; } -span.xval { font-style: italic; color: darkred; } diff --git a/extra/webapps/article-manager/resources/wiky.lang.js b/extra/webapps/article-manager/resources/wiky.lang.js deleted file mode 100644 index dd53e83f35..0000000000 --- a/extra/webapps/article-manager/resources/wiky.lang.js +++ /dev/null @@ -1,40 +0,0 @@ -/* This work is licensed under Creative Commons GNU LGPL License. - - License: http://creativecommons.org/licenses/LGPL/2.1/ - - Author: Stefan Goessner/2005-06 - Web: http://goessner.net/ - - credits: http://www.regular-expressions.info/examplesprogrammer.html -*/ -Wiky.rules.lang.js = [ - "Wiky.rules.code", - { rex:/"([^"\\\xB6]*(\\.[^"\\\xB6]*)*)"/g, tmplt:function($0,$1){return Wiky.store("\""+$1+"\"");}}, // string delimited by '"' with '\"' allowed .. - { rex:/'([^'\\\xB6]*(\\.[^'\\\xB6]*)*)'/g, tmplt:function($0,$1){return Wiky.store("\'"+$1+"\'");}}, // string delimited by "'" with "\'" allowed .. - { rex:/\/\/(.*?)(?:\xB6|$)/g, tmplt:function($0,$1){return Wiky.store("//"+$1+"\xB6");}}, // single line comment - { rex:/\/\*(.*?)\*\//g, tmplt:function($0,$1){return Wiky.store("\/*"+$1+"*\/");}}, // multi-line comment -// { rex:/([\]\[\-+\|*!%<>=\{\}?:,\)\(]+)|("|/|=)+/g, tmplt:"$1"}, // operators - { rex:/\b(break|case|catch|continue|do|else|false|for|function|if|in|new|return|switch|this|throw|true|try|var|while|with)\b/g, tmplt:"$1" }, // keywords - { rex:/\b(arguments|Array|Boolean|Date|Error|Function|Global|Math|Number|Object|RegExp|String)\b/g, tmplt:"$1" }, // objects - { rex:/\.(abs|acos|anchor|arguments|asin|atan|atan2|big|blink|bold|callee|caller|ceil|charAt|charCodeAt|concat|constructor|cos|E|escape|eval|exp|fixed|floor|fontcolor|fontsize|fromCharCode|getDate|getDay|getFullYear|getHours|getMilliseconds|getMinutes|getMonth|getSeconds|getTime|getTimezoneOffset|getUTCDate|getUTCDay|getUTCFullYear|getUTCHours|getUTCMilliseconds|getUTCMinutes|getUTCMonth|getUTCSeconds|getVarDate|getYear|index|indexOf|Infinity|input|isFinite|isNaN|italics|join|lastIndex|lastIndexOf|lastMatch|lastParen|leftContext|length|link|LN10|LN2|log|LOG10E|LOG2E|match|max|MAX_VALUE|min|MIN_VALUE|NaN|NaN|NEGATIVE_INFINITY|parse|parseFloat|parseInt|PI|pop|POSITIVE_INFINITY|pow|prototype|push|random|replace|reverse|rightContext|round|search|setDate|setFullYear|setHours|setMilliseconds|setMinutes|setMonth|setSeconds|setTime|setUTCDate|setUTCFullYear|setUTCHours|setUTCMilliseconds|setUTCMinutes|setUTCMonth|setUTCSeconds|setYear|shift|sin|slice|slice|small|sort|splice|split|sqrt|SQRT1_2|SQRT2|strike|sub|substr|substring|sup|tan|toGMTString|toLocaleString|toLowerCase|toString|toUpperCase|toUTCString|unescape|unshift|UTC|valueOf)\b/g, tmplt:".$1" }, // members -]; -Wiky.rules.lang.xml = [ - { rex:/]*)>(.*?)<\/script>/g, tmplt:function($0,$1,$2){return ""+Wiky.store(Wiky.apply($2, Wiky.rules.lang.js))+"";} }, // script blocks .. - { rex://g, tmplt:function($0,$1){return Wiky.store("<![CDATA["+$1+"]]>");} }, // CDATA sections, .. - { rex://g, tmplt:function($0,$1){return Wiky.store("<!"+$1+">");} }, // inline xml comments, doctypes, .. - { rex://g, tmplt:"\xBB"}, // replace '>' by '»' - { rex:/([-A-Za-z0-9_:]+)[ ]*=[ ]*\"(.*?)\"/g, tmplt:"$1="$2""}, // "xml attribute value strings .. - { rex:/(\xAB[\/]?)([-A-Za-z0-9_:]+)/g, tmplt:"$1$2"}, // "xml tag .. - { rex:/\xAB/g, tmplt:"<"}, // replace '«' by '<' - { rex:/\xBB/g, tmplt:">"}, // replace '»' by '>' -]; -Wiky.inverse.lang.js = [ - { rex:/|<\/span>/mgi, tmplt:"" }, - { rex:/(.*?)<\/strong>/mgi, tmplt:"[*$1*]" }, - "Wiky.inverse.code" -]; -Wiky.inverse.lang.xml = [ - { rex:/|<\/span>/mgi, tmplt:"" }, - "Wiky.inverse.lang.js" -]; diff --git a/extra/webapps/article-manager/resources/wiky.math.css b/extra/webapps/article-manager/resources/wiky.math.css deleted file mode 100644 index de2a6f572d..0000000000 --- a/extra/webapps/article-manager/resources/wiky.math.css +++ /dev/null @@ -1,88 +0,0 @@ -/* math */ -dfn, div.eq { - white-space: nowrap; - font-family: sans-serif; - font-style: normal; - color: navy; -} -div.eq { - margin-left: 3em; - margin-right: 1em; -} -div.eq a {float:right} - -span.h { /* huge */ - font-size:150%; -} - -span.o, span.s, span.f { - display:-moz-inline-box; - -moz-box-orient:vertical; - display:inline-block; - vertical-align:middle; - margin:0 0.2em; -} - -span.x, span.i, span.d, span.n, span.o span { - display: block; -} - -span.x, span.d, span.n, span.s, span.o span { - text-align:center; - margin:0 0.2em; -} - -span.n, span.d { - font-size: 90%; -} - -span.i { - text-align: left; - margin:0 0.2em 0 0; -} -span.b { - font-weight: bold; -} - -span.x, span.i, span.f span.f { - font-size: 80%; -} - -span.n { - border-bottom:solid 1px navy; -} - -span.v, span.m { - display:-moz-inline-box; - -moz-box-orient:vertical; - display:inline-block; - vertical-align:middle; -} -span.v span.e, span.m span.e { - font-size: 90%; - white-space:nowrap; - display: block; - text-align:center; - margin:0.2em; -} -/*span.m > span.e { height:2em; }*/ /* hide ie 6 */ - -span.lb, span.rb { - margin:0; - padding:0; - vertical-align: middle; - border-top:1px solid navy; - border-bottom:1px solid navy; -} -span.lb { - border-left:1px solid navy; -} -span.rb { - border-right:1px solid navy; -} -span.lbrk2, span.rbrk2 { - font-size:200%; -} -span.lbrk3, span.rbrk3 { - font-size:300%; -} diff --git a/extra/webapps/article-manager/resources/wiky.math.js b/extra/webapps/article-manager/resources/wiky.math.js deleted file mode 100644 index 26cf41e266..0000000000 --- a/extra/webapps/article-manager/resources/wiky.math.js +++ /dev/null @@ -1,374 +0,0 @@ -/* This work is licensed under Creative Commons GNU LGPL License. - - License: http://creativecommons.org/licenses/LGPL/2.1/ - - Author: Stefan Goessner/2005-06 - Web: http://goessner.net/ - inspired by: http://xml-maiden.com/ -*/ -Wiky.rules.math = { - version: 0.95, - preshortcuts: [ -// { rex:/[ ]/g, tmplt:"`"}, // omit due to charset support ie6 - { rex:/\+\-/g, tmplt:"±"}, - { rex:/\/O|\\Oslash/g, tmplt:"Ø"}, - { rex:/\/o|\\oslash/g, tmplt:"ø"}, - { rex:/<->|\\harr/g, tmplt:"↔"}, - { rex:/<-|\\larr/g, tmplt:"←"}, - { rex:/->|\\rarr/g, tmplt:"→"}, - { rex:/<=>|\\hArr/g, tmplt:"⇔"}, - { rex:/=>|\\rArr/g, tmplt:"⇒"}, - { rex:/-=|\\equiv/g, tmplt:"≡"}, - { rex:/<=|\\le/g, tmplt:"≤"}, - { rex:/>=|\\ge/g, tmplt:"≥"}, - { rex://g, tmplt:">"} - ], - postshortcuts: [ - { rex:/\*|\\middot/g, tmplt:"·"}, - { rex:/\\x|\\times/g, tmplt:"×"}, - { rex:/~=|\\cong/g, tmplt:"≅"}, - { rex:/~~|\\asymp/g, tmplt:"≈"}, - { rex:/~|\\sim/g, tmplt:"∼"}, - { rex:/!=|\\neq|\\ne/g, tmplt:"≠"}, - { rex:/\.\.\.|\\ldots/g, tmplt:"…"}, - { rex:/\\in|\\isin/g, tmplt:"∈"}, - { rex:/([0-9])x([0-9])/g, tmplt:"$1×$2"}, - { rex:/([A-Za-z]) x ([A-Za-z])/g, tmplt:"$1×$2"}, -// { rex:/[`]{4}/g, tmplt:" "}, // omit due to charset support ie6 -// { rex:/[`]{3}/g, tmplt:" "}, -// { rex:/[`]{2}/g, tmplt:" "}, -// { rex:/[`]/g, tmplt:" "}, - { rex:/\{/g, tmplt:"‎"}, // unvisible left-to-right mark, - { rex:/\}/g, tmplt:"‏"} // unvisible right-to-left mark, - ], - expr: [ - { rex:/\^\^/g, tmplt:"^^"}, // ^ overindex - { rex:/(\\sum|\\prod|\\int)_([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})\^([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$3$1$2"}, // over-/underscript (\sum, \prod, \int) - { rex:/(\\sum|\\prod|\\int)\^([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$2$1 "}, - { rex:/(\\sum|\\prod|\\int)_([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:" $1$2"}, - { rex:/_([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})\^([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$2$1"}, // over-/underindex - { rex:/\^([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$1"}, // overindex - { rex:/_([-]?[a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$1"}, // underindex - { rex:/-/g, tmplt:"−"}, - { rex:/([a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})\/([a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$1$2"}, // fraction - { rex:/([a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})\/\/([a-zA-Z0-9\.&;#\\]+|\{@[0-9]+@\})/g, tmplt:"$1⁄$2"}, // fraction - { rex:/\[((\[(([^,\]]+[,]){1,}[^\]]+)\][ \n]*){1,})\]/g, tmplt:function($0,$1){var m=Wiky.math.transpose($1.replace(/(^\[|\]$)/g,"").replace(/(\][ \n]*\[)/g,"|").split("|")),sz=" style=\"font-size:"+(m.len)+"00%;\"";/*alert("{("+m.mat.join(")}\n{(").split(",").join(")(")+")}");*/ return ""+Wiky.math.fence()+""+m.mat.join("\n").split(",").join("")+""+Wiky.math.fence()+"";}}, // matrix - { rex:/\[((?:[^,\]]){1,}[^\]]+)\]/g, tmplt:function($0,$1){var v=$1.split(","),sz=" style=\"font-size:"+v.length+"00%;\""; return ""+Wiky.math.fence()+""+v.join("")+""+Wiky.math.fence()+"";}}, // vector - { rex:/!([a-zA-Z0-9\.&;]+)/g, tmplt:"$1" }, // bold vector symbol .. - { rex:/\\prod/g, tmplt:"∏"}, - { rex:/\\sum/g, tmplt:"∑"}, - { rex:/\\int/g, tmplt:"∫"}, - "Wiky.rules.math.postshortcuts" - ], - symbols: [ - { rex:/\\Alpha/g, tmplt:"Α"}, - { rex:/\\Beta/g, tmplt:"Β"}, - { rex:/\\Gamma/g, tmplt:"Γ"}, - { rex:/\\Delta/g, tmplt:"Δ"}, - { rex:/\\Epsilon/g, tmplt:"Ε"}, - { rex:/\\Zeta/g, tmplt:"Ζ"}, - { rex:/\\Eta/g, tmplt:"Η"}, - { rex:/\\Theta/g, tmplt:"Θ"}, - { rex:/\\Iota/g, tmplt:"Ι"}, - { rex:/\\Kappa/g, tmplt:"Κ"}, - { rex:/\\Lambda/g, tmplt:"Λ"}, - { rex:/\\Mu/g, tmplt:"Μ"}, - { rex:/\\Nu/g, tmplt:"Ν"}, - { rex:/\\Xi/g, tmplt:"Ξ"}, - { rex:/\\Omicron/g, tmplt:"Ο"}, - { rex:/\\Pi/g, tmplt:"Π"}, - { rex:/\\Rho/g, tmplt:"Ρ"}, - { rex:/\\Sigma/g, tmplt:"Σ"}, - { rex:/\\Tau/g, tmplt:"Τ"}, - { rex:/\\Upsilon/g, tmplt:"Υ"}, - { rex:/\\Phi/g, tmplt:"Φ"}, - { rex:/\\Chi/g, tmplt:"Χ"}, - { rex:/\\Psi/g, tmplt:"Ψ"}, - { rex:/\\Omega/g, tmplt:"Ω"}, - { rex:/\\alpha/g, tmplt:"α"}, - { rex:/\\beta/g, tmplt:"β"}, - { rex:/\\gamma/g, tmplt:"γ"}, - { rex:/\\delta/g, tmplt:"δ"}, - { rex:/\\epsilon/g, tmplt:"ε"}, - { rex:/\\zeta/g, tmplt:"ζ"}, - { rex:/\\eta/g, tmplt:"η"}, - { rex:/\\thetasym/g, tmplt:"ϑ"}, - { rex:/\\theta/g, tmplt:"θ"}, - { rex:/\\iota/g, tmplt:"ι"}, - { rex:/\\kappa/g, tmplt:"κ"}, - { rex:/\\lambda/g, tmplt:"λ"}, - { rex:/\\mu/g, tmplt:"μ"}, - { rex:/\\nu/g, tmplt:"ν"}, - { rex:/\\xi/g, tmplt:"ξ"}, - { rex:/\\omicron/g, tmplt:"ο"}, - { rex:/\\piv/g, tmplt:"ϖ"}, - { rex:/\\pi/g, tmplt:"π"}, - { rex:/\\rho/g, tmplt:"ρ"}, - { rex:/\\sigmaf/g, tmplt:"ς"}, - { rex:/\\sigma/g, tmplt:"σ"}, - { rex:/\\tau/g, tmplt:"τ"}, - { rex:/\\upsilon/g, tmplt:"υ"}, - { rex:/\\phi/g, tmplt:"φ"}, - { rex:/\\chi/g, tmplt:"χ"}, - { rex:/\\psi/g, tmplt:"ψ"}, - { rex:/\\omega/g, tmplt:"ω"}, - { rex:/\\upsih/g, tmplt:"ϒ"}, - // miscellaneous symbols - { rex:/\\bull/g, tmplt:"•"}, - { rex:/\\uarr/g, tmplt:"↑"}, - { rex:/\\darr/g, tmplt:"↓"}, - { rex:/\\crarr/g, tmplt:"↵"}, - { rex:/\\lArr/g, tmplt:"⇐"}, - { rex:/\\uArr/g, tmplt:"⇑"}, - { rex:/\\dArr/g, tmplt:"⇓"}, - { rex:/\\forall/g, tmplt:"∀"}, - { rex:/\\part/g, tmplt:"∂"}, - { rex:/\\exist/g, tmplt:"∃"}, - { rex:/\\empty/g, tmplt:"∅"}, - { rex:/\\nabla/g, tmplt:"∇"}, - { rex:/\\notin/g, tmplt:"∉"}, - { rex:/\\ni/g, tmplt:"∋"}, - { rex:/\\minus/g, tmplt:"−"}, - { rex:/\\lowast/g, tmplt:"∗"}, - { rex:/\\sqrt|\\radic/g, tmplt:"√"}, - { rex:/\\prop/g, tmplt:"∝"}, - { rex:/\\infin/g, tmplt:"∞"}, - { rex:/\\ang/g, tmplt:"∠"}, - { rex:/\\and/g, tmplt:"∧"}, - { rex:/\\or/g, tmplt:"∨"}, - { rex:/\\cap/g, tmplt:"∩"}, - { rex:/\\cup/g, tmplt:"∪"}, - { rex:/\\there4/g, tmplt:"∴"}, - { rex:/\\sub/g, tmplt:"⊂"}, - { rex:/\\sup/g, tmplt:"⊃"}, - { rex:/\\nsub/g, tmplt:"⊄"}, - { rex:/\\sube/g, tmplt:"⊆"}, - { rex:/\\supe/g, tmplt:"⊇"}, - { rex:/\\oplus/g, tmplt:"⊕"}, - { rex:/\\otimes/g, tmplt:"⊗"}, - { rex:/\\perp/g, tmplt:"⊥"}, - { rex:/\\sdot/g, tmplt:"⋅"} - ] -}; - -Wiky.inverse.math = { - pre: [ - { rex:/−|\u2212/g, tmplt:"-"}, - { rex:/ |\u2009/g, tmplt:" "}, - { rex:/‎|\u200E/g, tmplt:"{"}, - { rex:/‏|\u200F/g, tmplt:"}"} - ], - post: [ -// { rex:/([$])/g, tmplt:"\\$1" }, - { rex:/^|\x5E/g, tmplt:"^"}, - { rex:/</g, tmplt:"<"}, - { rex:/>/g, tmplt:">"} - ], - shortcuts: [ -// { rex:/ |\u2003/g, tmplt:" "}, // omit due to charset support ie6 -// { rex:/ |\u2002/g, tmplt:" "}, -// { rex:/ |\u2009/g, tmplt:" "}, - { rex:/±|\xB1/g, tmplt:"+-"}, - { rex:/·|\xB7/g, tmplt:"*"}, - { rex:/×|\xD7/g, tmplt:"\\x"}, - { rex:/Ø|\xD8/g, tmplt:"/O"}, - { rex:/ø|\xF8/g, tmplt:"/o"}, - { rex:/←|\u2190/g, tmplt:"<-"}, - { rex:/→|\u2192/g, tmplt:"->"}, - { rex:/↔|\u2194/g, tmplt:"<->"}, - { rex:/⇒|\u21D2/g, tmplt:"=>"}, - { rex:/⇔|\u21D4/g, tmplt:"<=>"}, - { rex:/∼|\u223C/g, tmplt:"~"}, - { rex:/≅|\u2245/g, tmplt:"~="}, - { rex:/≈|\u2248/g, tmplt:"~~"}, - { rex:/≠|\u2260/g, tmplt:"!="}, - { rex:/…/g, tmplt:"..."}, - { rex:/≡|\u2261/g, tmplt:"-="}, - { rex:/≤|\u2264/g, tmplt:"<="}, - { rex:/≥|\u2265/g, tmplt:">="} - ], - expr: [ - { rex:/(\{?@[0-9]+@\}?)<\/span>(\{?@[0-9]+@\}?)<\/span><\/span>/g, tmplt:"_$2^$1"}, // superscript + subscript - { rex:/(\{?@[0-9]+@\}?)<\/span>(\\prod|\\sum|\\int)(\{?@[0-9]+@\}?)<\/span><\/span>/g, tmplt:"$2_$3^$1"}, // overscript + underscript - { rex:/@[0-9]+@<\/span>(\\prod|\\sum|\\int)(\{?@[0-9]+@\}?)<\/span><\/span>/mgi, tmplt:"$1_$2", dbg:true}, // underscript - { rex:/(\{?@[0-9]+@\}?)<\/span>(\\prod|\\sum|\\int)@[0-9]+@<\/span><\/span>/mgi, tmplt:"$2^$1"}, // overscript - { rex:/(\{?@[0-9]+@\}?)<\/span>(\{?@[0-9]+@\}?)<\/span><\/span>/mgi, tmplt:"$1/$2"}, // fraction - { rex:/]*>&[^;]+;<\/span>((?:[^>]*<\/span>){2,})<\/span>]*>&[^;]+;<\/span>/mgi, tmplt:function($0,$1){return "["+$1.replace(/(?:^|<\/span>$)/g,"").replace(/<\/span>/g,",")+"]";}}, // vector .. - { rex:/]*>&[^;]+;<\/span>((?:(?:(?:[^>]*<\/span>){2,})<\/span>[^>]*){2,})]*>&[^;]+;<\/span>/mgi, tmplt:function($0,$1){return "[["+Wiky.math.transpose($1.replace(/(?:^|<\/span><\/span>$)/g,"").replace(/<\/span>/g,",").replace(/<\/span><\/span>[^>]*/g,"|").split("|")).mat.join("][")+"]]";}}, // matrix .. - { rex:/(@[0-9]+@)<\/span>/mgi, tmplt:"!$1"}, // bold vector .. - { rex:/(\{?@[0-9]+@\}?)<\/sup>⁄(\{?@[0-9]+@\}?)<\/sub>/mgi, tmplt:"$1//$2"}, - { rex:/(\{?@[0-9]+@\}?)<\/sup>/mgi, tmplt:"^$1" }, - { rex:/(\{?@[0-9]+@\}?)<\/sub>/mgi, tmplt:"_$1" } - ], - symbols: [ - // greek symbols - { rex:/Α|\u391/g, tmplt:"\\Alpha"}, - { rex:/Β|\u392/g, tmplt:"\\Beta"}, - { rex:/Γ|\u393/g, tmplt:"\\Gamma"}, - { rex:/Δ|\u394/g, tmplt:"\\Delta"}, - { rex:/Ε|\u395/g, tmplt:"\\Epsilon"}, - { rex:/Ζ|\u396/g, tmplt:"\\Zeta"}, - { rex:/Η|\u397/g, tmplt:"\\Eta"}, - { rex:/Θ|\u398/g, tmplt:"\\Theta"}, - { rex:/Ι|\u399/g, tmplt:"\\Iota"}, - { rex:/Κ|\u39A/g, tmplt:"\\Kappa"}, - { rex:/Λ|\u39B/g, tmplt:"\\Lambda"}, - { rex:/Μ|\u39C/g, tmplt:"\\Mu"}, - { rex:/Ν|\u39D/g, tmplt:"\\Nu"}, - { rex:/Ξ|\u39E/g, tmplt:"\\Xi"}, - { rex:/Ο|\u39F/g, tmplt:"\\Omicron"}, - { rex:/Π|\u3A0/g, tmplt:"\\Pi"}, - { rex:/Ρ|\u3A1/g, tmplt:"\\Rho"}, - { rex:/Σ|\u3A3/g, tmplt:"\\Sigma"}, - { rex:/Τ|\u3A4/g, tmplt:"\\Tau"}, - { rex:/Υ|\u3A5/g, tmplt:"\\Upsilon"}, - { rex:/Φ|\u3A6/g, tmplt:"\\Phi"}, - { rex:/Χ|\u3A7/g, tmplt:"\\Chi"}, - { rex:/Ψ|\u3A8/g, tmplt:"\\Psi"}, - { rex:/Ω|\u3A9/g, tmplt:"\\Omega"}, - { rex:/α|\u3B1/g, tmplt:"\\alpha"}, - { rex:/β|\u3B2/g, tmplt:"\\beta"}, - { rex:/γ|\u3B3/g, tmplt:"\\gamma"}, - { rex:/δ|\u3B4/g, tmplt:"\\delta"}, - { rex:/ε|\u3B5/g, tmplt:"\\epsilon"}, - { rex:/ζ|\u3B6/g, tmplt:"\\zeta"}, - { rex:/η|\u3B7/g, tmplt:"\\eta"}, - { rex:/ϑ|\u3D1/g, tmplt:"\\thetasym"}, - { rex:/θ|\u3B8/g, tmplt:"\\theta"}, - { rex:/ι|\u3B9/g, tmplt:"\\iota"}, - { rex:/κ|\u3BA/g, tmplt:"\\kappa"}, - { rex:/λ|\u3BB/g, tmplt:"\\lambda"}, - { rex:/μ|\u3BC/g, tmplt:"\\mu"}, - { rex:/ν|\u3BD/g, tmplt:"\\nu"}, - { rex:/ξ|\u3BE/g, tmplt:"\\xi"}, - { rex:/ο|\u3BF/g, tmplt:"\\omicron"}, - { rex:/π|\u3C0/g, tmplt:"\\pi"}, - { rex:/ρ|\u3C1/g, tmplt:"\\rho"}, - { rex:/ς|\u3C2/g, tmplt:"\\sigmaf"}, - { rex:/σ|\u3C3/g, tmplt:"\\sigma"}, - { rex:/τ|\u3C4/g, tmplt:"\\tau"}, - { rex:/υ|\u3C5/g, tmplt:"\\upsilon"}, - { rex:/φ|\u3C6/g, tmplt:"\\phi"}, - { rex:/χ|\u3C7/g, tmplt:"\\chi"}, - { rex:/ψ|\u3C8/g, tmplt:"\\psi"}, - { rex:/ω|\u3C9/g, tmplt:"\\omega"}, - // miscellaneous symbols - { rex:/ϒ|\u3D2/g, tmplt:"\\upsih"}, - { rex:/ϖ|\u3D6/g, tmplt:"\\piv"}, - { rex:/•|\u2022/g, tmplt:"\\bull"}, - { rex:/↑|\u2191/g, tmplt:"\\uarr"}, - { rex:/↓|\u2193/g, tmplt:"\\darr"}, - { rex:/↵|\u21B5/g, tmplt:"\\crarr"}, - { rex:/⇐|\u21D0/g, tmplt:"\\lArr"}, - { rex:/⇑|\u21D1/g, tmplt:"\\uArr"}, - { rex:/⇓|\u21D3/g, tmplt:"\\dArr"}, - { rex:/∀|\u2200/g, tmplt:"\\forall"}, - { rex:/∂|\u2202/g, tmplt:"\\part"}, - { rex:/∃|\u2203/g, tmplt:"\\exist"}, - { rex:/∅|\u2205/g, tmplt:"\\empty"}, - { rex:/∇|\u2207/g, tmplt:"\\nabla"}, - { rex:/∈|\u2208/g, tmplt:"\\isin"}, - { rex:/∉|\u2209/g, tmplt:"\\notin"}, - { rex:/∋|\u220B/g, tmplt:"\\ni"}, - { rex:/(∏|\u220F)<\/span>/g, tmplt:"\\prod"}, - { rex:/(∑|\u2211)<\/span>/g, tmplt:"\\sum"}, - { rex:/∗|\u2217/g, tmplt:"\\lowast"}, - { rex:/√|\u221A/g, tmplt:"\\sqrt"}, - { rex:/∝|\u221D/g, tmplt:"\\prop"}, - { rex:/∞|\u221E/g, tmplt:"\\infin"}, - { rex:/∠|\u2220/g, tmplt:"\\ang"}, - { rex:/∧|\u2227/g, tmplt:"\\and"}, - { rex:/∨|\u2228/g, tmplt:"\\or"}, - { rex:/∩|\u2229/g, tmplt:"\\cap"}, - { rex:/∪|\u222A/g, tmplt:"\\cup"}, - { rex:/(?:∫|\u222B)<\/span>/g, tmplt:"\\int"}, - { rex:/∴|\u2234/g, tmplt:"\\there4"}, - { rex:/⊂|\u2282/g, tmplt:"\\sub"}, - { rex:/⊃|\u2283/g, tmplt:"\\sup"}, - { rex:/⊄|\u2284/g, tmplt:"\\nsub"}, - { rex:/⊆|\u2286/g, tmplt:"\\sube"}, - { rex:/⊇|\u2287/g, tmplt:"\\supe"}, - { rex:/⊕|\u2295/g, tmplt:"\\oplus"}, - { rex:/⊗|\u2297/g, tmplt:"\\otimes"}, - { rex:/⊥|\u22A5/g, tmplt:"\\perp"}, - { rex:/⋅|\u22C5/g, tmplt:"\\sdot"} - ] -}; - -Wiky.math = { - toHtml: function(str) { - var expr = function(itr) { // region from "{" to "}", nesting allowed .. - var s = ""; - for (var c = itr.str.charAt(itr.pos++); itr.pos <= itr.str.length && c != "}"; c = itr.str.charAt(itr.pos++)) - s += (c == "{") ? ("{"+expr(itr)+"}") : c; - return Wiky.store(Wiky.apply(s, Wiky.rules.math.expr)); - }; - str = Wiky.apply(str, Wiky.rules.math.preshortcuts); - str = Wiky.apply(str, Wiky.rules.math.symbols); - str = expr({str:str,pos:0}); - return str; - }, - toWiki: function(str) { - var parseTree = function(itr, endtag) { - var c, s="",gt,nam,idxof=function(s,c,p){var i=s.indexOf(c,p);return i>=0?i:s.length;} - for (itr.buf=itr.str.substr(itr.pos,endtag.length); - itr.pos",itr.pos)) < idxof(itr.str,"/",itr.pos)) { // start tags .. no empty elements or endtags .. - nam = itr.str.substring(itr.pos+1,Math.min(idxof(itr.str," ",itr.pos),gt)); - s += itr.str.substring(itr.pos,itr.pos=gt+1) + parseTree(itr, "") + ""; - itr.pos += nam.length+3; - } - else - s += c; - } - itr.pos--; - return Wiky.store(s, true); - }; - str = Wiky.apply(str, Wiky.inverse.math.pre); - str = Wiky.apply(str, Wiky.inverse.math.symbols); - str = parseTree({str:str,pos:0,buf:null}, ""); - while (str.match(/@[0-9]+@/g) != null) - str = Wiky.apply(str.replace(/@([0-9]+)@/g, function($0,$1){return Wiky.restore($1);}), Wiky.inverse.math.expr); - str = Wiky.apply(str, Wiky.inverse.math.shortcuts); - str = Wiky.apply(str, Wiky.inverse.math.post); - return str; - }, - fence: function(str) { - return window && window.ActiveXObject ? " " : " "; - }, - transpose: function (m) { - var t=[]; - for (var i in m) { - m[i] = m[i].split(","); - for (var j in m[i]) { - if (!t[j]) t[j]=[]; - t[j][i] = m[i][j]; - } - } - for (var i in t) - t[i] = t[i].join(","); - return {mat:t, len:m.length}; - } -}; - -Wiky.rules.pre = Wiky.rules.pre.concat({ rex:/\\([$])/g, tmplt:function($0,$1){return Wiky.store($1);} }); -Wiky.rules.nonwikiblocks = Wiky.rules.nonwikiblocks.concat( -[ - { rex:/\[\(([a-zA-Z0-9\.-]+)\)\$([^$]*)\$\]/g, tmplt:function($0,$1,$2){return ":p]
      ("+$1+")" + Wiky.math.toHtml($2) + "
      [p:";} }, // numbered equation - { rex:/\[\$([^$]*)\$\]/g, tmplt:function($0,$1){return ":p]
      " + Wiky.math.toHtml($1) + "
      [p:";} }, // equation -]); -Wiky.rules.nonwikiinlines = Wiky.rules.nonwikiinlines.concat( - { rex:/\$([^$]*)\$/g, tmplt:function($0,$1){return "" + Wiky.math.toHtml($1) + "";} } // inline equation -); - -Wiky.inverse.pre = Wiky.inverse.pre.concat({ rex:/([\$])/g, tmplt:"\\$1" }); -Wiky.inverse.nonwikiblocks = Wiky.inverse.nonwikiblocks.concat( -[ - { rex:/
      (?:.*?)<\/a>(.*?)<\/div>/g, tmplt:function($0,$1,$2){return Wiky.store("[("+$1+")$"+Wiky.math.toWiki($2)+"$]");} }, // numbered equation - { rex:/
      (.*?)<\/div>/g, tmplt:function($0,$1){return Wiky.store("[$"+Wiky.math.toWiki($1)+"$]");} }, // equation -]); -Wiky.inverse.nonwikiinlines = Wiky.inverse.nonwikiinlines.concat( - { rex:/(.*?)<\/dfn>/g, tmplt:function($0,$1){return Wiky.store("$"+Wiky.math.toWiki($1)+"$");} } // inline equation -); diff --git a/extra/webapps/article-manager/summary.txt b/extra/webapps/article-manager/summary.txt deleted file mode 100644 index cc43bdd56b..0000000000 --- a/extra/webapps/article-manager/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Article Manager web application diff --git a/extra/webapps/article-manager/tags.txt b/extra/webapps/article-manager/tags.txt deleted file mode 100644 index 1b93c9eb4d..0000000000 --- a/extra/webapps/article-manager/tags.txt +++ /dev/null @@ -1 +0,0 @@ -webapp diff --git a/unmaintained/jni/jni-internals.factor b/unmaintained/jni/jni-internals.factor deleted file mode 100644 index 49bc57b108..0000000000 --- a/unmaintained/jni/jni-internals.factor +++ /dev/null @@ -1,357 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -IN: jni-internals -USING: kernel alien arrays sequences ; - -LIBRARY: jvm - -TYPEDEF: int jint -TYPEDEF: uchar jboolean -TYPEDEF: void* JNIEnv - -C-STRUCT: jdk-init-args - { "jint" "version" } - { "void*" "properties" } - { "jint" "check-source" } - { "jint" "native-stack-size" } - { "jint" "java-stack-size" } - { "jint" "min-heap-size" } - { "jint" "max-heap-size" } - { "jint" "verify-mode" } - { "char*" "classpath" } - { "void*" "vprintf" } - { "void*" "exit" } - { "void*" "abort" } - { "jint" "enable-class-gc" } - { "jint" "enable-verbose-gc" } - { "jint" "disable-async-gc" } - { "jint" "verbose" } - { "jboolean" "debugging" } - { "jint" "debug-port" } ; - -C-STRUCT: JNIInvokeInterface - { "void*" "reserved0" } - { "void*" "reserved1" } - { "void*" "reserved2" } - { "void*" "DestroyJavaVM" } - { "void*" "AttachCurrentThread" } - { "void*" "DetachCurrentThread" } - { "void*" "GetEnv" } - { "void*" "AttachCurrentThreadAsDaemon" } ; - -C-STRUCT: JavaVM - { "JNIInvokeInterface*" "functions" } ; - -C-STRUCT: JNINativeInterface - { "void*" "reserved0" } - { "void*" "reserved1" } - { "void*" "reserved2" } - { "void*" "reserved3" } - { "void*" "GetVersion" } - { "void*" "DefineClass" } - { "void*" "FindClass" } - { "void*" "FromReflectedMethod" } - { "void*" "FromReflectedField" } - { "void*" "ToReflectedMethod" } - { "void*" "GetSuperclass" } - { "void*" "IsAssignableFrom" } - { "void*" "ToReflectedField" } - { "void*" "Throw" } - { "void*" "ThrowNew" } - { "void*" "ExceptionOccurred" } - { "void*" "ExceptionDescribe" } - { "void*" "ExceptionClear" } - { "void*" "FatalError" } - { "void*" "PushLocalFrame" } - { "void*" "PopLocalFrame" } - { "void*" "NewGlobalRef" } - { "void*" "DeleteGlobalRef" } - { "void*" "DeleteLocalRef" } - { "void*" "IsSameObject" } - { "void*" "NewLocalRef" } - { "void*" "EnsureLocalCapacity" } - { "void*" "AllocObject" } - { "void*" "NewObject" } - { "void*" "NewObjectV" } - { "void*" "NewObjectA" } - { "void*" "GetObjectClass" } - { "void*" "IsInstanceOf" } - { "void*" "GetMethodID" } - { "void*" "CallObjectMethod" } - { "void*" "CallObjectMethodV" } - { "void*" "CallObjectMethodA" } - { "void*" "CallBooleanMethod" } - { "void*" "CallBooleanMethodV" } - { "void*" "CallBooleanMethodA" } - { "void*" "CallByteMethod" } - { "void*" "CallByteMethodV" } - { "void*" "CallByteMethodA" } - { "void*" "CallCharMethod" } - { "void*" "CallCharMethodV" } - { "void*" "CallCharMethodA" } - { "void*" "CallShortMethod" } - { "void*" "CallShortMethodV" } - { "void*" "CallShortMethodA" } - { "void*" "CallIntMethod" } - { "void*" "CallIntMethodV" } - { "void*" "CallIntMethodA" } - { "void*" "CallLongMethod" } - { "void*" "CallLongMethodV" } - { "void*" "CallLongMethodA" } - { "void*" "CallFloatMethod" } - { "void*" "CallFloatMethodV" } - { "void*" "CallFloatMethodA" } - { "void*" "CallDoubleMethod" } - { "void*" "CallDoubleMethodV" } - { "void*" "CallDoubleMethodA" } - { "void*" "CallVoidMethod" } - { "void*" "CallVoidMethodV" } - { "void*" "CallVoidMethodA" } - { "void*" "CallNonvirtualObjectMethod" } - { "void*" "CallNonvirtualObjectMethodV" } - { "void*" "CallNonvirtualObjectMethodA" } - { "void*" "CallNonvirtualBooleanMethod" } - { "void*" "CallNonvirtualBooleanMethodV" } - { "void*" "CallNonvirtualBooleanMethodA" } - { "void*" "CallNonvirtualByteMethod" } - { "void*" "CallNonvirtualByteMethodV" } - { "void*" "CallNonvirtualByteMethodA" } - { "void*" "CallNonvirtualCharMethod" } - { "void*" "CallNonvirtualCharMethodV" } - { "void*" "CallNonvirtualCharMethodA" } - { "void*" "CallNonvirtualShortMethod" } - { "void*" "CallNonvirtualShortMethodV" } - { "void*" "CallNonvirtualShortMethodA" } - { "void*" "CallNonvirtualIntMethod" } - { "void*" "CallNonvirtualIntMethodV" } - { "void*" "CallNonvirtualIntMethodA" } - { "void*" "CallNonvirtualLongMethod" } - { "void*" "CallNonvirtualLongMethodV" } - { "void*" "CallNonvirtualLongMethodA" } - { "void*" "CallNonvirtualFloatMethod" } - { "void*" "CallNonvirtualFloatMethodV" } - { "void*" "CallNonvirtualFloatMethodA" } - { "void*" "CallNonvirtualDoubleMethod" } - { "void*" "CallNonvirtualDoubleMethodV" } - { "void*" "CallNonvirtualDoubleMethodA" } - { "void*" "CallNonvirtualVoidMethod" } - { "void*" "CallNonvirtualVoidMethodV" } - { "void*" "CallNonvirtualVoidMethodA" } - { "void*" "GetFieldID" } - { "void*" "GetObjectField" } - { "void*" "GetBooleanField" } - { "void*" "GetByteField" } - { "void*" "GetCharField" } - { "void*" "GetShortField" } - { "void*" "GetIntField" } - { "void*" "GetLongField" } - { "void*" "GetFloatField" } - { "void*" "GetDoubleField" } - { "void*" "SetObjectField" } - { "void*" "SetBooleanField" } - { "void*" "SetByteField" } - { "void*" "SetCharField" } - { "void*" "SetShortField" } - { "void*" "SetIntField" } - { "void*" "SetLongField" } - { "void*" "SetFloatField" } - { "void*" "SetDoubleField" } - { "void*" "GetStaticMethodID" } - { "void*" "CallStaticObjectMethod" } - { "void*" "CallStaticObjectMethodV" } - { "void*" "CallStaticObjectMethodA" } - { "void*" "CallStaticBooleanMethod" } - { "void*" "CallStaticBooleanMethodV" } - { "void*" "CallStaticBooleanMethodA" } - { "void*" "CallStaticByteMethod" } - { "void*" "CallStaticByteMethodV" } - { "void*" "CallStaticByteMethodA" } - { "void*" "CallStaticCharMethod" } - { "void*" "CallStaticCharMethodV" } - { "void*" "CallStaticCharMethodA" } - { "void*" "CallStaticShortMethod" } - { "void*" "CallStaticShortMethodV" } - { "void*" "CallStaticShortMethodA" } - { "void*" "CallStaticIntMethod" } - { "void*" "CallStaticIntMethodV" } - { "void*" "CallStaticIntMethodA" } - { "void*" "CallStaticLongMethod" } - { "void*" "CallStaticLongMethodV" } - { "void*" "CallStaticLongMethodA" } - { "void*" "CallStaticFloatMethod" } - { "void*" "CallStaticFloatMethodV" } - { "void*" "CallStaticFloatMethodA" } - { "void*" "CallStaticDoubleMethod" } - { "void*" "CallStaticDoubleMethodV" } - { "void*" "CallStaticDoubleMethodA" } - { "void*" "CallStaticVoidMethod" } - { "void*" "CallStaticVoidMethodV" } - { "void*" "CallStaticVoidMethodA" } - { "void*" "GetStaticFieldID" } - { "void*" "GetStaticObjectField" } - { "void*" "GetStaticBooleanField" } - { "void*" "GetStaticByteField" } - { "void*" "GetStaticCharField" } - { "void*" "GetStaticShortField" } - { "void*" "GetStaticIntField" } - { "void*" "GetStaticLongField" } - { "void*" "GetStaticFloatField" } - { "void*" "GetStaticDoubleField" } - { "void*" "SetStaticObjectField" } - { "void*" "SetStaticBooleanField" } - { "void*" "SetStaticByteField" } - { "void*" "SetStaticCharField" } - { "void*" "SetStaticShortField" } - { "void*" "SetStaticIntField" } - { "void*" "SetStaticLongField" } - { "void*" "SetStaticFloatField" } - { "void*" "SetStaticDoubleField" } - { "void*" "NewString" } - { "void*" "GetStringLength" } - { "void*" "GetStringChars" } - { "void*" "ReleaseStringChars" } - { "void*" "NewStringUTF" } - { "void*" "GetStringUTFLength" } - { "void*" "GetStringUTFChars" } - { "void*" "ReleaseStringUTFChars" } - { "void*" "GetArrayLength" } - { "void*" "NewObjectArray" } - { "void*" "GetObjectArrayElement" } - { "void*" "SetObjectArrayElement" } - { "void*" "NewBooleanArray" } - { "void*" "NewByteArray" } - { "void*" "NewCharArray" } - { "void*" "NewShortArray" } - { "void*" "NewIntArray" } - { "void*" "NewLongArray" } - { "void*" "NewFloatArray" } - { "void*" "NewDoubleArray" } - { "void*" "GetBooleanArrayElements" } - { "void*" "GetByteArrayElements" } - { "void*" "GetCharArrayElements" } - { "void*" "GetShortArrayElements" } - { "void*" "GetIntArrayElements" } - { "void*" "GetLongArrayElements" } - { "void*" "GetFloatArrayElements" } - { "void*" "GetDoubleArrayElements" } - { "void*" "ReleaseBooleanArrayElements" } - { "void*" "ReleaseByteArrayElements" } - { "void*" "ReleaseCharArrayElements" } - { "void*" "ReleaseShortArrayElements" } - { "void*" "ReleaseIntArrayElements" } - { "void*" "ReleaseLongArrayElements" } - { "void*" "ReleaseFloatArrayElements" } - { "void*" "ReleaseDoubleArrayElements" } - { "void*" "GetBooleanArrayRegion" } - { "void*" "GetByteArrayRegion" } - { "void*" "GetCharArrayRegion" } - { "void*" "GetShortArrayRegion" } - { "void*" "GetIntArrayRegion" } - { "void*" "GetLongArrayRegion" } - { "void*" "GetFloatArrayRegion" } - { "void*" "GetDoubleArrayRegion" } - { "void*" "SetBooleanArrayRegion" } - { "void*" "SetByteArrayRegion" } - { "void*" "SetCharArrayRegion" } - { "void*" "SetShortArrayRegion" } - { "void*" "SetIntArrayRegion" } - { "void*" "SetLongArrayRegion" } - { "void*" "SetFloatArrayRegion" } - { "void*" "SetDoubleArrayRegion" } - { "void*" "RegisterNatives" } - { "void*" "UnregisterNatives" } - { "void*" "MonitorEnter" } - { "void*" "MonitorExit" } - { "void*" "GetJavaVM" } - { "void*" "GetStringRegion" } - { "void*" "GetStringUTFRegion" } - { "void*" "GetPrimitiveArrayCritical" } - { "void*" "ReleasePrimitiveArrayCritical" } - { "void*" "GetStringCritical" } - { "void*" "ReleaseStringCritical" } - { "void*" "NewWeakGlobalRef" } - { "void*" "DeleteWeakGlobalRef" } - { "void*" "ExceptionCheck" } - { "void*" "NewDirectByteBuffer" } - { "void*" "GetDirectBufferAddress" } - { "void*" "GetDirectBufferCapacity" } ; - -C-STRUCT: JNIEnv - { "JNINativeInterface*" "functions" } ; - -FUNCTION: jint JNI_GetDefaultJavaVMInitArgs ( jdk-init-args* args ) ; -FUNCTION: jint JNI_CreateJavaVM ( void** pvm, void** penv, void* args ) ; - -: ( -- jdk-init-args ) - "jdk-init-args" HEX: 00010004 over set-jdk-init-args-version ; - -: jni1 ( -- init-args int ) - dup JNI_GetDefaultJavaVMInitArgs ; - -: jni2 ( -- vm env int ) - f f [ - jni1 drop JNI_CreateJavaVM - ] 2keep rot dup 0 = [ - >r >r 0 swap void*-nth r> 0 swap void*-nth r> - ] when ; - -: (destroy-java-vm) - "int" { "void*" } "cdecl" alien-indirect ; - -: (attach-current-thread) - "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ; - -: (detach-current-thread) - "int" { "void*" } "cdecl" alien-indirect ; - -: (get-env) - "int" { "void*" "void*" "int" } "cdecl" alien-indirect ; - -: (attach-current-thread-as-daemon) - "int" { "void*" "void*" "void*" } "cdecl" alien-indirect ; - -: destroy-java-vm ( javavm -- int ) - dup JavaVM-functions JNIInvokeInterface-DestroyJavaVM (destroy-java-vm) ; - -: (get-version) - "jint" { "JNIEnv*" } "cdecl" alien-indirect ; - -: get-version ( jnienv -- int ) - dup JNIEnv-functions JNINativeInterface-GetVersion (get-version) ; - -: (find-class) - "void*" { "JNINativeInterface*" "char*" } "cdecl" alien-indirect ; - -: find-class ( name jnienv -- int ) - dup swapd JNIEnv-functions JNINativeInterface-FindClass (find-class) ; - -: (get-static-field-id) - "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ; - -: get-static-field-id ( class name sig jnienv -- int ) - dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetStaticFieldID (get-static-field-id) ; - -: (get-static-object-field) - "void*" { "JNINativeInterface*" "void*" "void*" } "cdecl" alien-indirect ; - -: get-static-object-field ( class id jnienv -- int ) - dup >r >r 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-GetStaticObjectField (get-static-object-field) ; - -: (get-method-id) - "void*" { "JNINativeInterface*" "void*" "char*" "char*" } "cdecl" alien-indirect ; - -: get-method-id ( class name sig jnienv -- int ) - dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-GetMethodID (get-method-id) ; - -: (new-string) - "void*" { "JNINativeInterface*" "char*" "int" } "cdecl" alien-indirect ; - -: new-string ( str jnienv -- str ) - dup >r >r dup length 2array r> swap first2 r> JNIEnv-functions JNINativeInterface-NewString (new-string) ; - -: (call1) - "void" { "JNINativeInterface*" "void*" "void*" "int" } "cdecl" alien-indirect ; - -: call1 ( obj method-id jstr jnienv -- ) - dup >r >r 3array r> swap first3 r> JNIEnv-functions JNINativeInterface-CallObjectMethod (call1) ; - diff --git a/unmaintained/jni/jni.factor b/unmaintained/jni/jni.factor deleted file mode 100644 index 86e1670c50..0000000000 --- a/unmaintained/jni/jni.factor +++ /dev/null @@ -1,22 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -IN: jni -USING: kernel jni-internals namespaces ; - -! High level interface for JNI to be added here... - -: test0 ( -- ) - jni2 drop nip "env" set ; - -: test1 ( -- system ) - "java/lang/System" "env" get find-class ; - -: test2 ( system -- system.out ) - dup "out" "Ljava/io/PrintStream;" "env" get get-static-field-id - "env" get get-static-object-field ; - -: test3 ( int system.out -- ) - "java/io/PrintStream" "env" get find-class ! jstr out class - "println" "(I)V" "env" get get-method-id ! jstr out id - rot "env" get call1 ; - \ No newline at end of file diff --git a/unmaintained/jni/load.factor b/unmaintained/jni/load.factor deleted file mode 100644 index f5fd45c8d9..0000000000 --- a/unmaintained/jni/load.factor +++ /dev/null @@ -1,4 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -PROVIDE: libs/jni -{ +files+ { "jni-internals.factor" "jni.factor" } } ; diff --git a/unmaintained/reader/reader.factor b/unmaintained/reader/reader.factor deleted file mode 100644 index 205b51b72c..0000000000 --- a/unmaintained/reader/reader.factor +++ /dev/null @@ -1,133 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -! Create a test database like follows: -! -! sqlite3 history.db -! > create table rss (url text, title text, link text, primary key (url)); -! > create table entries (url text, link text, title text, description text, pubdate text, primary key(url, link)); -! > [eof] -! -IN: rss.reader -USING: kernel html namespaces sequences io quotations -assocs sqlite.tuple-db sqlite io.files html.elements -rss webapps.continuation ; - -TUPLE: reader-feed url title link ; - -C: reader-feed - -TUPLE: reader-entry url link title description pubdate ; - -C: reader-entry - -reader-feed default-mapping set-mapping -reader-entry default-mapping set-mapping - -: init-db ( -- ) - db get-global [ sqlite-close ] when* - "rss-reader.db" exists? [ - "rss-reader.db" sqlite-open db set-global - ] [ - "rss-reader.db" sqlite-open dup db set-global - dup reader-feed create-tuple-table - reader-entry create-tuple-table - ] if ; - -: add-feed ( url -- ) - "" "" db get swap insert-tuple ; - -: remove-feed ( url -- ) - f f db get swap find-tuples [ db get swap delete-tuple ] each ; - -: all-urls ( -- urls ) - f f f db get swap find-tuples [ reader-feed-url ] map ; - -: ask-for-url ( -- url ) - [ - - "Enter a Feed URL" write - -
      - "URL: " write - - -
      - - - ] show "url" swap at ; - -: get-entries ( url -- entries ) - f f f f db get swap find-tuples ; - -: display-entries ( url -- ) - [ - - "View entries for " write over write - - swap get-entries [ -

      dup reader-entry-title write

      -

      - reader-entry-description write -

      - ] each -

      "Back" write

      - - - ] show 2drop ; - -: rss>reader-feed ( url rss -- reader-feed ) - [ feed-title ] keep feed-link ; - -: rss-entry>reader-entry ( url entry -- reader-entry ) - [ entry-link ] keep - [ entry-title ] keep - [ entry-description ] keep - entry-pub-date - ; - -: update-feed-database ( url -- ) - dup remove-feed - dup news-get - 2dup rss>reader-feed db get swap save-tuple - feed-entries [ - dupd rss-entry>reader-entry - dup >r reader-entry-link f f f db get swap find-tuples [ db get swap delete-tuple ] each r> - db get swap save-tuple - ] curry* each ; - -: update-feeds ( seq -- ) - [ update-feed-database ] each - [ - - "Feeds Updated" write - -

      "Feeds Updated." write

      -

      "Back" write

      - - - ] show drop ; - -: maintain-feeds ( -- ) - [ - - "Maintain Feeds" write - -

      - - all-urls [ - - - - - - ] each -
      dup write dup [ remove-feed ] curry "Remove" swap quot-href [ display-entries ] curry "Database" swap quot-href
      -

      -

      "Add Feed" [ ask-for-url add-feed ] quot-href

      -

      "Update Feeds" [ all-urls update-feeds ] quot-href

      - - - ] show-final ; - -"maintain-feeds" [ init-db maintain-feeds ] install-cont-responder diff --git a/unmaintained/usb/load.factor b/unmaintained/usb/load.factor deleted file mode 100644 index 7c5eda2446..0000000000 --- a/unmaintained/usb/load.factor +++ /dev/null @@ -1,13 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel ; - -PROVIDE: libs/usb -{ +files+ { - "usb-common.factor" - { "usb-unix.factor" [ unix? ] } - { "usb-win32.factor" [ win32? ] } - { "usb-macosx.factor" [ macosx? ] } - "usb.factor" - "usb.facts" -} } ; diff --git a/unmaintained/usb/usb-common.factor b/unmaintained/usb/usb-common.factor deleted file mode 100644 index 0baca0e0fc..0000000000 --- a/unmaintained/usb/usb-common.factor +++ /dev/null @@ -1,3 +0,0 @@ -IN: usb - -: +packed+ ; parsing diff --git a/unmaintained/usb/usb-macosx.factor b/unmaintained/usb/usb-macosx.factor deleted file mode 100644 index 43a6caa8da..0000000000 --- a/unmaintained/usb/usb-macosx.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: usb -USING: kernel alien ; - -"usb" "libusb.dylib" "cdecl" add-library - -LIBRARY: usb - -C-STRUCT: usb_bus - { "void*" "next" } - { "void*" "prev" } - { { "char" 1025 } "dirname" } - { "void*" "devices" } - { "uint" "location" } - { "void*" "root_dev" } ; - -C-STRUCT: usb_device_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "bcdUSB" } - { +packed+ "uchar" "bDeviceClass" } - { +packed+ "uchar" "bDeviceSubClass" } - { +packed+ "uchar" "bDeviceProtocol" } - { +packed+ "uchar" "bMaxPacketSize0" } - { +packed+ "ushort" "idVendor" } - { +packed+ "ushort" "idProduct" } - { +packed+ "ushort" "bcdDevice;" } - { +packed+ "uchar" "iManufacturer" } - { +packed+ "uchar" "iProduct" } - { +packed+ "uchar" "iSerialNumber" } - { +packed+ "uchar" "bNumConfigurations" } ; - -C-STRUCT: usb_config_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "wTotalLength" } - { +packed+ "uchar" "bNumInterfaces" } - { +packed+ "uchar" "bConfigurationValue" } - { +packed+ "uchar" "iConfiguration" } - { +packed+ "uchar" "bmAttributes" } - { +packed+ "uchar" "MaxPower" } - - { "void*" "interface" } - - { "uchar*" "extra" } - { "int" "extralen" } ; - -C-STRUCT: usb_device - { "void*" "next" } - { "void*" "prev" } - { { "char" 1025 } "filename" } - { "usb_bus*" "bus" } - { "usb_device_descriptor" "descriptor" } - { "usb_config_descriptor*" "config" } - { "void*" "dev" } - { "uchar" "devnum" } - { "uchar" "num_children" } - { "void*" "children" } ; - diff --git a/unmaintained/usb/usb-unix.factor b/unmaintained/usb/usb-unix.factor deleted file mode 100644 index 8274cb56e8..0000000000 --- a/unmaintained/usb/usb-unix.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: usb -USING: kernel alien ; - -"usb" "libusb.so" "cdecl" add-library - -LIBRARY: usb - -C-STRUCT: usb_bus - { "void*" "next" } - { "void*" "prev" } - { { "char" 4097 } "dirname" } - { "void*" "devices" } - { "uint" "location" } - { "void*" "root_dev" } ; - -! __attribute__ ((packed)) -C-STRUCT: usb_device_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "bcdUSB" } - { +packed+ "uchar" "bDeviceClass" } - { +packed+ "uchar" "bDeviceSubClass" } - { +packed+ "uchar" "bDeviceProtocol" } - { +packed+ "uchar" "bMaxPacketSize0" } - { +packed+ "ushort" "idVendor" } - { +packed+ "ushort" "idProduct" } - { +packed+ "ushort" "bcdDevice" } - { +packed+ "uchar" "iManufacturer" } - { +packed+ "uchar" "iProduct" } - { +packed+ "uchar" "iSerialNumber" } - { +packed+ "uchar" "bNumConfigurations" } ; - -C-STRUCT: usb_config_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "wTotalLength" } - { +packed+ "uchar" "bNumInterfaces" } - { +packed+ "uchar" "bConfigurationValue" } - { +packed+ "uchar" "iConfiguration" } - { +packed+ "uchar" "bmAttributes" } - { +packed+ "uchar" "MaxPower" } - - { "void*" "interface" } - - { "uchar*" "extra" } - { "int" "extralen" } ; - -C-STRUCT: usb_device - { "void*" "next" } - { "void*" "prev" } - { { "char" 4097 } "filename" } - { "usb_bus*" "bus" } - { "usb_device_descriptor" "descriptor" } - { "usb_config_descriptor*" "config" } - { "void*" "dev" } - { "uchar" "devnum" } - { "uchar" "num_children" } - { "void*" "children" } ; \ No newline at end of file diff --git a/unmaintained/usb/usb-win32.factor b/unmaintained/usb/usb-win32.factor deleted file mode 100644 index a4b1355fff..0000000000 --- a/unmaintained/usb/usb-win32.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: usb -USING: kernel alien ; - -"usb" "libusb.dll" "cdecl" add-library - -LIBRARY: usb - -C-STRUCT: usb_bus - { "void*" "next" } - { "void*" "prev" } - { { "char" 261 } "dirname" } - { "void*" "devices" } - { "uint" "location" } - { "void*" "root_dev" } ; - -C-STRUCT: usb_device_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "bcdUSB" } - { +packed+ "uchar" "bDeviceClass" } - { +packed+ "uchar" "bDeviceSubClass" } - { +packed+ "uchar" "bDeviceProtocol" } - { +packed+ "uchar" "bMaxPacketSize0" } - { +packed+ "ushort" "idVendor" } - { +packed+ "ushort" "idProduct" } - { +packed+ "ushort" "bcdDevice;" } - { +packed+ "uchar" "iManufacturer" } - { +packed+ "uchar" "iProduct" } - { +packed+ "uchar" "iSerialNumber" } - { +packed+ "uchar" "bNumConfigurations" } ; - -C-STRUCT: usb_config_descriptor - { +packed+ "uchar" "bLength" } - { +packed+ "uchar" "bDescriptorType" } - { +packed+ "ushort" "wTotalLength" } - { +packed+ "uchar" "bNumInterfaces" } - { +packed+ "uchar" "bConfigurationValue" } - { +packed+ "uchar" "iConfiguration" } - { +packed+ "uchar" "bmAttributes" } - { +packed+ "uchar" "MaxPower" } - - { "void*" "interface" } - - { "uchar*" "extra" } - { "int" "extralen" } ; - -C-STRUCT: usb_device - { "void*" "next" } - { "void*" "prev" } - { { "char" 261 } "filename" } - { "usb_bus*" "bus" } - { "usb_device_descriptor" "descriptor" } - { "usb_config_descriptor*" "config" } - { "void*" "dev" } - { "uchar" "devnum" } - { "uchar" "num_children" } - { "void*" "children" } ; - diff --git a/unmaintained/usb/usb.factor b/unmaintained/usb/usb.factor deleted file mode 100644 index 662b6e9b7b..0000000000 --- a/unmaintained/usb/usb.factor +++ /dev/null @@ -1,88 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -! -IN: usb -USING: kernel alien io math arrays sequences ; - -LIBRARY: usb - -TYPEDEF: void* usb_dev_handle* - -FUNCTION: usb_dev_handle* usb_open ( usb_device* dev ) ; -FUNCTION: int usb_close ( usb_dev_handle* dev ) ; -FUNCTION: int usb_get_string ( usb_dev_handle* dev, int index, int langid, char *buf, int buflen ) ; -FUNCTION: int usb_get_string_simple ( usb_dev_handle* dev, int index, char* buf, int buflen ) ; - -FUNCTION: int usb_get_descriptor_by_endpoint ( usb_dev_handle* udev, int ep, uchar type, uchar index, void* buf, int size ) ; -FUNCTION: int usb_get_descriptor ( usb_dev_handle* udev, uchar type, uchar index, void* buf, int size ) ; - -FUNCTION: int usb_bulk_write ( usb_dev_handle* dev, int ep, void* bytes, int size, int timeout ) ; -FUNCTION: int usb_bulk_read ( usb_dev_handle* dev, int ep, void* bytes, int size, int timeout ) ; -FUNCTION: int usb_interrupt_write ( usb_dev_handle* dev, int ep, char* bytes, int size, int timeout ) ; -FUNCTION: int usb_interrupt_read ( usb_dev_handle* dev, int ep, char* bytes, int size, int timeout ) ; -FUNCTION: int usb_control_msg ( usb_dev_handle* dev, int requesttype, int request, int value, int index, char* bytes, int size, int timeout ) ; -FUNCTION: int usb_set_configuration ( usb_dev_handle* dev, int configuration ) ; -FUNCTION: int usb_claim_interface ( usb_dev_handle* dev, int interface ) ; -FUNCTION: int usb_release_interface ( usb_dev_handle* dev, int interface ) ; -FUNCTION: int usb_set_altinterface ( usb_dev_handle* dev, int alternate ) ; -FUNCTION: int usb_resetep ( usb_dev_handle* dev, uint ep ) ; -FUNCTION: int usb_clear_halt ( usb_dev_handle* dev, uint ep ) ; -FUNCTION: int usb_reset ( usb_dev_handle* dev ) ; -FUNCTION: int usb_get_driver_np ( usb_dev_handle* dev, int interface, char* name, uint namelen ) ; -FUNCTION: char* usb_strerror ( ) ; - -FUNCTION: void usb_init ( ) ; -FUNCTION: void usb_set_debug ( int level ) ; -FUNCTION: int usb_find_busses ( ) ; -FUNCTION: int usb_find_devices ( ) ; -FUNCTION: usb_device* usb_device ( usb_dev_handle* dev ) ; -FUNCTION: usb_bus* usb_get_busses ( ) ; - -: bus-each ( usb_bus quot -- ) - [ call ] 2keep >r usb_bus-next r> over [ bus-each ] [ 2drop ] if ; - -: device-each ( usb_device quot -- ) - [ call ] 2keep >r usb_device-next r> over [ device-each ] [ 2drop ] if ; - -: vendor-id-matches? ( id usb_device -- bool ) - usb_device-descriptor usb_device_descriptor-idVendor = ; - -: product-id-matches? ( id usb_device -- bool ) - usb_device-descriptor usb_device_descriptor-idProduct = ; - -: is-device? ( vendor-id product-id usb_device -- bool ) - tuck product-id-matches? >r vendor-id-matches? r> and ; - -: find-devices ( vendor-id product-id -- seq ) - 2array - V{ } clone - usb_get_busses [ - usb_bus-devices [ - pick first2 pick is-device? [ - over push - ] [ - drop - ] if - ] device-each - ] bus-each nip ; - -: init ( -- ) - #! Initialize libusb and find devices and busses - usb_init usb_find_busses drop usb_find_devices drop ; - -: display-devices ( -- ) - #! Example function to list all usb devices on system - usb_get_busses [ - dup usb_bus-dirname alien>char-string write " - " write - usb_bus-devices [ - nl " " write - dup usb_device-filename alien>char-string write - " - " write - dup usb_device-descriptor usb_device_descriptor-bLength number>string write - " - " write - dup usb_device-descriptor usb_device_descriptor-idVendor >hex write - " - " write - usb_device-descriptor usb_device_descriptor-idProduct >hex write - ] device-each - nl - ] bus-each ; diff --git a/unmaintained/usb/usb.facts b/unmaintained/usb/usb.facts deleted file mode 100644 index bd67f642b3..0000000000 --- a/unmaintained/usb/usb.facts +++ /dev/null @@ -1,44 +0,0 @@ -! Copyright (C) 2006 Chris Double. -! See http://factorcode.org/license.txt for BSD license. - -USING: help usb ; - -HELP: bus-each -{ $values { "usb_bus" "an alien pointing to a usb_bus structure" } { "quot" "A quotation with stack effect " { $snippet "( usb_bus -- )" } } } -{ $description "Starting with the given usb_bus, traverse the linked list of busses calling the quotation on each one." } -{ $examples - { $code "usb_get_busses [ display-devices ]" } -} -{ $see-also device-each find-devices } ; - -HELP: device-each -{ $values { "usb_device" "an alien pointing to a usb_device structure" } { "quot" "A quotation with stack effect " { $snippet "( usb_device -- )" } } } -{ $description "Starting with the given usb_device, traverse the linked list of devices calling the quotation on each one." } -{ $examples - { $code "usb_get_busses [\n usb_bus-devices [ display-device ]\n] bus-each" } -} -{ $see-also bus-each find-devices } ; - -HELP: vendor-id-matches? -{ $values { "id" "the integer vendor id" } { "usb_device" "an alien pointing to a usb_device structure" } { "bool" "a boolean" } } -{ $description "Return true if the device has the given vendor id." } -{ $see-also product-id-matches? is-device? } ; - -HELP: product-id-matches? -{ $values { "id" "the integer product id" } { "usb_device" "an alien pointing to a usb_device structure" } { "bool" "a boolean" } } -{ $description "Return true if the device has the given product id." } -{ $see-also vendor-id-matches? is-device? } ; - -HELP: is-device? -{ $values { "vendor-id" "the integer vendor id" } { "product-id" "the integer product-id" } { "usb_device" "an alien pointing to a usb_device structure" } { "bool" "a boolean" } } -{ $description "Return true if the device has the given vendor and product id." } -{ $see-also vendor-id-matches? product-id-matches? } ; - -HELP: find-devices -{ $values { "vendor-id" "the integer vendor id for the device to find" } { "product-id" "the integer product id for the device to find" } { "seq" "a sequence containing the usb_devices found" } } -{ $description "Traverse the devices on all USB busses looking for a device with the given vendor and product id's. Return a sequence containing all the usb_device structures found matcing the vendor and product id's." } -{ $examples - { $code "HEX: 10D6 HEX: 1100 find-devices" } -} -{ $see-also bus-each device-each } ; - From c584e50c04dc4ce9d5e78988dc6f07e5839b6fe8 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 Feb 2008 23:59:46 -0600 Subject: [PATCH 082/317] Finishing updating UTF --- core/io/encodings/encodings.factor | 2 +- core/io/utf16/utf16-tests.factor | 14 +++++++------- core/io/utf16/utf16.factor | 18 +++++++++++------- 3 files changed, 19 insertions(+), 15 deletions(-) diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor index 956c512780..767e9b266b 100755 --- a/core/io/encodings/encodings.factor +++ b/core/io/encodings/encodings.factor @@ -10,7 +10,7 @@ TUPLE: encode-error ; TUPLE: decode-error ; -: decode-error ( -- * ) \ encode-error construct-empty throw ; +: decode-error ( -- * ) \ decode-error construct-empty throw ; SYMBOL: begin diff --git a/core/io/utf16/utf16-tests.factor b/core/io/utf16/utf16-tests.factor index 7a4b766941..9800a9827d 100755 --- a/core/io/utf16/utf16-tests.factor +++ b/core/io/utf16/utf16-tests.factor @@ -1,15 +1,15 @@ -USING: tools.test io.utf16 ; +USING: tools.test io.utf16 arrays unicode.syntax ; [ { CHAR: x } ] [ { 0 CHAR: x } decode-utf16be >array ] unit-test [ { HEX: 1D11E } ] [ { HEX: D8 HEX: 34 HEX: DD HEX: 1E } decode-utf16be >array ] unit-test -[ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test-fails -[ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test-fails +[ { UNICHAR: replacement-character } ] [ { BIN: 11011111 CHAR: q } decode-utf16be >array ] unit-test +[ { UNICHAR: replacement-character } ] [ { BIN: 11011011 CHAR: x BIN: 11011011 CHAR: x } decode-utf16be >array ] unit-test -[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be >array ] unit-test +[ B{ 0 120 216 52 221 30 } ] [ { CHAR: x HEX: 1d11e } encode-utf16be ] unit-test [ { CHAR: x } ] [ { CHAR: x 0 } decode-utf16le >array ] unit-test [ { 119070 } ] [ { HEX: 34 HEX: D8 HEX: 1E HEX: DD } decode-utf16le >array ] unit-test -[ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test-fails -[ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test-fails +[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011111 } decode-utf16le >array ] unit-test +[ { UNICHAR: replacement-character } ] [ { 0 BIN: 11011011 0 0 } decode-utf16le >array ] unit-test -[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le >array ] unit-test +[ B{ 120 0 52 216 30 221 } ] [ { CHAR: x HEX: 1d11e } encode-utf16le ] unit-test diff --git a/core/io/utf16/utf16.factor b/core/io/utf16/utf16.factor index d6b160e156..19ebc1d43a 100755 --- a/core/io/utf16/utf16.factor +++ b/core/io/utf16/utf16.factor @@ -8,6 +8,9 @@ SYMBOL: double SYMBOL: quad1 SYMBOL: quad2 SYMBOL: quad3 +SYMBOL: ignore + +: do-ignore ( -- ch state ) 0 ignore ; : append-nums ( byte ch -- ch ) 8 shift bitor ; @@ -19,21 +22,22 @@ SYMBOL: quad3 dup -3 shift BIN: 11011 number= [ dup BIN: 00000100 bitand zero? [ BIN: 11 bitand quad1 ] - [ decode-error ] if + [ drop do-ignore ] if ] [ double ] if ; -: handle-quad2be ( byte ch -- ch ) +: handle-quad2be ( byte ch -- ch state ) swap dup -2 shift BIN: 110111 number= [ - >r 2 shift r> BIN: 11 bitand bitor - ] [ decode-error ] if ; + >r 2 shift r> BIN: 11 bitand bitor quad3 + ] [ 2drop do-ignore ] if ; : (decode-utf16be) ( buf byte ch state -- buf ch state ) { { begin [ drop begin-utf16be ] } { double [ end-multibyte ] } { quad1 [ append-nums quad2 ] } - { quad2 [ handle-quad2be quad3 ] } + { quad2 [ handle-quad2be ] } { quad3 [ append-nums HEX: 10000 + decoded ] } + { ignore [ 2drop push-replacement ] } } case ; : decode-utf16be ( seq -- str ) @@ -43,13 +47,13 @@ SYMBOL: quad3 swap dup -3 shift BIN: 11011 = [ dup BIN: 100 bitand 0 number= [ BIN: 11 bitand 8 shift bitor quad2 ] - [ decode-error ] if + [ 2drop push-replacement ] if ] [ end-multibyte ] if ; : handle-quad3le ( buf byte ch -- buf ch state ) swap dup -2 shift BIN: 110111 = [ BIN: 11 bitand append-nums HEX: 10000 + decoded - ] [ decode-error ] if ; + ] [ 2drop push-replacement ] if ; : (decode-utf16le) ( buf byte ch state -- buf ch state ) { From 5da80f7e5dd623f3a42bd8ff68234a7f9a40a63c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 2 Feb 2008 00:29:47 -0600 Subject: [PATCH 083/317] Lot's of load-everything fixes. * untabify things * using ascii or unicode --- core/parser/parser.factor | 2 +- core/prettyprint/backend/backend-docs.factor | 4 - extra/automata/ui/ui.factor | 6 +- extra/bake/bake.factor | 8 +- extra/builder/builder.factor | 8 +- extra/cairo-demo/cairo-demo.factor | 4 +- extra/cairo/cairo.factor | 34 +- extra/cfdg/cfdg.factor | 4 +- extra/cfdg/models/aqua-star/aqua-star.factor | 4 +- .../models/chiaroscuro/chiaroscuro.factor | 8 +- .../models/game1-turn6/game1-turn6.factor | 4 +- extra/cfdg/models/lesson/lesson.factor | 2 +- extra/cfdg/models/snowflake/snowflake.factor | 8 +- extra/concurrency/concurrency-docs.factor | 10 +- extra/cryptlib/cryptlib.factor | 16 +- extra/html/parser/analyzer/analyzer.factor | 3 +- extra/html/parser/parser.factor | 2 +- extra/koszul/koszul.factor | 2 +- extra/lsys/strings/rewrite/rewrite.factor | 2 +- extra/match/match.factor | 2 +- extra/ogg/ogg.factor | 2 +- extra/ogg/vorbis/vorbis.factor | 12 +- extra/opengl/gl/gl.factor | 10 +- extra/ori/ori.factor | 18 +- extra/postgresql/libpq/libpq.factor | 264 ++-- extra/springies/springies.factor | 2 +- extra/springies/ui/ui.factor | 4 +- extra/sqlite/sqlite-docs.factor | 18 +- extra/tar/tar.factor | 5 +- extra/ui/tools/search/search.factor | 4 +- extra/unix/linux/fs/fs.factor | 26 +- extra/unix/linux/swap/swap.factor | 6 +- .../article-manager/database/database.factor | 2 +- extra/webapps/callback/callback.factor | 2 +- extra/webapps/planet/planet.factor | 2 +- extra/windows/advapi32/advapi32.factor | 24 +- extra/x/widgets/widgets.factor | 2 +- .../x/widgets/wm/frame/drag/move/move.factor | 6 +- .../x/widgets/wm/frame/drag/size/size.factor | 4 +- extra/x/widgets/wm/frame/frame.factor | 2 +- extra/x/widgets/wm/root/root.factor | 6 +- extra/x/x.factor | 6 +- extra/x11/constants/constants.factor | 316 ++--- extra/x11/glx/glx.factor | 34 +- extra/x11/windows/windows.factor | 2 +- extra/x11/xlib/xlib.factor | 1256 ++++++++--------- 46 files changed, 1082 insertions(+), 1086 deletions(-) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 2643ea95d9..ffecf9493e 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -389,7 +389,7 @@ SYMBOL: interactive-vocabs : with-interactive-vocabs ( quot -- ) [ "scratchpad" in set - interactive-vocabs get set-use + interactive-vocabs get set-use call ] with-scope ; inline diff --git a/core/prettyprint/backend/backend-docs.factor b/core/prettyprint/backend/backend-docs.factor index c7ca380fbd..c6eff28d08 100755 --- a/core/prettyprint/backend/backend-docs.factor +++ b/core/prettyprint/backend/backend-docs.factor @@ -18,10 +18,6 @@ HELP: ch>ascii-escape { $values { "ch" "a character" } { "str" string } } { $description "Converts a character to an escape code." } ; -HELP: ch>unicode-escape -{ $values { "ch" "a character" } { "str" string } } -{ $description "Converts a character to a Unicode escape code (" { $snippet "\\u123456"} ")." } ; - HELP: unparse-ch { $values { "ch" "a character" } } { $description "Adds the character to the sequence being constructed (see " { $link "namespaces-make" } "). If the character can appear in a string literal, it is added directly, otherwise an escape code is added." } ; diff --git a/extra/automata/ui/ui.factor b/extra/automata/ui/ui.factor index ab424cdab6..467db53366 100644 --- a/extra/automata/ui/ui.factor +++ b/extra/automata/ui/ui.factor @@ -62,9 +62,9 @@ DEFER: automata-window { [ "1 - Center" [ start-center ] view-button ] [ "2 - Random" [ start-random ] view-button ] -[ "3 - Continue" [ run-rule ] view-button ] +[ "3 - Continue" [ run-rule ] view-button ] [ "5 - Random Rule" [ random-rule ] view-button ] -[ "n - New" [ automata-window ] view-button ] +[ "n - New" [ automata-window ] view-button ] } make* [ [ gadget, ] curry ] map concat ! Hack make-shelf over @top grid-add @@ -75,7 +75,7 @@ over @center grid-add { { T{ key-down f f "1" } [ [ start-center ] view-action ] } { T{ key-down f f "2" } [ [ start-random ] view-action ] } -{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } +{ T{ key-down f f "3" } [ [ run-rule ] view-action ] } { T{ key-down f f "5" } [ [ random-rule ] view-action ] } { T{ key-down f f "n" } [ [ automata-window ] view-action ] } } [ make* ] map >hashtable tuck set-gadget-delegate diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor index d038e81394..19d89f67f0 100644 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -38,16 +38,16 @@ DEFER: bake : bake-item ( item -- ) { { [ dup \ , = ] [ drop , ] } - { [ dup \ % = ] [ drop % ] } - { [ dup \ ,u = ] [ drop ,u ] } + { [ dup \ % = ] [ drop % ] } + { [ dup \ ,u = ] [ drop ,u ] } { [ dup insert-quot? ] [ insert-quot-expr call , ] } { [ dup splice-quot? ] [ splice-quot-expr call % ] } { [ dup integer? ] [ , ] } - { [ dup string? ] [ , ] } + { [ dup string? ] [ , ] } { [ dup tuple? ] [ tuple>array bake >tuple , ] } { [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] } { [ dup sequence? ] [ bake , ] } - { [ t ] [ , ] } } + { [ t ] [ , ] } } cond ; : bake-items ( seq -- ) [ bake-item ] each ; diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index a9a4c159f8..38570ae46f 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -9,10 +9,10 @@ IN: builder : datestamp ( -- string ) now `{ ,[ dup timestamp-year ] - ,[ dup timestamp-month ] - ,[ dup timestamp-day ] - ,[ dup timestamp-hour ] - ,[ timestamp-minute ] } + ,[ dup timestamp-month ] + ,[ dup timestamp-day ] + ,[ dup timestamp-hour ] + ,[ timestamp-minute ] } [ number>string 2 CHAR: 0 pad-left ] map "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cairo-demo/cairo-demo.factor b/extra/cairo-demo/cairo-demo.factor index 9d7af090a7..316479d53c 100644 --- a/extra/cairo-demo/cairo-demo.factor +++ b/extra/cairo-demo/cairo-demo.factor @@ -7,7 +7,7 @@ USING: cairo math math.constants byte-arrays kernel ui ui.render - ui.gadgets opengl.gl ; + ui.gadgets opengl.gl ; IN: cairo-demo @@ -66,7 +66,7 @@ M: cairo-gadget ungraft* ( gadget -- ) : run ( -- ) [ - "Hello World from Factor!" open-window + "Hello World from Factor!" open-window ] with-ui ; MAIN: run diff --git a/extra/cairo/cairo.factor b/extra/cairo/cairo.factor index 96e3daca50..4ec9de8c5b 100644 --- a/extra/cairo/cairo.factor +++ b/extra/cairo/cairo.factor @@ -13,9 +13,9 @@ USING: alien alien.syntax combinators system ; IN: cairo << "cairo" { - { [ win32? ] [ "cairo.dll" ] } - { [ macosx? ] [ "libcairo.dylib" ] } - { [ unix? ] [ "libcairo.so.2" ] } + { [ win32? ] [ "cairo.dll" ] } + { [ macosx? ] [ "libcairo.dylib" ] } + { [ unix? ] [ "libcairo.so.2" ] } } cond "cdecl" add-library >> ! cairo_status_t @@ -152,12 +152,12 @@ C-STRUCT: cairo_t { "uint" "status ! cairo_status_t" } ; C-STRUCT: cairo_matrix_t - { "double" "xx" } - { "double" "yx" } - { "double" "xy" } - { "double" "yy" } - { "double" "x0" } - { "double" "y0" } ; + { "double" "xx" } + { "double" "yx" } + { "double" "xy" } + { "double" "yy" } + { "double" "x0" } + { "double" "y0" } ; ! cairo_format_t C-ENUM: @@ -204,16 +204,16 @@ C-ENUM: "cairo_t*" "cairo" "cairo_create" [ "void*" ] alien-invoke ; : cairo_reference ( cairo_t -- cairo_t ) - "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ; + "cairo_t*" "cairo" "cairo_reference" [ "cairo_t*" ] alien-invoke ; : cairo_destroy ( cairo_t -- ) "void" "cairo" "cairo_destroy" [ "cairo_t*" ] alien-invoke ; : cairo_save ( cairo_t -- ) - "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ; + "void" "cairo" "cairo_save" [ "cairo_t*" ] alien-invoke ; : cairo_restore ( cairo_t -- ) - "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ; + "void" "cairo" "cairo_restore" [ "cairo_t*" ] alien-invoke ; : cairo_set_operator ( cairo_t cairo_operator_t -- ) "void" "cairo" "cairo_set_operator" [ "cairo_t*" "int" ] alien-invoke ; @@ -268,13 +268,13 @@ C-ENUM: "void" "cairo" "cairo_rotate" [ "cairo_t*" "double" ] alien-invoke ; : cairo_transform ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; + "void" "cairo" "cairo_transform" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; : cairo_set_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; + "void" "cairo" "cairo_set_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; : cairo_identity_matrix ( cairo_t -- ) - "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ; + "void" "cairo" "cairo_identity_matrix" [ "cairo_t*" ] alien-invoke ; ! cairo path creating functions @@ -415,10 +415,10 @@ C-ENUM: "void" "cairo" "cairo_set_font_size" [ "cairo_t*" "double" ] alien-invoke ; : cairo_set_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; + "void" "cairo" "cairo_set_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; : cairo_get_font_matrix ( cairo_t cairo_matrix_t -- ) - "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; + "void" "cairo" "cairo_get_font_matrix" [ "cairo_t*" "cairo_matrix_t*" ] alien-invoke ; diff --git a/extra/cfdg/cfdg.factor b/extra/cfdg/cfdg.factor index 5555e45ac7..c3ada95533 100644 --- a/extra/cfdg/cfdg.factor +++ b/extra/cfdg/cfdg.factor @@ -94,9 +94,9 @@ VAR: threshold : gl-flip ( angle -- ) deg>rad dup dup dup [ 2 * cos , 2 * sin , 0 , 0 , - 2 * sin , 2 * cos neg , 0 , 0 , + 2 * sin , 2 * cos neg , 0 , 0 , 0 , 0 , 1 , 0 , - 0 , 0 , 0 , 1 , ] + 0 , 0 , 0 , 1 , ] { } make >c-double-array glMultMatrixd ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cfdg/models/aqua-star/aqua-star.factor b/extra/cfdg/models/aqua-star/aqua-star.factor index 062f10b292..f692328515 100644 --- a/extra/cfdg/models/aqua-star/aqua-star.factor +++ b/extra/cfdg/models/aqua-star/aqua-star.factor @@ -9,9 +9,9 @@ iterate? [ { { 1 [ circle [ .23 y .99 s .002 b tentacle ] do ] } { 1 [ circle - [ .17 y 2 r .99 s .002 b tentacle ] do ] } + [ .17 y 2 r .99 s .002 b tentacle ] do ] } { 1 [ circle - [ .12 y -2 r .99 s .001 b tentacle ] do ] } } + [ .12 y -2 r .99 s .001 b tentacle ] do ] } } call-random-weighted ] when ; diff --git a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor index a87b3602d9..31f78c459e 100644 --- a/extra/cfdg/models/chiaroscuro/chiaroscuro.factor +++ b/extra/cfdg/models/chiaroscuro/chiaroscuro.factor @@ -9,18 +9,18 @@ DEFER: white : black ( -- ) iterate? [ { { 60 [ [ 0.6 s circle ] do - [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } + [ 0.1 x 5 r 0.99 s -0.01 b -0.01 a black ] do ] } { 1 [ white black ] } } call-random-weighted ] when ; : white ( -- ) iterate? [ { { 60 [ - [ 0.6 s circle ] do - [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do + [ 0.6 s circle ] do + [ 0.1 x -5 r 0.99 s 0.01 b -0.01 a white ] do ] } { 1 [ - black white + black white ] } } call-random-weighted ] when ; diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor index c00f95233c..0cd65242fb 100644 --- a/extra/cfdg/models/game1-turn6/game1-turn6.factor +++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor @@ -24,8 +24,8 @@ DEFER: start : spiral ( -- ) iterate? [ { { 1 [ f-squares - [ 0.5 x 0.5 y 45 r f-triangles ] do - [ 1 y 25 r 0.9 s spiral ] do ] } + [ 0.5 x 0.5 y 45 r f-triangles ] do + [ 1 y 25 r 0.9 s spiral ] do ] } { 0.022 [ [ 90 flip 50 hue start ] do ] } } call-random-weighted ] when ; diff --git a/extra/cfdg/models/lesson/lesson.factor b/extra/cfdg/models/lesson/lesson.factor index 26934aa182..287e572929 100644 --- a/extra/cfdg/models/lesson/lesson.factor +++ b/extra/cfdg/models/lesson/lesson.factor @@ -73,7 +73,7 @@ DEFER: tree iterate? [ { { 20 [ [ 0.25 size circle ] do - [ 0.1 y 0.97 size tree ] do ] } + [ 0.1 y 0.97 size tree ] do ] } { 1.5 [ branch ] } } random-weighted* do ] when ; diff --git a/extra/cfdg/models/snowflake/snowflake.factor b/extra/cfdg/models/snowflake/snowflake.factor index eb1936101a..951f449e68 100644 --- a/extra/cfdg/models/snowflake/snowflake.factor +++ b/extra/cfdg/models/snowflake/snowflake.factor @@ -7,11 +7,11 @@ IN: cfdg.models.snowflake : spike ( -- ) iterate? [ { { 1 [ square - [ 0.95 y 0.97 s spike ] do ] } + [ 0.95 y 0.97 s spike ] do ] } { 0.03 [ square - [ 60 r spike ] do - [ -60 r spike ] do - [ 0.95 y 0.97 s spike ] do ] } } + [ 60 r spike ] do + [ -60 r spike ] do + [ 0.95 y 0.97 s spike ] do ] } } call-random-weighted ] when ; diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index 7e76ff242a..dafbafbc5b 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -33,7 +33,7 @@ HELP: (mailbox-block-unless-pred) HELP: (mailbox-block-if-empty) { $values { "mailbox" "a mailbox object" } - { "mailbox2" "same object as 'mailbox'" } + { "mailbox2" "same object as 'mailbox'" } { "timeout" "a timeout in milliseconds" } } { $description "Block the thread if the mailbox is empty." } @@ -41,21 +41,21 @@ HELP: (mailbox-block-if-empty) HELP: mailbox-get { $values { "mailbox" "a mailbox object" } - { "obj" "an object" } + { "obj" "an object" } } { $description "Get the first item put into the mailbox. If it is empty the thread blocks until an item is put into it. The thread then resumes, leaving the item on the stack." } { $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; HELP: mailbox-get-all { $values { "mailbox" "a mailbox object" } - { "array" "an array" } + { "array" "an array" } } { $description "Blocks the thread if the mailbox is empty, otherwise removes all objects in the mailbox and returns an array containing the objects." } { $see-also make-mailbox mailbox-empty? mailbox-put while-mailbox-empty mailbox-get-all mailbox-get? } ; HELP: while-mailbox-empty { $values { "mailbox" "a mailbox object" } - { "quot" "a quotation with stack effect " { $snippet "( -- )" } } + { "quot" "a quotation with stack effect " { $snippet "( -- )" } } } { $description "Repeatedly call the quotation while there are no items in the mailbox. Quotation should have stack effect " { $snippet "( -- )" } "." } { $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all mailbox-get? } ; @@ -63,7 +63,7 @@ HELP: while-mailbox-empty HELP: mailbox-get? { $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } } { "mailbox" "a mailbox object" } - { "obj" "an object" } + { "obj" "an object" } } { $description "Get the first item in the mailbox which satisfies the predicate. 'pred' will be called repeatedly for each item in the mailbox. When 'pred' returns true that item will be returned. If nothing in the mailbox satisfies the predicate then the thread will block until something does. 'pred' must have stack effect " { $snippet "( X -- bool }" } "." } { $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty } ; diff --git a/extra/cryptlib/cryptlib.factor b/extra/cryptlib/cryptlib.factor index 2ba81ef15a..1bb9f3d5dd 100644 --- a/extra/cryptlib/cryptlib.factor +++ b/extra/cryptlib/cryptlib.factor @@ -59,7 +59,7 @@ SYMBOL: session cryptEnd check-result ; : with-cryptlib ( quot -- ) - [ init [ end ] [ ] cleanup ] with-scope ; inline + [ init [ end ] [ ] cleanup ] with-scope ; inline ! ========================================================= ! Create and destroy an encryption context @@ -71,10 +71,10 @@ SYMBOL: session : destroy-context ( -- ) context get [ *int cryptDestroyContext check-result ] when* - context off ; + context off ; : with-context ( algo quot -- ) - swap create-context [ destroy-context ] [ ] cleanup ; inline + swap create-context [ destroy-context ] [ ] cleanup ; inline ! ========================================================= ! Keyset routines @@ -86,10 +86,10 @@ SYMBOL: session : close-keyset ( -- ) keyset get *int cryptKeysetClose check-result - destroy-context ; + destroy-context ; : with-keyset ( type name options quot -- ) - >r open-keyset r> [ close-keyset ] [ ] cleanup ; inline + >r open-keyset r> [ close-keyset ] [ ] cleanup ; inline : get-public-key ( idtype id -- ) >r >r keyset get *int "int*" tuck r> r> string>char-alien @@ -128,7 +128,7 @@ SYMBOL: session certificate get *int cryptDestroyCert check-result ; : with-certificate ( type quot -- ) - swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline + swap create-certificate [ destroy-certificate ] [ ] cleanup ; inline : sign-certificate ( -- ) certificate get *int context get *int cryptSignCert check-result ; @@ -175,7 +175,7 @@ SYMBOL: session envelope get *int cryptDestroyEnvelope check-result ; : with-envelope ( format quot -- ) - swap create-envelope [ destroy-envelope ] [ ] cleanup ; + swap create-envelope [ destroy-envelope ] [ ] cleanup ; : create-session ( format -- ) >r "int" dup swap CRYPT_UNUSED r> cryptCreateSession @@ -185,7 +185,7 @@ SYMBOL: session session get *int cryptDestroySession check-result ; : with-session ( format quot -- ) - swap create-session [ destroy-session ] [ ] cleanup ; + swap create-session [ destroy-session ] [ ] cleanup ; : push-data ( handle buffer length -- ) >r >r *int r> r> "int" [ cryptPushData ] diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index dfb4552e03..e4f11cd91e 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,4 +1,5 @@ -USING: assocs html.parser kernel math sequences strings ; +USING: assocs html.parser kernel math sequences strings unicode.categories + unicode.case ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor index 7057cfe61e..bc4dc429fa 100644 --- a/extra/html/parser/parser.factor +++ b/extra/html/parser/parser.factor @@ -1,6 +1,6 @@ USING: arrays html.parser.utils hashtables io kernel namespaces prettyprint quotations -sequences splitting state-parser strings ; +sequences splitting state-parser strings unicode.categories unicode.case ; IN: html.parser TUPLE: tag name attributes text matched? closing? ; diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index faf1280f7c..9545e1cc9d 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -123,7 +123,7 @@ DEFER: (d) [ drop H{ } ] [ unclip swap [ x.dy ] 2keep dx.y alt+ ] if ; : linear-op ( vec quot -- vec ) - [ + [ [ -rot >r swap call r> alt*n (alt+) ] curry assoc-each diff --git a/extra/lsys/strings/rewrite/rewrite.factor b/extra/lsys/strings/rewrite/rewrite.factor index 7ba5e55c99..8e45e5f499 100644 --- a/extra/lsys/strings/rewrite/rewrite.factor +++ b/extra/lsys/strings/rewrite/rewrite.factor @@ -19,7 +19,7 @@ VAR: accum : (rewrite) ( slice -- ) { { [ empty? ] [ drop ] } { [ has-param? ] [ next+rest* [ push-next ] [ (rewrite) ] bi* ] } - { [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } } + { [ t ] [ next+rest [ push-next ] [ (rewrite) ] bi* ] } } switch ; : rewrite ( string -- string ) diff --git a/extra/match/match.factor b/extra/match/match.factor index 6d63b5af21..722c330a32 100755 --- a/extra/match/match.factor +++ b/extra/match/match.factor @@ -54,7 +54,7 @@ MACRO: match-cond ( assoc -- ) : replace-patterns ( object -- result ) { - { [ dup number? ] [ ] } + { [ dup number? ] [ ] } { [ dup match-var? ] [ get ] } { [ dup sequence? ] [ [ replace-patterns ] map ] } { [ dup tuple? ] [ tuple>array replace-patterns >tuple ] } diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor index b0a78e1490..830249a3df 100644 --- a/extra/ogg/ogg.factor +++ b/extra/ogg/ogg.factor @@ -104,7 +104,7 @@ FUNCTION: int ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ; FUNCTION: int ogg_sync_init ( ogg_sync_state* oy ) ; FUNCTION: int ogg_sync_clear ( ogg_sync_state* oy ) ; FUNCTION: int ogg_sync_reset ( ogg_sync_state* oy ) ; -FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ; +FUNCTION: int ogg_sync_destroy ( ogg_sync_state* oy ) ; FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ; FUNCTION: int ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ; diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index eff28b69ca..26e917ebf4 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -100,19 +100,19 @@ FUNCTION: double vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepo FUNCTION: int vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; FUNCTION: int vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ; FUNCTION: int vorbis_analysis_headerout ( vorbis_dsp_state* v, - vorbis_comment* vc, - ogg_packet* op, - ogg_packet* op_comm, - ogg_packet* op_code ) ; + vorbis_comment* vc, + ogg_packet* op, + ogg_packet* op_comm, + ogg_packet* op_code ) ; FUNCTION: float** vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ; FUNCTION: int vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ; FUNCTION: int vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ; FUNCTION: int vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ; FUNCTION: int vorbis_bitrate_addblock ( vorbis_block* vb ) ; FUNCTION: int vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd, - ogg_packet* op ) ; + ogg_packet* op ) ; FUNCTION: int vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc, - ogg_packet* op ) ; + ogg_packet* op ) ; FUNCTION: int vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ; FUNCTION: int vorbis_synthesis_restart ( vorbis_dsp_state* v ) ; FUNCTION: int vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ; diff --git a/extra/opengl/gl/gl.factor b/extra/opengl/gl/gl.factor index 071fbc45e7..76c30baa85 100644 --- a/extra/opengl/gl/gl.factor +++ b/extra/opengl/gl/gl.factor @@ -1014,7 +1014,7 @@ FUNCTION: void glTexImage1D ( GLenum target, GLint level, GLint internalFormat, FUNCTION: void glTexImage2D ( GLenum target, GLint level, GLint internalFormat, GLsizei width, GLsizei height, GLint border, - GLenum format, GLenum type, GLvoid* pixels ) ; + GLenum format, GLenum type, GLvoid* pixels ) ; FUNCTION: void glGetTexImage ( GLenum target, GLint level, GLenum format, GLenum type, GLvoid* pixels ) ; @@ -1039,14 +1039,14 @@ FUNCTION: void glTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLsi FUNCTION: void glTexSubImage2D ( GLenum target, GLint level, GLint xoffset, GLint yoffset, GLsizei width, GLsizei height, GLenum format, - GLenum type, GLvoid* pixels ) ; + GLenum type, GLvoid* pixels ) ; FUNCTION: void glCopyTexImage1D ( GLenum target, GLint level, GLenum internalformat, GLint x, GLint y, GLsizei width, GLint border ) ; FUNCTION: void glCopyTexImage2D ( GLenum target, GLint level, GLenum internalformat, GLint x, GLint y, - GLsizei width, GLsizei height, GLint border ) ; + GLsizei width, GLsizei height, GLint border ) ; FUNCTION: void glCopyTexSubImage1D ( GLenum target, GLint level, GLint xoffset, GLint x, GLint y, GLsizei width ) ; @@ -1064,10 +1064,10 @@ FUNCTION: void glMap1f ( GLenum target, GLfloat u1, GLfloat u2, FUNCTION: void glMap2d ( GLenum target, GLdouble u1, GLdouble u2, GLint ustride, GLint uorder, GLdouble v1, GLdouble v2, GLint vstride, GLint vorder, - GLdouble* points ) ; + GLdouble* points ) ; FUNCTION: void glMap2f ( GLenum target, GLfloat u1, GLfloat u2, GLint ustride, GLint uorder, GLfloat v1, GLfloat v2, GLint vstride, GLint vorder, - GLfloat* points ) ; + GLfloat* points ) ; FUNCTION: void glGetMapdv ( GLenum target, GLenum query, GLdouble* v ) ; FUNCTION: void glGetMapfv ( GLenum target, GLenum query, GLfloat* v ) ; diff --git a/extra/ori/ori.factor b/extra/ori/ori.factor index db60f95183..729dcba56a 100644 --- a/extra/ori/ori.factor +++ b/extra/ori/ori.factor @@ -25,19 +25,19 @@ C: ori ! `Computer Graphics: Principles and Practice' : Rz ( angle -- Rx ) deg>rad -[ dup cos , dup sin neg , 0 , - dup sin , dup cos , 0 , - 0 , 0 , 1 , ] 3 make-matrix nip ; +[ dup cos , dup sin neg , 0 , + dup sin , dup cos , 0 , + 0 , 0 , 1 , ] 3 make-matrix nip ; : Ry ( angle -- Ry ) deg>rad -[ dup cos , 0 , dup sin , - 0 , 1 , 0 , - dup sin neg , 0 , dup cos , ] 3 make-matrix nip ; +[ dup cos , 0 , dup sin , + 0 , 1 , 0 , + dup sin neg , 0 , dup cos , ] 3 make-matrix nip ; : Rx ( angle -- Rz ) deg>rad -[ 1 , 0 , 0 , - 0 , dup cos , dup sin neg , - 0 , dup sin , dup cos , ] 3 make-matrix nip ; +[ 1 , 0 , 0 , + 0 , dup cos , dup sin neg , + 0 , dup sin , dup cos , ] 3 make-matrix nip ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/postgresql/libpq/libpq.factor b/extra/postgresql/libpq/libpq.factor index 3b21fd8203..faeb3f9aa4 100644 --- a/extra/postgresql/libpq/libpq.factor +++ b/extra/postgresql/libpq/libpq.factor @@ -17,44 +17,44 @@ IN: postgresql.libpq >> ! ConnSatusType -: CONNECTION_OK HEX: 0 ; inline -: CONNECTION_BAD HEX: 1 ; inline -: CONNECTION_STARTED HEX: 2 ; inline -: CONNECTION_MADE HEX: 3 ; inline -: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline -: CONNECTION_AUTH_OK HEX: 5 ; inline -: CONNECTION_SETENV HEX: 6 ; inline -: CONNECTION_SSL_STARTUP HEX: 7 ; inline -: CONNECTION_NEEDED HEX: 8 ; inline +: CONNECTION_OK HEX: 0 ; inline +: CONNECTION_BAD HEX: 1 ; inline +: CONNECTION_STARTED HEX: 2 ; inline +: CONNECTION_MADE HEX: 3 ; inline +: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline +: CONNECTION_AUTH_OK HEX: 5 ; inline +: CONNECTION_SETENV HEX: 6 ; inline +: CONNECTION_SSL_STARTUP HEX: 7 ; inline +: CONNECTION_NEEDED HEX: 8 ; inline ! PostgresPollingStatusType -: PGRES_POLLING_FAILED HEX: 0 ; inline -: PGRES_POLLING_READING HEX: 1 ; inline -: PGRES_POLLING_WRITING HEX: 2 ; inline -: PGRES_POLLING_OK HEX: 3 ; inline -: PGRES_POLLING_ACTIVE HEX: 4 ; inline +: PGRES_POLLING_FAILED HEX: 0 ; inline +: PGRES_POLLING_READING HEX: 1 ; inline +: PGRES_POLLING_WRITING HEX: 2 ; inline +: PGRES_POLLING_OK HEX: 3 ; inline +: PGRES_POLLING_ACTIVE HEX: 4 ; inline ! ExecStatusType; -: PGRES_EMPTY_QUERY HEX: 0 ; inline -: PGRES_COMMAND_OK HEX: 1 ; inline -: PGRES_TUPLES_OK HEX: 2 ; inline -: PGRES_COPY_OUT HEX: 3 ; inline -: PGRES_COPY_IN HEX: 4 ; inline -: PGRES_BAD_RESPONSE HEX: 5 ; inline -: PGRES_NONFATAL_ERROR HEX: 6 ; inline -: PGRES_FATAL_ERROR HEX: 7 ; inline +: PGRES_EMPTY_QUERY HEX: 0 ; inline +: PGRES_COMMAND_OK HEX: 1 ; inline +: PGRES_TUPLES_OK HEX: 2 ; inline +: PGRES_COPY_OUT HEX: 3 ; inline +: PGRES_COPY_IN HEX: 4 ; inline +: PGRES_BAD_RESPONSE HEX: 5 ; inline +: PGRES_NONFATAL_ERROR HEX: 6 ; inline +: PGRES_FATAL_ERROR HEX: 7 ; inline ! PGTransactionStatusType; -: PQTRANS_IDLE HEX: 0 ; inline -: PQTRANS_ACTIVE HEX: 1 ; inline -: PQTRANS_INTRANS HEX: 2 ; inline -: PQTRANS_INERROR HEX: 3 ; inline -: PQTRANS_UNKNOWN HEX: 4 ; inline +: PQTRANS_IDLE HEX: 0 ; inline +: PQTRANS_ACTIVE HEX: 1 ; inline +: PQTRANS_INTRANS HEX: 2 ; inline +: PQTRANS_INERROR HEX: 3 ; inline +: PQTRANS_UNKNOWN HEX: 4 ; inline ! PGVerbosity; -: PQERRORS_TERSE HEX: 0 ; inline -: PQERRORS_DEFAULT HEX: 1 ; inline -: PQERRORS_VERBOSE HEX: 2 ; inline +: PQERRORS_TERSE HEX: 0 ; inline +: PQERRORS_DEFAULT HEX: 1 ; inline +: PQERRORS_VERBOSE HEX: 2 ; inline TYPEDEF: int size_t @@ -81,7 +81,7 @@ LIBRARY: postgresql ! Exported functions of libpq -! === in fe-connect.c === +! === in fe-connect.c === ! make a new client connection to the backend ! Asynchronous (non-blocking) @@ -91,12 +91,12 @@ FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ; ! Synchronous (blocking) FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ; FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport, - char* pgoptions, char* pgtty, - char* dbName, - char* login, char* pwd ) ; + char* pgoptions, char* pgtty, + char* dbName, + char* login, char* pwd ) ; : PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* ) - f f PQsetdbLogin ; + f f PQsetdbLogin ; ! close the current connection and free the PGconn data structure FUNCTION: void PQfinish ( PGconn* conn ) ; @@ -112,7 +112,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ; ! parameters ! ! Asynchronous (non-blocking) -FUNCTION: int PQresetStart ( PGconn* conn ) ; +FUNCTION: int PQresetStart ( PGconn* conn ) ; FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ; ! Synchronous (blocking) @@ -125,7 +125,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ; FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ; ! issue a cancel request -FUNCTION: int PQrequestCancel ( PGconn* conn ) ; +FUNCTION: int PQrequestCancel ( PGconn* conn ) ; ! Accessor functions for PGconn objects FUNCTION: char* PQdb ( PGconn* conn ) ; @@ -138,14 +138,14 @@ FUNCTION: char* PQoptions ( PGconn* conn ) ; FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ; FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ; FUNCTION: char* PQparameterStatus ( PGconn* conn, - char* paramName ) ; -FUNCTION: int PQprotocolVersion ( PGconn* conn ) ; -FUNCTION: int PQServerVersion ( PGconn* conn ) ; + char* paramName ) ; +FUNCTION: int PQprotocolVersion ( PGconn* conn ) ; +FUNCTION: int PQServerVersion ( PGconn* conn ) ; FUNCTION: char* PQerrorMessage ( PGconn* conn ) ; -FUNCTION: int PQsocket ( PGconn* conn ) ; -FUNCTION: int PQbackendPID ( PGconn* conn ) ; -FUNCTION: int PQclientEncoding ( PGconn* conn ) ; -FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ; +FUNCTION: int PQsocket ( PGconn* conn ) ; +FUNCTION: int PQbackendPID ( PGconn* conn ) ; +FUNCTION: int PQclientEncoding ( PGconn* conn ) ; +FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ; ! May not be compiled into libpq ! Get the SSL structure associated with a connection @@ -156,7 +156,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ; ! Set verbosity for PQerrorMessage and PQresultErrorMessage FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn, - PGVerbosity verbosity ) ; + PGVerbosity verbosity ) ; ! Enable/disable tracing FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ; @@ -171,11 +171,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ; ! Override default notice handling routines ! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn, - ! PQnoticeReceiver proc, - ! void* arg ) ; + ! PQnoticeReceiver proc, + ! void* arg ) ; ! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn, - ! PQnoticeProcessor proc, - ! void* arg ) ; + ! PQnoticeProcessor proc, + ! void* arg ) ; ! END BROKEN ! === in fe-exec.c === @@ -183,107 +183,107 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ; ! Simple synchronous query FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ; FUNCTION: PGresult* PQexecParams ( PGconn* conn, - char* command, - int nParams, - Oid* paramTypes, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; + char* command, + int nParams, + Oid* paramTypes, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName, char* query, int nParams, Oid* paramTypes ) ; FUNCTION: PGresult* PQexecPrepared ( PGconn* conn, - char* stmtName, - int nParams, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; + char* stmtName, + int nParams, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; ! Interface for multiple-result or asynchronous queries FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ; FUNCTION: int PQsendQueryParams ( PGconn* conn, - char* command, - int nParams, - Oid* paramTypes, - char** paramValues, - int* paramLengths, - int* paramFormats, - int resultFormat ) ; + char* command, + int nParams, + Oid* paramTypes, + char** paramValues, + int* paramLengths, + int* paramFormats, + int resultFormat ) ; FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName, char* query, int nParams, Oid* paramTypes ) ; FUNCTION: int PQsendQueryPrepared ( PGconn* conn, - char* stmtName, - int nParams, - char** paramValues, - int *paramLengths, - int *paramFormats, - int resultFormat ) ; + char* stmtName, + int nParams, + char** paramValues, + int *paramLengths, + int *paramFormats, + int resultFormat ) ; FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ; ! Routines for managing an asynchronous query -FUNCTION: int PQisBusy ( PGconn* conn ) ; -FUNCTION: int PQconsumeInput ( PGconn* conn ) ; +FUNCTION: int PQisBusy ( PGconn* conn ) ; +FUNCTION: int PQconsumeInput ( PGconn* conn ) ; ! LISTEN/NOTIFY support FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ; ! Routines for copy in/out -FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ; -FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ; -FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ; +FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ; +FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ; +FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ; ! Deprecated routines for copy in/out -FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ; -FUNCTION: int PQputline ( PGconn* conn, char* string ) ; -FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ; -FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ; -FUNCTION: int PQendcopy ( PGconn* conn ) ; +FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ; +FUNCTION: int PQputline ( PGconn* conn, char* string ) ; +FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ; +FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ; +FUNCTION: int PQendcopy ( PGconn* conn ) ; ! Set blocking/nonblocking connection to the backend -FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ; -FUNCTION: int PQisnonblocking ( PGconn* conn ) ; +FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ; +FUNCTION: int PQisnonblocking ( PGconn* conn ) ; ! Force the write buffer to be written (or at least try) -FUNCTION: int PQflush ( PGconn* conn ) ; +FUNCTION: int PQflush ( PGconn* conn ) ; ! ! * "Fast path" interface --- not really recommended for application ! * use ! FUNCTION: PGresult* PQfn ( PGconn* conn, - int fnid, - int* result_buf, - int* result_len, - int result_is_int, - PQArgBlock* args, - int nargs ) ; + int fnid, + int* result_buf, + int* result_len, + int result_is_int, + PQArgBlock* args, + int nargs ) ; ! Accessor functions for PGresult objects FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ; FUNCTION: char* PQresStatus ( ExecStatusType status ) ; FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ; FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ; -FUNCTION: int PQntuples ( PGresult* res ) ; -FUNCTION: int PQnfields ( PGresult* res ) ; -FUNCTION: int PQbinaryTuples ( PGresult* res ) ; +FUNCTION: int PQntuples ( PGresult* res ) ; +FUNCTION: int PQnfields ( PGresult* res ) ; +FUNCTION: int PQbinaryTuples ( PGresult* res ) ; FUNCTION: char* PQfname ( PGresult* res, int field_num ) ; -FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ; -FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ; -FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ; -FUNCTION: int PQfformat ( PGresult* res, int field_num ) ; -FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ; -FUNCTION: int PQfsize ( PGresult* res, int field_num ) ; -FUNCTION: int PQfmod ( PGresult* res, int field_num ) ; +FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ; +FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ; +FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ; +FUNCTION: int PQfformat ( PGresult* res, int field_num ) ; +FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ; +FUNCTION: int PQfsize ( PGresult* res, int field_num ) ; +FUNCTION: int PQfmod ( PGresult* res, int field_num ) ; FUNCTION: char* PQcmdStatus ( PGresult* res ) ; FUNCTION: char* PQoidStatus ( PGresult* res ) ; -FUNCTION: Oid PQoidValue ( PGresult* res ) ; +FUNCTION: Oid PQoidValue ( PGresult* res ) ; FUNCTION: char* PQcmdTuples ( PGresult* res ) ; FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ; -FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; -FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ; +FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ; ! Delete a PGresult FUNCTION: void PQclear ( PGresult* res ) ; @@ -313,7 +313,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext, ! These forms are deprecated! FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ; FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen, - size_t* bytealen ) ; + size_t* bytealen ) ; ! === in fe-print.c === @@ -321,41 +321,41 @@ FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ; ! really old printing routines FUNCTION: void PQdisplayTuples ( PGresult* res, - FILE* fp, - int fillAlign, - char* fieldSep, - int printHeader, - int quiet ) ; + FILE* fp, + int fillAlign, + char* fieldSep, + int printHeader, + int quiet ) ; FUNCTION: void PQprintTuples ( PGresult* res, - FILE* fout, - int printAttName, - int terseOutput, - int width ) ; - + FILE* fout, + int printAttName, + int terseOutput, + int width ) ; + ! === in fe-lobj.c === ! Large-object access routines -FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ; -FUNCTION: int lo_close ( PGconn* conn, int fd ) ; -FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ; -FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ; -FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ; -FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ; -! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ; -FUNCTION: int lo_tell ( PGconn* conn, int fd ) ; -FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ; -FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ; -FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ; +FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ; +FUNCTION: int lo_close ( PGconn* conn, int fd ) ; +FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ; +FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ; +FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ; +FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ; +! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ; +FUNCTION: int lo_tell ( PGconn* conn, int fd ) ; +FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ; +FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ; +FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ; ! === in fe-misc.c === ! Determine length of multibyte encoded char at *s -FUNCTION: int PQmblen ( uchar* s, int encoding ) ; +FUNCTION: int PQmblen ( uchar* s, int encoding ) ; ! Determine display length of multibyte encoded char at *s -FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; +FUNCTION: int PQdsplen ( uchar* s, int encoding ) ; ! Get encoding id from environment variable PGCLIENTENCODING -FUNCTION: int PQenv2encoding ( ) ; +FUNCTION: int PQenv2encoding ( ) ; diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor index a2c0827064..bc50ecb1d4 100644 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -183,7 +183,7 @@ C: spring { [ dup below? ] [ bounce-bottom ] } { [ dup beyond-left? ] [ bounce-left ] } { [ dup beyond-right? ] [ bounce-right ] } - { [ t ] [ drop ] } } + { [ t ] [ drop ] } } cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor index 830bbd35b3..fc5fee5c01 100644 --- a/extra/springies/ui/ui.factor +++ b/extra/springies/ui/ui.factor @@ -51,10 +51,10 @@ DEFER: maybe-loop : springies-window* ( -- ) C[ display ] >slate - { 800 600 } slate> set-slate-dim + { 800 600 } slate> set-slate-dim C[ { 500 500 } >world-size loop on [ run ] in-thread ] slate> set-slate-graft - C[ loop off ] slate> set-slate-ungraft + C[ loop off ] slate> set-slate-ungraft slate> "Springies" open-window ; diff --git a/extra/sqlite/sqlite-docs.factor b/extra/sqlite/sqlite-docs.factor index d58b553f11..87bf1b5230 100644 --- a/extra/sqlite/sqlite-docs.factor +++ b/extra/sqlite/sqlite-docs.factor @@ -18,24 +18,24 @@ HELP: sqlite-close HELP: sqlite-last-insert-rowid { $values { "db" "the database object" } - { "rowid" "the row number of the last insert" } + { "rowid" "the row number of the last insert" } } { $description "Returns the number of the row of the last statement inserted into the database." } { $see-also sqlite-open sqlite-close } ; HELP: sqlite-prepare { $values { "db" "the database object" } - { "sql" "the SQL statement as a string" } - { "statement" "the prepared SQL statement" } + { "sql" "the SQL statement as a string" } + { "statement" "the prepared SQL statement" } } { $description "Internally compiles the SQL statement ready to be run by sqlite. The statement is executed and the results iterated over using " { $link sqlite-each } " and " { $link sqlite-map } ". The SQL statement can use named parameters which are later bound to values using " { $link sqlite-bind-text } " and " { $link sqlite-bind-text-by-name } "." } { $see-also sqlite-open sqlite-close } ; HELP: sqlite-bind-text { $values { "statement" "a prepared SQL statement" } - { "index" "the index of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - + { "index" "the index of the bound parameter in the SQL statement" } + { "text" "the string value to bind to that column" } + } { $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the index given and the indexes start from one." } { $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=?\" sqlite-prepare\n1 \"chris\" sqlite-bind-text" } } @@ -43,9 +43,9 @@ HELP: sqlite-bind-text HELP: sqlite-bind-text-by-name { $values { "statement" "a prepared SQL statement" } - { "name" "the name of the bound parameter in the SQL statement" } - { "text" "the string value to bind to that column" } - + { "name" "the name of the bound parameter in the SQL statement" } + { "text" "the string value to bind to that column" } + } { $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the given name." } { $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=:name\" sqlite-prepare\n\"name\" \"chris\" sqlite-bind-text" } } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 363ce6b412..20e997185d 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,8 +1,7 @@ -<<<<<<< HEAD:extra/tar/tar.factor USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations -namespaces pack prettyprint sequences strings system ; -USING: hexdump tools.interpreter ; +namespaces pack prettyprint sequences strings system +hexdump tools.interpreter ; IN: tar : zero-checksum 256 ; diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 27ca4a165d..4bf89d03d1 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -39,8 +39,8 @@ TUPLE: search-field ; search-field H{ { T{ key-down f f "UP" } [ find-search-list select-previous ] } { T{ key-down f f "DOWN" } [ find-search-list select-next ] } - { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] } - { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] } + { T{ key-down f f "PAGE_UP" } [ find-search-list list-page-up ] } + { T{ key-down f f "PAGE_DOWN" } [ find-search-list list-page-down ] } { T{ key-down f f "RET" } [ find-search-list invoke-value-action ] } } set-gestures diff --git a/extra/unix/linux/fs/fs.factor b/extra/unix/linux/fs/fs.factor index 02fd357ccd..475d0290a6 100644 --- a/extra/unix/linux/fs/fs.factor +++ b/extra/unix/linux/fs/fs.factor @@ -3,19 +3,19 @@ USING: alien.syntax ; IN: unix.linux.fs -: MS_RDONLY 1 ; ! Mount read-only. -: MS_NOSUID 2 ; ! Ignore suid and sgid bits. -: MS_NODEV 4 ; ! Disallow access to device special files. -: MS_NOEXEC 8 ; ! Disallow program execution. -: MS_SYNCHRONOUS 16 ; ! Writes are synced at once. -: MS_REMOUNT 32 ; ! Alter flags of a mounted FS. -: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS. -: S_WRITE 128 ; ! Write on file/directory/symlink. -: S_APPEND 256 ; ! Append-only file. -: S_IMMUTABLE 512 ; ! Immutable file. -: MS_NOATIME 1024 ; ! Do not update access times. -: MS_NODIRATIME 2048 ; ! Do not update directory access times. -: MS_BIND 4096 ; ! Bind directory at different place. +: MS_RDONLY 1 ; ! Mount read-only. +: MS_NOSUID 2 ; ! Ignore suid and sgid bits. +: MS_NODEV 4 ; ! Disallow access to device special files. +: MS_NOEXEC 8 ; ! Disallow program execution. +: MS_SYNCHRONOUS 16 ; ! Writes are synced at once. +: MS_REMOUNT 32 ; ! Alter flags of a mounted FS. +: MS_MANDLOCK 64 ; ! Allow mandatory locks on an FS. +: S_WRITE 128 ; ! Write on file/directory/symlink. +: S_APPEND 256 ; ! Append-only file. +: S_IMMUTABLE 512 ; ! Immutable file. +: MS_NOATIME 1024 ; ! Do not update access times. +: MS_NODIRATIME 2048 ; ! Do not update directory access times. +: MS_BIND 4096 ; ! Bind directory at different place. FUNCTION: int mount ( char* special_file, char* dir, char* fstype, ulong options, void* data ) ; diff --git a/extra/unix/linux/swap/swap.factor b/extra/unix/linux/swap/swap.factor index 4cafa5723f..b4edaaa8e3 100644 --- a/extra/unix/linux/swap/swap.factor +++ b/extra/unix/linux/swap/swap.factor @@ -3,9 +3,9 @@ USING: alien.syntax ; IN: unix.linux.swap -: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified. -: SWAP_FLAG_PRIO_MASK HEX: 7fff ; -: SWAP_FLAG_PRIO_SHIFT 0 ; +: SWAP_FLAG_PREFER HEX: 8000 ; ! Set if swap priority is specified. +: SWAP_FLAG_PRIO_MASK HEX: 7fff ; +: SWAP_FLAG_PRIO_SHIFT 0 ; FUNCTION: int swapon ( char* path, int flags ) ; diff --git a/extra/webapps/article-manager/database/database.factor b/extra/webapps/article-manager/database/database.factor index 8463c2545b..0349ad9ea7 100644 --- a/extra/webapps/article-manager/database/database.factor +++ b/extra/webapps/article-manager/database/database.factor @@ -22,7 +22,7 @@ article default-mapping set-mapping tag default-mapping set-mapping : db ( -- object ) - { f } ; + { f } ; : set-db ( value -- ) 0 db set-nth ; diff --git a/extra/webapps/callback/callback.factor b/extra/webapps/callback/callback.factor index bf1ebe6648..6bdc84bfa6 100644 --- a/extra/webapps/callback/callback.factor +++ b/extra/webapps/callback/callback.factor @@ -111,7 +111,7 @@ TUPLE: item quot expire? request id time-added ; expire-callbacks "id" query-param callback-table at [ [ - dup item-request [ + dup item-request [ update-request ] when* item-quot call diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index 3e09b57dd1..e9105ee459 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer ; +xml.writer prettyprint ; IN: webapps.planet : print-posting-summary ( posting -- ) diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index a749fcb52b..fd2a9fb8af 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -484,19 +484,19 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, : TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline : TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; : TOKEN_WRITE STANDARD_RIGHTS_WRITE - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable + TOKEN_ADJUST_PRIVILEGES bitor + TOKEN_ADJUST_GROUPS bitor + TOKEN_ADJUST_DEFAULT bitor ; foldable : TOKEN_ALL_ACCESS STANDARD_RIGHTS_REQUIRED - TOKEN_ASSIGN_PRIMARY bitor - TOKEN_DUPLICATE bitor - TOKEN_IMPERSONATE bitor - TOKEN_QUERY bitor - TOKEN_QUERY_SOURCE bitor - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_SESSIONID bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable + TOKEN_ASSIGN_PRIMARY bitor + TOKEN_DUPLICATE bitor + TOKEN_IMPERSONATE bitor + TOKEN_QUERY bitor + TOKEN_QUERY_SOURCE bitor + TOKEN_ADJUST_PRIVILEGES bitor + TOKEN_ADJUST_GROUPS bitor + TOKEN_ADJUST_SESSIONID bitor + TOKEN_ADJUST_DEFAULT bitor ; foldable FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, diff --git a/extra/x/widgets/widgets.factor b/extra/x/widgets/widgets.factor index 34540c489f..d8c28f5d64 100644 --- a/extra/x/widgets/widgets.factor +++ b/extra/x/widgets/widgets.factor @@ -32,7 +32,7 @@ SYMBOL: { [ dup UnmapNotify = ] [ drop <- handle-unmap ] } { [ dup PropertyNotify = ] [ drop <- handle-property ] } { [ t ] [ "handle-event :: ignoring event" - print flush 3drop ] } + print flush 3drop ] } } cond ] } add-methods \ No newline at end of file diff --git a/extra/x/widgets/wm/frame/drag/move/move.factor b/extra/x/widgets/wm/frame/drag/move/move.factor index 2a6d61596e..f29993e1d7 100644 --- a/extra/x/widgets/wm/frame/drag/move/move.factor +++ b/extra/x/widgets/wm/frame/drag/move/move.factor @@ -37,9 +37,9 @@ SYMBOL: [ <- draw-move-outline <- update-posn <- draw-move-outline <- loop ] } { [ <- event-type ButtonRelease = ] [ <- draw-move-outline - dup $frame <- position over <- drag-offset v+ >r - dup $frame r> <-- move drop - dup $frame <- raise drop drop ] } + dup $frame <- position over <- drag-offset v+ >r + dup $frame r> <-- move drop + dup $frame <- raise drop drop ] } { [ t ] [ <- loop ] } } cond ] diff --git a/extra/x/widgets/wm/frame/drag/size/size.factor b/extra/x/widgets/wm/frame/drag/size/size.factor index 5ef28e2a41..8dba541768 100644 --- a/extra/x/widgets/wm/frame/drag/size/size.factor +++ b/extra/x/widgets/wm/frame/drag/size/size.factor @@ -37,8 +37,8 @@ SYMBOL: [ <- draw-size-outline <- update-posn <- draw-size-outline <- loop ] } { [ <- event-type ButtonRelease = ] [ <- draw-size-outline - dup $frame over $posn pick $frame <- position v- <-- resize - <- adjust-child drop ] } + dup $frame over $posn pick $frame <- position v- <-- resize + <- adjust-child drop ] } { [ t ] [ <- loop ] } } cond ] diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index d8f08d8772..ecf628b9c7 100644 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -137,7 +137,7 @@ SYMBOL: WM_DELETE_WINDOW [ over XConfigureRequestEvent-height <-- set-child-height ] } { [ t ] [ " handle-configure-request :: resize not requested" - print flush ] } } + print flush ] } } cond 2drop ] diff --git a/extra/x/widgets/wm/root/root.factor b/extra/x/widgets/wm/root/root.factor index f5352a0f07..2f6882304f 100755 --- a/extra/x/widgets/wm/root/root.factor +++ b/extra/x/widgets/wm/root/root.factor @@ -64,7 +64,7 @@ dup XKeyEvent-state swap event>keyname 2array ; "handle-map-request" !( event wm-root -- ) [ { { [ over XMapRequestEvent-window managed? ] [ " handle-map-request :: window already managed" print flush - 2drop ] } + 2drop ] } { [ t ] [ drop XMapRequestEvent-window <<- create drop ] } } cond ] @@ -88,7 +88,7 @@ dup XKeyEvent-state swap event>keyname 2array ; { [ over CWX? ] [ over XConfigureRequestEvent-x <-- set-x ] } { [ over CWY? ] [ over XConfigureRequestEvent-y <-- set-y ] } { [ t ] [ " handle-configure-request :: move not requested" - print flush ] } } + print flush ] } } cond { { [ over dup CWWidth? swap CWHeight? and ] @@ -96,7 +96,7 @@ dup XKeyEvent-state swap event>keyname 2array ; { [ over CWWidth? ] [ over XConfigureRequestEvent-width <-- set-width ] } { [ over CWHeight? ] [ over XConfigureRequestEvent-height <-- set-height ] } { [ t ] [ " handle-configure-request :: resize not requested" - print flush ] } } + print flush ] } } cond 2drop ] diff --git a/extra/x/x.factor b/extra/x/x.factor index 8d9f869fa3..63d90f58db 100644 --- a/extra/x/x.factor +++ b/extra/x/x.factor @@ -330,7 +330,7 @@ add-method [ 3dup dup <- top-left swap <- top-right <---- draw-line 3dup dup <- top-right swap <- bottom-right <---- draw-line 3dup dup <- bottom-left swap <- bottom-right <---- draw-line - dup <- top-left swap <- bottom-left <---- draw-line ] + dup <- top-left swap <- bottom-left <---- draw-line ] add-method ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -449,8 +449,8 @@ USING: alien.syntax ; FUNCTION: KeyCode XKeysymToKeycode ( Display* display, KeySym keysym ) ; FUNCTION: KeySym XKeycodeToKeysym ( Display* display, - KeyCode keycode, - int index ) ; + KeyCode keycode, + int index ) ; FUNCTION: char* XKeysymToString ( KeySym keysym ) ; diff --git a/extra/x11/constants/constants.factor b/extra/x11/constants/constants.factor index ac0367eb44..367f40cebd 100644 --- a/extra/x11/constants/constants.factor +++ b/extra/x11/constants/constants.factor @@ -31,21 +31,21 @@ TYPEDEF: uchar KeyCode ! modifier names. Used to build a SetModifierMapping request or ! to read a GetModifierMapping request. These correspond to the ! masks defined above. -: ShiftMapIndex 0 ; -: LockMapIndex 1 ; -: ControlMapIndex 2 ; -: Mod1MapIndex 3 ; -: Mod2MapIndex 4 ; -: Mod3MapIndex 5 ; -: Mod4MapIndex 6 ; -: Mod5MapIndex 7 ; +: ShiftMapIndex 0 ; +: LockMapIndex 1 ; +: ControlMapIndex 2 ; +: Mod1MapIndex 3 ; +: Mod2MapIndex 4 ; +: Mod3MapIndex 5 ; +: Mod4MapIndex 6 ; +: Mod5MapIndex 7 ; ! button masks. Used in same manner as Key masks above. Not to be confused ! with button names below. -: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey +: AnyModifier 1 15 shift ; ! used in GrabButton, GrabKey ! button names. Used as arguments to GrabButton and as detail in ButtonPress ! and ButtonRelease events. Not to be confused with button masks above. @@ -53,117 +53,117 @@ TYPEDEF: uchar KeyCode ! Notify modes -: NotifyNormal 0 ; -: NotifyGrab 1 ; -: NotifyUngrab 2 ; -: NotifyWhileGrabbed 3 ; +: NotifyNormal 0 ; +: NotifyGrab 1 ; +: NotifyUngrab 2 ; +: NotifyWhileGrabbed 3 ; -: NotifyHint 1 ; ! for MotionNotify events - +: NotifyHint 1 ; ! for MotionNotify events + ! Notify detail -: NotifyAncestor 0 ; -: NotifyVirtual 1 ; -: NotifyInferior 2 ; -: NotifyNonlinear 3 ; +: NotifyAncestor 0 ; +: NotifyVirtual 1 ; +: NotifyInferior 2 ; +: NotifyNonlinear 3 ; : NotifyNonlinearVirtual 4 ; -: NotifyPointer 5 ; -: NotifyPointerRoot 6 ; -: NotifyDetailNone 7 ; +: NotifyPointer 5 ; +: NotifyPointerRoot 6 ; +: NotifyDetailNone 7 ; ! Visibility notify -: VisibilityUnobscured 0 ; -: VisibilityPartiallyObscured 1 ; -: VisibilityFullyObscured 2 ; +: VisibilityUnobscured 0 ; +: VisibilityPartiallyObscured 1 ; +: VisibilityFullyObscured 2 ; ! Circulation request -: PlaceOnTop 0 ; -: PlaceOnBottom 1 ; +: PlaceOnTop 0 ; +: PlaceOnBottom 1 ; ! protocol families -: FamilyInternet 0 ; ! IPv4 -: FamilyDECnet 1 ; -: FamilyChaos 2 ; -: FamilyInternet6 6 ; ! IPv6 +: FamilyInternet 0 ; ! IPv4 +: FamilyDECnet 1 ; +: FamilyChaos 2 ; +: FamilyInternet6 6 ; ! IPv6 ! authentication families not tied to a specific protocol : FamilyServerInterpreted 5 ; ! Property notification -: PropertyNewValue 0 ; -: PropertyDelete 1 ; +: PropertyNewValue 0 ; +: PropertyDelete 1 ; ! Color Map notification -: ColormapUninstalled 0 ; -: ColormapInstalled 1 ; +: ColormapUninstalled 0 ; +: ColormapInstalled 1 ; ! GrabPointer, GrabButton, GrabKeyboard, GrabKey Modes -: GrabModeSync 0 ; -: GrabModeAsync 1 ; +: GrabModeSync 0 ; +: GrabModeAsync 1 ; ! GrabPointer, GrabKeyboard reply status -: GrabSuccess 0 ; -: AlreadyGrabbed 1 ; -: GrabInvalidTime 2 ; -: GrabNotViewable 3 ; -: GrabFrozen 4 ; +: GrabSuccess 0 ; +: AlreadyGrabbed 1 ; +: GrabInvalidTime 2 ; +: GrabNotViewable 3 ; +: GrabFrozen 4 ; ! AllowEvents modes -: AsyncPointer 0 ; -: SyncPointer 1 ; -: ReplayPointer 2 ; -: AsyncKeyboard 3 ; -: SyncKeyboard 4 ; -: ReplayKeyboard 5 ; -: AsyncBoth 6 ; -: SyncBoth 7 ; +: AsyncPointer 0 ; +: SyncPointer 1 ; +: ReplayPointer 2 ; +: AsyncKeyboard 3 ; +: SyncKeyboard 4 ; +: ReplayKeyboard 5 ; +: AsyncBoth 6 ; +: SyncBoth 7 ; ! Used in SetInputFocus, GetInputFocus -: RevertToNone None ; -: RevertToPointerRoot PointerRoot ; -: RevertToParent 2 ; +: RevertToNone None ; +: RevertToPointerRoot PointerRoot ; +: RevertToParent 2 ; ! ***************************************************************** ! * ERROR CODES ! ***************************************************************** -: Success 0 ; ! everything's okay -: BadRequest 1 ; ! bad request code -: BadValue 2 ; ! int parameter out of range -: BadWindow 3 ; ! parameter not a Window -: BadPixmap 4 ; ! parameter not a Pixmap -: BadAtom 5 ; ! parameter not an Atom -: BadCursor 6 ; ! parameter not a Cursor -: BadFont 7 ; ! parameter not a Font -: BadMatch 8 ; ! parameter mismatch -: BadDrawable 9 ; ! parameter not a Pixmap or Window -: BadAccess 10 ; ! depending on context: - ! - key/button already grabbed - ! - attempt to free an illegal - ! cmap entry - ! - attempt to store into a read-only - ! color map entry. - ! - attempt to modify the access control - ! list from other than the local host. -: BadAlloc 11 ; ! insufficient resources -: BadColor 12 ; ! no such colormap -: BadGC 13 ; ! parameter not a GC -: BadIDChoice 14 ; ! choice not in range or already used +: Success 0 ; ! everything's okay +: BadRequest 1 ; ! bad request code +: BadValue 2 ; ! int parameter out of range +: BadWindow 3 ; ! parameter not a Window +: BadPixmap 4 ; ! parameter not a Pixmap +: BadAtom 5 ; ! parameter not an Atom +: BadCursor 6 ; ! parameter not a Cursor +: BadFont 7 ; ! parameter not a Font +: BadMatch 8 ; ! parameter mismatch +: BadDrawable 9 ; ! parameter not a Pixmap or Window +: BadAccess 10 ; ! depending on context: + ! - key/button already grabbed + ! - attempt to free an illegal + ! cmap entry + ! - attempt to store into a read-only + ! color map entry. + ! - attempt to modify the access control + ! list from other than the local host. +: BadAlloc 11 ; ! insufficient resources +: BadColor 12 ; ! no such colormap +: BadGC 13 ; ! parameter not a GC +: BadIDChoice 14 ; ! choice not in range or already used : BadName 15 ; ! font or color name doesn't exist -: BadLength 16 ; ! Request length incorrect +: BadLength 16 ; ! Request length incorrect : BadImplementation 17 ; ! server is defective -: FirstExtensionError 128 ; -: LastExtensionError 255 ; +: FirstExtensionError 128 ; +: LastExtensionError 255 ; ! ***************************************************************** ! * WINDOW DEFINITIONS @@ -172,8 +172,8 @@ TYPEDEF: uchar KeyCode ! Window classes used by CreateWindow ! Note that CopyFromParent is already defined as 0 above -: InputOutput 1 ; -: InputOnly 2 ; +: InputOutput 1 ; +: InputOnly 2 ; ! Used in CreateWindow for backing-store hint @@ -217,46 +217,46 @@ TYPEDEF: uchar KeyCode ! LineStyle -: LineSolid 0 ; -: LineOnOffDash 1 ; -: LineDoubleDash 2 ; +: LineSolid 0 ; +: LineOnOffDash 1 ; +: LineDoubleDash 2 ; ! capStyle -: CapNotLast 0 ; -: CapButt 1 ; -: CapRound 2 ; -: CapProjecting 3 ; +: CapNotLast 0 ; +: CapButt 1 ; +: CapRound 2 ; +: CapProjecting 3 ; ! joinStyle -: JoinMiter 0 ; -: JoinRound 1 ; -: JoinBevel 2 ; +: JoinMiter 0 ; +: JoinRound 1 ; +: JoinBevel 2 ; ! fillStyle -: FillSolid 0 ; -: FillTiled 1 ; -: FillStippled 2 ; -: FillOpaqueStippled 3 ; +: FillSolid 0 ; +: FillTiled 1 ; +: FillStippled 2 ; +: FillOpaqueStippled 3 ; ! fillRule -: EvenOddRule 0 ; -: WindingRule 1 ; +: EvenOddRule 0 ; +: WindingRule 1 ; ! subwindow mode -: ClipByChildren 0 ; -: IncludeInferiors 1 ; +: ClipByChildren 0 ; +: IncludeInferiors 1 ; ! SetClipRectangles ordering -: Unsorted 0 ; -: YSorted 1 ; -: YXSorted 2 ; -: YXBanded 3 ; +: Unsorted 0 ; +: YSorted 1 ; +: YXSorted 2 ; +: YXBanded 3 ; ! CoordinateMode for drawing routines @@ -265,9 +265,9 @@ TYPEDEF: uchar KeyCode ! Polygon shapes -: Complex 0 ; ! paths may intersect -: Nonconvex 1 ; ! no paths intersect, but not convex -: Convex 2 ; ! wholly convex +: Complex 0 ; ! paths may intersect +: Nonconvex 1 ; ! no paths intersect, but not convex +: Convex 2 ; ! wholly convex ! Arc modes for PolyFillArc @@ -280,10 +280,10 @@ TYPEDEF: uchar KeyCode ! used in QueryFont -- draw direction -: FontLeftToRight 0 ; -: FontRightToLeft 1 ; +: FontLeftToRight 0 ; +: FontRightToLeft 1 ; -: FontChange 255 ; +: FontChange 255 ; ! ***************************************************************** ! * IMAGING @@ -291,9 +291,9 @@ TYPEDEF: uchar KeyCode ! ImageFormat -- PutImage, GetImage -: XYBitmap 0 ; ! depth 1, XYFormat -: XYPixmap 1 ; ! depth == drawable depth -: ZPixmap 2 ; ! depth == drawable depth +: XYBitmap 0 ; ! depth 1, XYFormat +: XYPixmap 1 ; ! depth == drawable depth +: ZPixmap 2 ; ! depth == drawable depth ! ***************************************************************** ! * COLOR MAP STUFF @@ -301,15 +301,15 @@ TYPEDEF: uchar KeyCode ! For CreateColormap -: AllocNone 0 ; ! create map with no entries -: AllocAll 1 ; ! allocate entire map writeable +: AllocNone 0 ; ! create map with no entries +: AllocAll 1 ; ! allocate entire map writeable ! Flags used in StoreNamedColor, StoreColors -: DoRed 1 0 shift ; -: DoGreen 1 1 shift ; -: DoBlue 1 2 shift ; +: DoRed 1 0 shift ; +: DoGreen 1 1 shift ; +: DoBlue 1 2 shift ; ! ***************************************************************** ! * CURSOR STUFF @@ -317,54 +317,54 @@ TYPEDEF: uchar KeyCode ! QueryBestSize Class -: CursorShape 0 ; ! largest size that can be displayed -: TileShape 1 ; ! size tiled fastest -: StippleShape 2 ; ! size stippled fastest +: CursorShape 0 ; ! largest size that can be displayed +: TileShape 1 ; ! size tiled fastest +: StippleShape 2 ; ! size stippled fastest ! ***************************************************************** ! * KEYBOARD/POINTER STUFF ! ***************************************************************** -: AutoRepeatModeOff 0 ; -: AutoRepeatModeOn 1 ; -: AutoRepeatModeDefault 2 ; +: AutoRepeatModeOff 0 ; +: AutoRepeatModeOn 1 ; +: AutoRepeatModeDefault 2 ; -: LedModeOff 0 ; -: LedModeOn 1 ; +: LedModeOff 0 ; +: LedModeOn 1 ; ! masks for ChangeKeyboardControl -: KBKeyClickPercent 1 0 shift ; -: KBBellPercent 1 1 shift ; -: KBBellPitch 1 2 shift ; -: KBBellDuration 1 3 shift ; -: KBLed 1 4 shift ; -: KBLedMode 1 5 shift ; -: KBKey 1 6 shift ; -: KBAutoRepeatMode 1 7 shift ; +: KBKeyClickPercent 1 0 shift ; +: KBBellPercent 1 1 shift ; +: KBBellPitch 1 2 shift ; +: KBBellDuration 1 3 shift ; +: KBLed 1 4 shift ; +: KBLedMode 1 5 shift ; +: KBKey 1 6 shift ; +: KBAutoRepeatMode 1 7 shift ; -: MappingSuccess 0 ; -: MappingBusy 1 ; -: MappingFailed 2 ; +: MappingSuccess 0 ; +: MappingBusy 1 ; +: MappingFailed 2 ; -: MappingModifier 0 ; -: MappingKeyboard 1 ; -: MappingPointer 2 ; +: MappingModifier 0 ; +: MappingKeyboard 1 ; +: MappingPointer 2 ; ! ***************************************************************** ! * SCREEN SAVER STUFF ! ***************************************************************** -: DontPreferBlanking 0 ; -: PreferBlanking 1 ; -: DefaultBlanking 2 ; +: DontPreferBlanking 0 ; +: PreferBlanking 1 ; +: DefaultBlanking 2 ; -: DisableScreenSaver 0 ; -: DisableScreenInterval 0 ; +: DisableScreenSaver 0 ; +: DisableScreenInterval 0 ; -: DontAllowExposures 0 ; -: AllowExposures 1 ; -: DefaultExposures 2 ; +: DontAllowExposures 0 ; +: AllowExposures 1 ; +: DefaultExposures 2 ; ! for ForceScreenSaver @@ -377,28 +377,28 @@ TYPEDEF: uchar KeyCode ! for ChangeHosts -: HostInsert 0 ; -: HostDelete 1 ; +: HostInsert 0 ; +: HostDelete 1 ; ! for ChangeAccessControl -: EnableAccess 1 ; -: DisableAccess 0 ; +: EnableAccess 1 ; +: DisableAccess 0 ; ! Display classes used in opening the connection ! Note that the statically allocated ones are even numbered and the ! dynamically changeable ones are odd numbered -: StaticGray 0 ; -: GrayScale 1 ; -: StaticColor 2 ; -: PseudoColor 3 ; -: TrueColor 4 ; -: DirectColor 5 ; +: StaticGray 0 ; +: GrayScale 1 ; +: StaticColor 2 ; +: PseudoColor 3 ; +: TrueColor 4 ; +: DirectColor 5 ; ! Byte order used in imageByteOrder and bitmapBitOrder -: LSBFirst 0 ; -: MSBFirst 1 ; +: LSBFirst 0 ; +: MSBFirst 1 ; diff --git a/extra/x11/glx/glx.factor b/extra/x11/glx/glx.factor index 1a898c50a9..2b1d05e2e4 100644 --- a/extra/x11/glx/glx.factor +++ b/extra/x11/glx/glx.factor @@ -9,23 +9,23 @@ IN: x11.glx LIBRARY: glx ! Visual Config Attributes (glXGetConfig, glXGetFBConfigAttrib) -: GLX_USE_GL 1 ; ! support GLX rendering -: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer -: GLX_LEVEL 3 ; ! level in plane stacking -: GLX_RGBA 4 ; ! true if RGBA mode -: GLX_DOUBLEBUFFER 5 ; ! double buffering supported -: GLX_STEREO 6 ; ! stereo buffering supported -: GLX_AUX_BUFFERS 7 ; ! number of aux buffers -: GLX_RED_SIZE 8 ; ! number of red component bits -: GLX_GREEN_SIZE 9 ; ! number of green component bits -: GLX_BLUE_SIZE 10 ; ! number of blue component bits -: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits -: GLX_DEPTH_SIZE 12 ; ! number of depth bits -: GLX_STENCIL_SIZE 13 ; ! number of stencil bits -: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits -: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits -: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits -: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits +: GLX_USE_GL 1 ; ! support GLX rendering +: GLX_BUFFER_SIZE 2 ; ! depth of the color buffer +: GLX_LEVEL 3 ; ! level in plane stacking +: GLX_RGBA 4 ; ! true if RGBA mode +: GLX_DOUBLEBUFFER 5 ; ! double buffering supported +: GLX_STEREO 6 ; ! stereo buffering supported +: GLX_AUX_BUFFERS 7 ; ! number of aux buffers +: GLX_RED_SIZE 8 ; ! number of red component bits +: GLX_GREEN_SIZE 9 ; ! number of green component bits +: GLX_BLUE_SIZE 10 ; ! number of blue component bits +: GLX_ALPHA_SIZE 11 ; ! number of alpha component bits +: GLX_DEPTH_SIZE 12 ; ! number of depth bits +: GLX_STENCIL_SIZE 13 ; ! number of stencil bits +: GLX_ACCUM_RED_SIZE 14 ; ! number of red accum bits +: GLX_ACCUM_GREEN_SIZE 15 ; ! number of green accum bits +: GLX_ACCUM_BLUE_SIZE 16 ; ! number of blue accum bits +: GLX_ACCUM_ALPHA_SIZE 17 ; ! number of alpha accum bits TYPEDEF: XID GLXContextID TYPEDEF: XID GLXPixmap diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor index 1f44460026..94695720ea 100644 --- a/extra/x11/windows/windows.factor +++ b/extra/x11/windows/windows.factor @@ -17,7 +17,7 @@ IN: x11.windows StructureNotifyMask bitor KeyPressMask bitor KeyReleaseMask bitor - ButtonPressMask bitor + ButtonPressMask bitor ButtonReleaseMask bitor PointerMotionMask bitor FocusChangeMask bitor diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor index 730c4cf7cd..8dd8a55acc 100644 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -92,52 +92,52 @@ FUNCTION: int XCloseDisplay ( Display* display ) ; ! 3.2 - Window Attributes -: CWBackPixmap 1 0 shift ; inline -: CWBackPixel 1 1 shift ; inline -: CWBorderPixmap 1 2 shift ; inline +: CWBackPixmap 1 0 shift ; inline +: CWBackPixel 1 1 shift ; inline +: CWBorderPixmap 1 2 shift ; inline : CWBorderPixel 1 3 shift ; inline -: CWBitGravity 1 4 shift ; inline -: CWWinGravity 1 5 shift ; inline +: CWBitGravity 1 4 shift ; inline +: CWWinGravity 1 5 shift ; inline : CWBackingStore 1 6 shift ; inline -: CWBackingPlanes 1 7 shift ; inline -: CWBackingPixel 1 8 shift ; inline -: CWOverrideRedirect 1 9 shift ; inline -: CWSaveUnder 1 10 shift ; inline -: CWEventMask 1 11 shift ; inline -: CWDontPropagate 1 12 shift ; inline -: CWColormap 1 13 shift ; inline -: CWCursor 1 14 shift ; inline +: CWBackingPlanes 1 7 shift ; inline +: CWBackingPixel 1 8 shift ; inline +: CWOverrideRedirect 1 9 shift ; inline +: CWSaveUnder 1 10 shift ; inline +: CWEventMask 1 11 shift ; inline +: CWDontPropagate 1 12 shift ; inline +: CWColormap 1 13 shift ; inline +: CWCursor 1 14 shift ; inline C-STRUCT: XSetWindowAttributes - { "Pixmap" "background_pixmap" } - { "ulong" "background_pixel" } - { "Pixmap" "border_pixmap" } - { "ulong" "border_pixel" } - { "int" "bit_gravity" } - { "int" "win_gravity" } - { "int" "backing_store" } - { "ulong" "backing_planes" } - { "ulong" "backing_pixel" } - { "Bool" "save_under" } - { "long" "event_mask" } - { "long" "do_not_propagate_mask" } - { "Bool" "override_redirect" } - { "Colormap" "colormap" } - { "Cursor" "cursor" } ; + { "Pixmap" "background_pixmap" } + { "ulong" "background_pixel" } + { "Pixmap" "border_pixmap" } + { "ulong" "border_pixel" } + { "int" "bit_gravity" } + { "int" "win_gravity" } + { "int" "backing_store" } + { "ulong" "backing_planes" } + { "ulong" "backing_pixel" } + { "Bool" "save_under" } + { "long" "event_mask" } + { "long" "do_not_propagate_mask" } + { "Bool" "override_redirect" } + { "Colormap" "colormap" } + { "Cursor" "cursor" } ; -: UnmapGravity 0 ; inline +: UnmapGravity 0 ; inline -: ForgetGravity 0 ; inline -: NorthWestGravity 1 ; inline -: NorthGravity 2 ; inline -: NorthEastGravity 3 ; inline -: WestGravity 4 ; inline -: CenterGravity 5 ; inline -: EastGravity 6 ; inline -: SouthWestGravity 7 ; inline -: SouthGravity 8 ; inline -: SouthEastGravity 9 ; inline -: StaticGravity 10 ; inline +: ForgetGravity 0 ; inline +: NorthWestGravity 1 ; inline +: NorthGravity 2 ; inline +: NorthEastGravity 3 ; inline +: WestGravity 4 ; inline +: CenterGravity 5 ; inline +: EastGravity 6 ; inline +: SouthWestGravity 7 ; inline +: SouthGravity 8 ; inline +: SouthEastGravity 9 ; inline +: StaticGravity 10 ; inline ! 3.3 - Creating Windows @@ -155,22 +155,22 @@ FUNCTION: int XMapRaised ( Display* display, Window w ) ; ! 3.7 - Configuring Windows -: CWX 1 0 shift ; inline -: CWY 1 1 shift ; inline -: CWWidth 1 2 shift ; inline -: CWHeight 1 3 shift ; inline -: CWBorderWidth 1 4 shift ; inline -: CWSibling 1 5 shift ; inline -: CWStackMode 1 6 shift ; inline +: CWX 1 0 shift ; inline +: CWY 1 1 shift ; inline +: CWWidth 1 2 shift ; inline +: CWHeight 1 3 shift ; inline +: CWBorderWidth 1 4 shift ; inline +: CWSibling 1 5 shift ; inline +: CWStackMode 1 6 shift ; inline C-STRUCT: XWindowChanges - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "sibling" } - { "int" "stack_mode" } ; + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "border_width" } + { "Window" "sibling" } + { "int" "stack_mode" } ; FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ; FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ; @@ -206,35 +206,35 @@ FUNCTION: Status XQueryTree ( Window** children_return, uint* nchildren_return ) ; C-STRUCT: XWindowAttributes - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" " height" } - { "int" "border_width" } - { "int" "depth" } - { "Visual*" "visual" } - { "Window" "root" } - { "int" "class" } - { "int" "bit_gravity" } - { "int" "win_gravity" } - { "int" "backing_store" } - { "ulong" "backing_planes" } - { "ulong" "backing_pixel" } - { "Bool" "save_under" } - { "Colormap" "colormap" } - { "Bool" "map_installed" } - { "int" "map_state" } - { "long" "all_event_masks" } - { "long" "your_event_mask" } - { "long" "do_not_propagate_mask" } - { "Bool" "override_redirect" } - { "Screen*" "screen" } ; + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" " height" } + { "int" "border_width" } + { "int" "depth" } + { "Visual*" "visual" } + { "Window" "root" } + { "int" "class" } + { "int" "bit_gravity" } + { "int" "win_gravity" } + { "int" "backing_store" } + { "ulong" "backing_planes" } + { "ulong" "backing_pixel" } + { "Bool" "save_under" } + { "Colormap" "colormap" } + { "Bool" "map_installed" } + { "int" "map_state" } + { "long" "all_event_masks" } + { "long" "your_event_mask" } + { "long" "do_not_propagate_mask" } + { "Bool" "override_redirect" } + { "Screen*" "screen" } ; FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ; -: IsUnmapped 0 ; inline -: IsUnviewable 1 ; inline -: IsViewable 2 ; inline +: IsUnmapped 0 ; inline +: IsUnviewable 1 ; inline +: IsViewable 2 ; inline FUNCTION: Status XGetGeometry ( Display* display, @@ -276,12 +276,12 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XColor - { "ulong" "pixel" } - { "ushort" "red" } - { "ushort" "green" } - { "ushort" "blue" } - { "char" "flags" } - { "char" "pad" } ; + { "ulong" "pixel" } + { "ushort" "red" } + { "ushort" "green" } + { "ushort" "blue" } + { "char" "flags" } + { "char" "pad" } ; FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ; FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ; @@ -302,64 +302,64 @@ FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, : GCLineWidth 1 4 shift ; inline : GCLineStyle 1 5 shift ; inline : GCCapStyle 1 6 shift ; inline -: GCJoinStyle 1 7 shift ; inline -: GCFillStyle 1 8 shift ; inline -: GCFillRule 1 9 shift ; inline -: GCTile 1 10 shift ; inline -: GCStipple 1 11 shift ; inline -: GCTileStipXOrigin 1 12 shift ; inline -: GCTileStipYOrigin 1 13 shift ; inline -: GCFont 1 14 shift ; inline -: GCSubwindowMode 1 15 shift ; inline +: GCJoinStyle 1 7 shift ; inline +: GCFillStyle 1 8 shift ; inline +: GCFillRule 1 9 shift ; inline +: GCTile 1 10 shift ; inline +: GCStipple 1 11 shift ; inline +: GCTileStipXOrigin 1 12 shift ; inline +: GCTileStipYOrigin 1 13 shift ; inline +: GCFont 1 14 shift ; inline +: GCSubwindowMode 1 15 shift ; inline : GCGraphicsExposures 1 16 shift ; inline -: GCClipXOrigin 1 17 shift ; inline -: GCClipYOrigin 1 18 shift ; inline -: GCClipMask 1 19 shift ; inline -: GCDashOffset 1 20 shift ; inline -: GCDashList 1 21 shift ; inline -: GCArcMode 1 22 shift ; inline +: GCClipXOrigin 1 17 shift ; inline +: GCClipYOrigin 1 18 shift ; inline +: GCClipMask 1 19 shift ; inline +: GCDashOffset 1 20 shift ; inline +: GCDashList 1 21 shift ; inline +: GCArcMode 1 22 shift ; inline -: GXclear HEX: 0 ; inline -: GXand HEX: 1 ; inline -: GXandReverse HEX: 2 ; inline -: GXcopy HEX: 3 ; inline -: GXandInverted HEX: 4 ; inline -: GXnoop HEX: 5 ; inline -: GXxor HEX: 6 ; inline -: GXor HEX: 7 ; inline -: GXnor HEX: 8 ; inline -: GXequiv HEX: 9 ; inline -: GXinvert HEX: a ; inline -: GXorReverse HEX: b ; inline -: GXcopyInverted HEX: c ; inline -: GXorInverted HEX: d ; inline -: GXnand HEX: e ; inline -: GXset HEX: f ; inline +: GXclear HEX: 0 ; inline +: GXand HEX: 1 ; inline +: GXandReverse HEX: 2 ; inline +: GXcopy HEX: 3 ; inline +: GXandInverted HEX: 4 ; inline +: GXnoop HEX: 5 ; inline +: GXxor HEX: 6 ; inline +: GXor HEX: 7 ; inline +: GXnor HEX: 8 ; inline +: GXequiv HEX: 9 ; inline +: GXinvert HEX: a ; inline +: GXorReverse HEX: b ; inline +: GXcopyInverted HEX: c ; inline +: GXorInverted HEX: d ; inline +: GXnand HEX: e ; inline +: GXset HEX: f ; inline C-STRUCT: XGCValues - { "int" "function" } - { "ulong" "plane_mask" } - { "ulong" "foreground" } - { "ulong" "background" } - { "int" "line_width" } - { "int" "line_style" } - { "int" "cap_style" } - { "int" "join_style" } - { "int" "fill_style" } - { "int" "fill_rule" } - { "int" "arc_mode" } - { "Pixmap" "tile" } - { "Pixmap" "stipple" } - { "int" "ts_x_origin" } - { "int" "ts_y_origin" } - { "Font" "font" } - { "int" "subwindow_mode" } - { "Bool" "graphics_exposures" } - { "int" "clip_x_origin" } - { "int" "clip_y_origin" } - { "Pixmap" "clip_mask" } - { "int" "dash_offset" } - { "char" "dashes" } ; + { "int" "function" } + { "ulong" "plane_mask" } + { "ulong" "foreground" } + { "ulong" "background" } + { "int" "line_width" } + { "int" "line_style" } + { "int" "cap_style" } + { "int" "join_style" } + { "int" "fill_style" } + { "int" "fill_rule" } + { "int" "arc_mode" } + { "Pixmap" "tile" } + { "Pixmap" "stipple" } + { "int" "ts_x_origin" } + { "int" "ts_y_origin" } + { "Font" "font" } + { "int" "subwindow_mode" } + { "Bool" "graphics_exposures" } + { "int" "clip_x_origin" } + { "int" "clip_y_origin" } + { "Pixmap" "clip_mask" } + { "int" "dash_offset" } + { "char" "dashes" } ; FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ; FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ; @@ -386,47 +386,47 @@ FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, u ! 8.5 - Font Metrics C-STRUCT: XCharStruct - { "short" "lbearing" } - { "short" "rbearing" } - { "short" "width" } - { "short" "ascent" } - { "short" "descent" } - { "ushort" "attributes" } ; + { "short" "lbearing" } + { "short" "rbearing" } + { "short" "width" } + { "short" "ascent" } + { "short" "descent" } + { "ushort" "attributes" } ; FUNCTION: Font XLoadFont ( Display* display, char* name ) ; FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; C-STRUCT: XFontStruct - { "XExtData*" "ext_data" } - { "Font" "fid" } - { "uint" "direction" } - { "uint" "min_char_or_byte2" } - { "uint" "max_char_or_byte2" } - { "uint" "min_byte1" } - { "uint" "max_byte1" } - { "Bool" "all_chars_exist" } - { "uint" "default_char" } - { "int" "n_properties" } - { "XFontProp*" "properties" } - { "XCharStruct" "min_bounds" } - { "XCharStruct" "max_bounds" } - { "XCharStruct*" "per_char" } - { "int" "ascent" } - { "int" "descent" } ; + { "XExtData*" "ext_data" } + { "Font" "fid" } + { "uint" "direction" } + { "uint" "min_char_or_byte2" } + { "uint" "max_char_or_byte2" } + { "uint" "min_byte1" } + { "uint" "max_byte1" } + { "Bool" "all_chars_exist" } + { "uint" "default_char" } + { "int" "n_properties" } + { "XFontProp*" "properties" } + { "XCharStruct" "min_bounds" } + { "XCharStruct" "max_bounds" } + { "XCharStruct*" "per_char" } + { "int" "ascent" } + { "int" "descent" } ; FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text FUNCTION: Status XDrawString ( - Display* display, - Drawable d, - GC gc, - int x, - int y, - char* string, - int length ) ; + Display* display, + Drawable d, + GC gc, + int x, + int y, + char* string, + int length ) ; ! ! 9 - Window and Session Manager Functions @@ -445,74 +445,74 @@ FUNCTION: Status XKillClient ( Display* display, XID resource ) ; ! 10.3 - Event Masks -: NoEventMask 0 ; inline -: KeyPressMask 1 0 shift ; inline -: KeyReleaseMask 1 1 shift ; inline -: ButtonPressMask 1 2 shift ; inline -: ButtonReleaseMask 1 3 shift ; inline -: EnterWindowMask 1 4 shift ; inline -: LeaveWindowMask 1 5 shift ; inline -: PointerMotionMask 1 6 shift ; inline -: PointerMotionHintMask 1 7 shift ; inline -: Button1MotionMask 1 8 shift ; inline -: Button2MotionMask 1 9 shift ; inline -: Button3MotionMask 1 10 shift ; inline -: Button4MotionMask 1 11 shift ; inline -: Button5MotionMask 1 12 shift ; inline -: ButtonMotionMask 1 13 shift ; inline -: KeymapStateMask 1 14 shift ; inline -: ExposureMask 1 15 shift ; inline -: VisibilityChangeMask 1 16 shift ; inline -: StructureNotifyMask 1 17 shift ; inline -: ResizeRedirectMask 1 18 shift ; inline -: SubstructureNotifyMask 1 19 shift ; inline -: SubstructureRedirectMask 1 20 shift ; inline -: FocusChangeMask 1 21 shift ; inline -: PropertyChangeMask 1 22 shift ; inline -: ColormapChangeMask 1 23 shift ; inline -: OwnerGrabButtonMask 1 24 shift ; inline +: NoEventMask 0 ; inline +: KeyPressMask 1 0 shift ; inline +: KeyReleaseMask 1 1 shift ; inline +: ButtonPressMask 1 2 shift ; inline +: ButtonReleaseMask 1 3 shift ; inline +: EnterWindowMask 1 4 shift ; inline +: LeaveWindowMask 1 5 shift ; inline +: PointerMotionMask 1 6 shift ; inline +: PointerMotionHintMask 1 7 shift ; inline +: Button1MotionMask 1 8 shift ; inline +: Button2MotionMask 1 9 shift ; inline +: Button3MotionMask 1 10 shift ; inline +: Button4MotionMask 1 11 shift ; inline +: Button5MotionMask 1 12 shift ; inline +: ButtonMotionMask 1 13 shift ; inline +: KeymapStateMask 1 14 shift ; inline +: ExposureMask 1 15 shift ; inline +: VisibilityChangeMask 1 16 shift ; inline +: StructureNotifyMask 1 17 shift ; inline +: ResizeRedirectMask 1 18 shift ; inline +: SubstructureNotifyMask 1 19 shift ; inline +: SubstructureRedirectMask 1 20 shift ; inline +: FocusChangeMask 1 21 shift ; inline +: PropertyChangeMask 1 22 shift ; inline +: ColormapChangeMask 1 23 shift ; inline +: OwnerGrabButtonMask 1 24 shift ; inline -: KeyPress 2 ; inline -: KeyRelease 3 ; inline -: ButtonPress 4 ; inline -: ButtonRelease 5 ; inline -: MotionNotify 6 ; inline -: EnterNotify 7 ; inline -: LeaveNotify 8 ; inline -: FocusIn 9 ; inline -: FocusOut 10 ; inline -: KeymapNotify 11 ; inline -: Expose 12 ; inline -: GraphicsExpose 13 ; inline -: NoExpose 14 ; inline -: VisibilityNotify 15 ; inline -: CreateNotify 16 ; inline -: DestroyNotify 17 ; inline -: UnmapNotify 18 ; inline -: MapNotify 19 ; inline -: MapRequest 20 ; inline -: ReparentNotify 21 ; inline -: ConfigureNotify 22 ; inline -: ConfigureRequest 23 ; inline -: GravityNotify 24 ; inline -: ResizeRequest 25 ; inline -: CirculateNotify 26 ; inline -: CirculateRequest 27 ; inline -: PropertyNotify 28 ; inline -: SelectionClear 29 ; inline -: SelectionRequest 30 ; inline -: SelectionNotify 31 ; inline -: ColormapNotify 32 ; inline -: ClientMessage 33 ; inline -: MappingNotify 34 ; inline -: LASTEvent 35 ; inline +: KeyPress 2 ; inline +: KeyRelease 3 ; inline +: ButtonPress 4 ; inline +: ButtonRelease 5 ; inline +: MotionNotify 6 ; inline +: EnterNotify 7 ; inline +: LeaveNotify 8 ; inline +: FocusIn 9 ; inline +: FocusOut 10 ; inline +: KeymapNotify 11 ; inline +: Expose 12 ; inline +: GraphicsExpose 13 ; inline +: NoExpose 14 ; inline +: VisibilityNotify 15 ; inline +: CreateNotify 16 ; inline +: DestroyNotify 17 ; inline +: UnmapNotify 18 ; inline +: MapNotify 19 ; inline +: MapRequest 20 ; inline +: ReparentNotify 21 ; inline +: ConfigureNotify 22 ; inline +: ConfigureRequest 23 ; inline +: GravityNotify 24 ; inline +: ResizeRequest 25 ; inline +: CirculateNotify 26 ; inline +: CirculateRequest 27 ; inline +: PropertyNotify 28 ; inline +: SelectionClear 29 ; inline +: SelectionRequest 30 ; inline +: SelectionNotify 31 ; inline +: ColormapNotify 32 ; inline +: ClientMessage 33 ; inline +: MappingNotify 34 ; inline +: LASTEvent 35 ; inline C-STRUCT: XAnyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -524,37 +524,37 @@ C-STRUCT: XAnyEvent : Button4 4 ; inline : Button5 5 ; inline -: Button1Mask 1 8 shift ; inline -: Button2Mask 1 9 shift ; inline -: Button3Mask 1 10 shift ; inline -: Button4Mask 1 11 shift ; inline -: Button5Mask 1 12 shift ; inline +: Button1Mask 1 8 shift ; inline +: Button2Mask 1 9 shift ; inline +: Button3Mask 1 10 shift ; inline +: Button4Mask 1 11 shift ; inline +: Button5Mask 1 12 shift ; inline -: ShiftMask 1 0 shift ; inline -: LockMask 1 1 shift ; inline -: ControlMask 1 2 shift ; inline -: Mod1Mask 1 3 shift ; inline -: Mod2Mask 1 4 shift ; inline -: Mod3Mask 1 5 shift ; inline -: Mod4Mask 1 6 shift ; inline -: Mod5Mask 1 7 shift ; inline +: ShiftMask 1 0 shift ; inline +: LockMask 1 1 shift ; inline +: ControlMask 1 2 shift ; inline +: Mod1Mask 1 3 shift ; inline +: Mod2Mask 1 4 shift ; inline +: Mod3Mask 1 5 shift ; inline +: Mod4Mask 1 6 shift ; inline +: Mod5Mask 1 7 shift ; inline C-STRUCT: XButtonEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "uint" "button" } - { "Bool" "same_screen" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Window" "root" } + { "Window" "subwindow" } + { "Time" "time" } + { "int" "x" } + { "int" "y" } + { "int" "x_root" } + { "int" "y_root" } + { "uint" "state" } + { "uint" "button" } + { "Bool" "same_screen" } ; TYPEDEF: XButtonEvent XButtonPressedEvent TYPEDEF: XButtonEvent XButtonReleasedEvent @@ -563,21 +563,21 @@ TYPEDEF: XButtonEvent XButtonReleasedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XKeyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "uint" "keycode" } - { "Bool" "same_screen" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Window" "root" } + { "Window" "subwindow" } + { "Time" "time" } + { "int" "x" } + { "int" "y" } + { "int" "x_root" } + { "int" "y_root" } + { "uint" "state" } + { "uint" "keycode" } + { "Bool" "same_screen" } ; TYPEDEF: XKeyEvent XKeyPressedEvent TYPEDEF: XKeyEvent XKeyReleasedEvent @@ -585,44 +585,44 @@ TYPEDEF: XKeyEvent XKeyReleasedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XMotionEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "uint" "state" } - { "char" "is_hint" } - { "Bool" "same_screen" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Window" "root" } + { "Window" "subwindow" } + { "Time" "time" } + { "int" "x" } + { "int" "y" } + { "int" "x_root" } + { "int" "y_root" } + { "uint" "state" } + { "char" "is_hint" } + { "Bool" "same_screen" } ; TYPEDEF: XMotionEvent XPointerMovedEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XCrossingEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Window" "root" } - { "Window" "subwindow" } - { "Time" "time" } - { "int" "x" } - { "int" "y" } - { "int" "x_root" } - { "int" "y_root" } - { "int" "mode" } - { "int" "detail" } - { "Bool" "same_screen" } - { "Bool" "focus" } - { "uint" "state" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Window" "root" } + { "Window" "subwindow" } + { "Time" "time" } + { "int" "x" } + { "int" "y" } + { "int" "x_root" } + { "int" "y_root" } + { "int" "mode" } + { "int" "detail" } + { "Bool" "same_screen" } + { "Bool" "focus" } + { "uint" "state" } ; TYPEDEF: XCrossingEvent XEnterWindowEvent TYPEDEF: XCrossingEvent XLeaveWindowEvent @@ -630,13 +630,13 @@ TYPEDEF: XCrossingEvent XLeaveWindowEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XFocusChangeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "mode" } - { "int" "detail" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "int" "mode" } + { "int" "detail" } ; TYPEDEF: XFocusChangeEvent XFocusInEvent TYPEDEF: XFocusChangeEvent XFocusOutEvent @@ -644,363 +644,363 @@ TYPEDEF: XFocusChangeEvent XFocusOutEvent ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "count" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "count" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XGraphicsExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Drawable" "drawable" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "count" } - { "int" "major_code" } - { "int" "minor_code" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Drawable" "drawable" } + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "count" } + { "int" "major_code" } + { "int" "minor_code" } ; C-STRUCT: XNoExposeEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Drawable" "drawable" } - { "int" "major_code" } - { "int" "minor_code" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Drawable" "drawable" } + { "int" "major_code" } + { "int" "minor_code" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XVisibilityEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "state" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "int" "state" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XCreateWindowEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Bool" "override_redirect" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "parent" } + { "Window" "window" } + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "border_width" } + { "Bool" "override_redirect" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XDestroyWindowEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XUnmapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Bool" "from_configure" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "Bool" "from_configure" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XMapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Bool" "override_redirect" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "Bool" "override_redirect" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XMapRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "parent" } + { "Window" "window" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XReparentEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "Window" "parent" } - { "int" "x" } - { "int" "y" } - { "Bool" "override_redirect" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "Window" "parent" } + { "int" "x" } + { "int" "y" } + { "Bool" "override_redirect" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XConfigureEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "above" } - { "Bool" "override_redirect" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "border_width" } + { "Window" "above" } + { "Bool" "override_redirect" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XGravityEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "int" "x" } + { "int" "y" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XResizeRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "width" } - { "int" "height" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "int" "width" } + { "int" "height" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XConfigureRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "x" } - { "int" "y" } - { "int" "width" } - { "int" "height" } - { "int" "border_width" } - { "Window" "above" } - { "int" "detail" } - { "ulong" "value_mask" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "parent" } + { "Window" "window" } + { "int" "x" } + { "int" "y" } + { "int" "width" } + { "int" "height" } + { "int" "border_width" } + { "Window" "above" } + { "int" "detail" } + { "ulong" "value_mask" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XCirculateEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "event" } - { "Window" "window" } - { "int" "place" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "event" } + { "Window" "window" } + { "int" "place" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XCirculateRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "parent" } - { "Window" "window" } - { "int" "place" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "parent" } + { "Window" "window" } + { "int" "place" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XPropertyEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "atom" } - { "Time" "time" } - { "int" "state" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Atom" "atom" } + { "Time" "time" } + { "int" "state" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XSelectionClearEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "selection" } - { "Time" "time" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Atom" "selection" } + { "Time" "time" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XSelectionRequestEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "owner" } - { "Window" "requestor" } - { "Atom" "selection" } - { "Atom" "target" } - { "Atom" "property" } - { "Time" "time" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "owner" } + { "Window" "requestor" } + { "Atom" "selection" } + { "Atom" "target" } + { "Atom" "property" } + { "Time" "time" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XSelectionEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "requestor" } - { "Atom" "selection" } - { "Atom" "target" } - { "Atom" "property" } - { "Time" "time" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "requestor" } + { "Atom" "selection" } + { "Atom" "target" } + { "Atom" "property" } + { "Time" "time" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XColormapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Colormap" "colormap" } - { "Bool" "new" } - { "int" "state" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Colormap" "colormap" } + { "Bool" "new" } + { "int" "state" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XClientMessageEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "Atom" "message_type" } - { "int" "format" } - { "long" "data0" } - { "long" "data1" } - { "long" "data2" } - { "long" "data3" } - { "long" "data4" } + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "Atom" "message_type" } + { "int" "format" } + { "long" "data0" } + { "long" "data1" } + { "long" "data2" } + { "long" "data3" } + { "long" "data4" } ! union { -! char b[20]; -! short s[10]; -! long l[5]; -! } data; +! char b[20]; +! short s[10]; +! long l[5]; +! } data; ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XMappingEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - { "int" "request" } - { "int" "first_keycode" } - { "int" "count" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + { "int" "request" } + { "int" "first_keycode" } + { "int" "count" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XErrorEvent - { "int" "type" } - { "Display*" "display" } - { "XID" "resourceid" } - { "ulong" "serial" } - { "uchar" "error_code" } - { "uchar" "request_code" } - { "uchar" "minor_code" } ; + { "int" "type" } + { "Display*" "display" } + { "XID" "resourceid" } + { "ulong" "serial" } + { "uchar" "error_code" } + { "uchar" "request_code" } + { "uchar" "minor_code" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! C-STRUCT: XKeymapEvent - { "int" "type" } - { "ulong" "serial" } - { "Bool" "send_event" } - { "Display*" "display" } - { "Window" "window" } - ! char key_vector[32]; - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } - { "int" "pad" } ; + { "int" "type" } + { "ulong" "serial" } + { "Bool" "send_event" } + { "Display*" "display" } + { "Window" "window" } + ! char key_vector[32]; + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } + { "int" "pad" } ; C-UNION: XEvent - "int" - "XAnyEvent" - "XKeyEvent" - "XButtonEvent" - "XMotionEvent" - "XCrossingEvent" - "XFocusChangeEvent" - "XExposeEvent" - "XGraphicsExposeEvent" - "XNoExposeEvent" - "XVisibilityEvent" - "XCreateWindowEvent" - "XDestroyWindowEvent" - "XUnmapEvent" - "XMapEvent" - "XMapRequestEvent" - "XReparentEvent" - "XConfigureEvent" - "XGravityEvent" - "XResizeRequestEvent" - "XConfigureRequestEvent" - "XCirculateEvent" - "XCirculateRequestEvent" - "XPropertyEvent" - "XSelectionClearEvent" - "XSelectionRequestEvent" - "XSelectionEvent" - "XColormapEvent" - "XClientMessageEvent" - "XMappingEvent" - "XErrorEvent" - "XKeymapEvent" - { "long" 24 } ; + "int" + "XAnyEvent" + "XKeyEvent" + "XButtonEvent" + "XMotionEvent" + "XCrossingEvent" + "XFocusChangeEvent" + "XExposeEvent" + "XGraphicsExposeEvent" + "XNoExposeEvent" + "XVisibilityEvent" + "XCreateWindowEvent" + "XDestroyWindowEvent" + "XUnmapEvent" + "XMapEvent" + "XMapRequestEvent" + "XReparentEvent" + "XConfigureEvent" + "XGravityEvent" + "XResizeRequestEvent" + "XConfigureRequestEvent" + "XCirculateEvent" + "XCirculateRequestEvent" + "XPropertyEvent" + "XSelectionClearEvent" + "XSelectionRequestEvent" + "XSelectionEvent" + "XColormapEvent" + "XClientMessageEvent" + "XMappingEvent" + "XErrorEvent" + "XKeymapEvent" + { "long" 24 } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 11 - Event Handling Functions @@ -1052,8 +1052,8 @@ FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Windo FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ; FUNCTION: Status XGetInputFocus ( Display* display, - Window* focus_return, - int* revert_to_return ) ; + Window* focus_return, + int* revert_to_return ) ; FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ; @@ -1069,25 +1069,25 @@ FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop ! 14.1.1. Manipulating Top-Level Windows FUNCTION: Status XIconifyWindow ( - Display* display, Window w, int screen_number ) ; + Display* display, Window w, int screen_number ) ; FUNCTION: Status XWithdrawWindow ( - Display* display, Window w, int screen_number ) ; + Display* display, Window w, int screen_number ) ; ! 14.1.6 - Setting and Reading the WM_HINTS Property ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property -: USPosition 1 0 shift ; inline -: USSize 1 1 shift ; inline -: PPosition 1 2 shift ; inline -: PSize 1 3 shift ; inline -: PMinSize 1 4 shift ; inline -: PMaxSize 1 5 shift ; inline -: PResizeInc 1 6 shift ; inline -: PAspect 1 7 shift ; inline -: PBaseSize 1 8 shift ; inline -: PWinGravity 1 9 shift ; inline +: USPosition 1 0 shift ; inline +: USSize 1 1 shift ; inline +: PPosition 1 2 shift ; inline +: PSize 1 3 shift ; inline +: PMinSize 1 4 shift ; inline +: PMaxSize 1 5 shift ; inline +: PResizeInc 1 6 shift ; inline +: PAspect 1 7 shift ; inline +: PBaseSize 1 8 shift ; inline +: PWinGravity 1 9 shift ; inline : PAllHints [ PPosition PSize PMinSize PMaxSize PResizeInc PAspect ] 0 [ execute bitor ] reduce ; inline @@ -1114,13 +1114,13 @@ C-STRUCT: XSizeHints ! 14.1.10. Setting and Reading the WM_PROTOCOLS Property FUNCTION: Status XSetWMProtocols ( - Display* display, Window w, Atom* protocols, int count ) ; + Display* display, Window w, Atom* protocols, int count ) ; FUNCTION: Status XGetWMProtocols ( - Display* display, - Window w, - Atom** protocols_return, - int* count_return ) ; + Display* display, + Window w, + Atom** protocols_return, + int* count_return ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! 16 - Application Utility Functions @@ -1131,51 +1131,51 @@ FUNCTION: Status XGetWMProtocols ( FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ; FUNCTION: int XLookupString ( - XKeyEvent* event_struct, - void* buffer_return, - int bytes_buffer, - KeySym* keysym_return, - XComposeStatus* status_in_out ) ; + XKeyEvent* event_struct, + void* buffer_return, + int bytes_buffer, + KeySym* keysym_return, + XComposeStatus* status_in_out ) ; ! 16.7 Determining the Appropriate Visual Type -: VisualNoMask HEX: 0 ; inline -: VisualIDMask HEX: 1 ; inline -: VisualScreenMask HEX: 2 ; inline -: VisualDepthMask HEX: 4 ; inline -: VisualClassMask HEX: 8 ; inline -: VisualRedMaskMask HEX: 10 ; inline -: VisualGreenMaskMask HEX: 20 ; inline -: VisualBlueMaskMask HEX: 40 ; inline -: VisualColormapSizeMask HEX: 80 ; inline -: VisualBitsPerRGBMask HEX: 100 ; inline -: VisualAllMask HEX: 1FF ; inline +: VisualNoMask HEX: 0 ; inline +: VisualIDMask HEX: 1 ; inline +: VisualScreenMask HEX: 2 ; inline +: VisualDepthMask HEX: 4 ; inline +: VisualClassMask HEX: 8 ; inline +: VisualRedMaskMask HEX: 10 ; inline +: VisualGreenMaskMask HEX: 20 ; inline +: VisualBlueMaskMask HEX: 40 ; inline +: VisualColormapSizeMask HEX: 80 ; inline +: VisualBitsPerRGBMask HEX: 100 ; inline +: VisualAllMask HEX: 1FF ; inline C-STRUCT: XVisualInfo - { "Visual*" "visual" } - { "VisualID" "visualid" } - { "int" "screen" } - { "uint" "depth" } - { "int" "class" } - { "ulong" "red_mask" } - { "ulong" "green_mask" } - { "ulong" "blue_mask" } - { "int" "colormap_size" } - { "int" "bits_per_rgb" } ; + { "Visual*" "visual" } + { "VisualID" "visualid" } + { "int" "screen" } + { "uint" "depth" } + { "int" "class" } + { "ulong" "red_mask" } + { "ulong" "green_mask" } + { "ulong" "blue_mask" } + { "int" "colormap_size" } + { "int" "bits_per_rgb" } ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Appendix D - Compatibility Functions ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! FUNCTION: Status XSetStandardProperties ( - Display* display, - Window w, - char* window_name, - char* icon_name, - Pixmap icon_pixmap, - char** argv, - int argc, - XSizeHints* hints ) ; + Display* display, + Window w, + char* window_name, + char* icon_name, + Pixmap icon_pixmap, + char** argv, + int argc, + XSizeHints* hints ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From a11481908800c486df4ab1db9afb8a945118c8fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 00:30:36 -0600 Subject: [PATCH 084/317] Fix UI listener bug with EOF --- extra/ui/tools/interactor/interactor.factor | 9 +++++---- extra/ui/tools/listener/listener.factor | 4 ++-- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index ae1b61f06c..e667b1206b 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -3,9 +3,10 @@ USING: arrays assocs combinators continuations documents ui.tools.workspace hashtables io io.styles kernel math math.vectors models namespaces parser prettyprint quotations -sequences strings threads listener tuples ui.commands ui.gadgets -ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds -ui.gestures definitions ; +sequences sequences.lib strings threads listener tuples +ui.commands ui.gadgets ui.gadgets.editors +ui.gadgets.presentations ui.gadgets.worlds ui.gestures +definitions ; IN: ui.tools.interactor TUPLE: interactor @@ -97,7 +98,7 @@ M: interactor model-changed [ set-interactor-continuation stop ] curry callcc1 ; M: interactor stream-readln - [ interactor-yield ] keep interactor-finish first ; + [ interactor-yield ] keep interactor-finish ?first ; : interactor-call ( quot interactor -- ) dup interactor-busy? [ diff --git a/extra/ui/tools/listener/listener.factor b/extra/ui/tools/listener/listener.factor index f96fdf8875..3a3ba5f1af 100755 --- a/extra/ui/tools/listener/listener.factor +++ b/extra/ui/tools/listener/listener.factor @@ -77,7 +77,7 @@ M: listener-operation invoke-command ( target command -- ) [ [ run-file ] each ] curry call-listener ] if ; -: com-EOF ( listener -- ) +: com-end ( listener -- ) listener-gadget-input interactor-eof ; : clear-output ( listener -- ) @@ -154,7 +154,7 @@ listener-gadget "toolbar" f { { f restart-listener } { T{ key-down f f "CLEAR" } clear-output } { T{ key-down f { C+ } "CLEAR" } clear-stack } - { T{ key-down f { C+ } "d" } com-EOF } + { T{ key-down f { C+ } "d" } com-end } { T{ key-down f f "F1" } listener-help } } define-command-map From 4d24978507bac597e9de65d1e1434f8d4bd12503 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 00:30:47 -0600 Subject: [PATCH 085/317] Fix IO timeouts --- extra/io/unix/backend/backend.factor | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 141b115ebe..1b66c0332e 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -104,8 +104,21 @@ M: integer close-handle ( fd -- ) : handle-io-task ( mx task -- ) dup do-io-task [ pop-callbacks ] [ 2drop ] if ; -: handle-timeout ( mx task -- ) - "Timeout" over io-task-port report-error pop-callbacks ; +: handle-timeout ( port mx assoc -- ) + >r swap port-handle r> delete-at* [ + "I/O operation cancelled" over io-task-port report-error + pop-callbacks + ] [ + 2drop + ] if ; + +: cancel-io-tasks ( port mx -- ) + 2dup + dup mx-reads handle-timeout + dup mx-writes handle-timeout ; + +M: unix-io cancel-io ( port -- ) + mx get-global cancel-io-tasks ; ! Readers : reader-eof ( reader -- ) @@ -165,7 +178,7 @@ M: port port-flush ( port -- ) dup buffer-empty? [ drop ] [ (wait-to-write) ] if ; M: unix-io io-multiplex ( ms -- ) - mx get-global wait-for-events ; + expire-timeouts mx get-global wait-for-events ; M: unix-io init-stdio ( -- ) 0 1 handle>duplex-stream io:stdio set-global From 16e206b3b8dccdeda5fb29fb155ab9ecd6e53766 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sat, 2 Feb 2008 06:58:28 -0600 Subject: [PATCH 086/317] Add flags to math.bitfields --- core/inference/transforms/transforms.factor | 2 ++ core/math/bitfields/bitfields.factor | 5 ++++- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index fd15b7da98..ad2bacc789 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,6 +54,8 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform +\ flags [ flags [ ] curry ] 1 define-transform + ! Tuple operations : [get-slots] ( slots -- quot ) [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ; diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index f6a3419784..29c3329f3d 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math sequences words ; IN: math.bitfields @@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum ) : bitfield ( values... bitspec -- n ) 0 [ (bitfield) ] reduce ; + +: flags ( values -- n ) + 0 [ execute bitor ] reduce ; From b22a40f90602b6ac9461a49c3782aa0249512c7a Mon Sep 17 00:00:00 2001 From: sheeple Date: Sat, 2 Feb 2008 07:02:32 -0600 Subject: [PATCH 087/317] inotify bindings --- extra/unix/linux/inotify/inotify.factor | 50 +++++++++++++++++++++++++ vm/os-linux.c | 15 ++++++++ vm/os-linux.h | 4 ++ 3 files changed, 69 insertions(+) create mode 100644 extra/unix/linux/inotify/inotify.factor diff --git a/extra/unix/linux/inotify/inotify.factor b/extra/unix/linux/inotify/inotify.factor new file mode 100644 index 0000000000..14840b380a --- /dev/null +++ b/extra/unix/linux/inotify/inotify.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax ; +IN: unix.linux.inotify + +C-STRUCT: inotify-event + { "int" "wd" } ! watch descriptor + { "uint" "mask" } ! watch mask + { "uint" "cookie" } ! cookie to synchronize two events + { "uint" "len" } ! length (including nulls) of name + { "char[1]" "name" } ! stub for possible name + ; + +: IN_ACCESS HEX: 1 ; inline ! File was accessed +: IN_MODIFY HEX: 2 ; inline ! File was modified +: IN_ATTRIB HEX: 4 ; inline ! Metadata changed +: IN_CLOSE_WRITE HEX: 8 ; inline ! Writtable file was closed +: IN_CLOSE_NOWRITE HEX: 10 ; inline ! Unwrittable file closed +: IN_OPEN HEX: 20 ; inline ! File was opened +: IN_MOVED_FROM HEX: 40 ; inline ! File was moved from X +: IN_MOVED_TO HEX: 80 ; inline ! File was moved to Y +: IN_CREATE HEX: 100 ; inline ! Subfile was created +: IN_DELETE HEX: 200 ; inline ! Subfile was deleted +: IN_DELETE_SELF HEX: 400 ; inline ! Self was deleted +: IN_MOVE_SELF HEX: 800 ; inline ! Self was moved + +: IN_UNMOUNT HEX: 2000 ; inline ! Backing fs was unmounted +: IN_Q_OVERFLOW HEX: 4000 ; inline ! Event queued overflowed +: IN_IGNORED HEX: 8000 ; inline ! File was ignored + +: IN_CLOSE IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close +: IN_MOVE IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves + +: IN_ONLYDIR HEX: 1000000 ; inline ! only watch the path if it is a directory +: IN_DONT_FOLLOW HEX: 2000000 ; inline ! don't follow a sym link +: IN_MASK_ADD HEX: 20000000 ; inline ! add to the mask of an already existing watch +: IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir +: IN_ONESHOT HEX: 80000000 ; inline ! only send event once + +: IN_ALL_EVENTS + { + IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE + IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } flags ; foldable + +FUNCTION: int inotify_init ( void ) ; +FUNCTION: int inotify_add_watch ( int fd, char* name, u32 mask ) ; +FUNCTION: int inotify_rm_watch ( int fd, u32 wd ) ; diff --git a/vm/os-linux.c b/vm/os-linux.c index 8f3f8408f3..935add6714 100644 --- a/vm/os-linux.c +++ b/vm/os-linux.c @@ -17,3 +17,18 @@ const char *vm_executable_path(void) return safe_strdup(path); } } + +int inotify_init(void) +{ + return syscall(SYS_inotify_init); +} + +int inotify_add_watch(int fd, const char *name, u32 mask) +{ + return syscall(SYS_inotify_add_watch, fd, name, mask); +} + +int inotify_rm_watch(int fd, u32 wd) +{ + return syscall(SYS_inotify_rm_watch, fd, wd); +} diff --git a/vm/os-linux.h b/vm/os-linux.h index 21e34c98f8..2b5371ff1b 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -4,3 +4,7 @@ #ifndef environ extern char **environ; #endif + +int inotify_init(void); +int inotify_add_watch(int fd, const char *name, u32 mask); +int inotify_rm_watch(int fd, u32 wd); From a05c18152b59073c49aa313ba685516310ec74a8 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sat, 2 Feb 2008 07:05:15 -0600 Subject: [PATCH 088/317] flags now works with numbers --- core/math/bitfields/bitfields.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index 29c3329f3d..77cc40180e 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -15,4 +15,4 @@ M: pair (bitfield) ( value accum pair -- newaccum ) 0 [ (bitfield) ] reduce ; : flags ( values -- n ) - 0 [ execute bitor ] reduce ; + 0 [ dup word? [ execute ] when bitor ] reduce ; From ff4051316513f0eb56a07051887491067ed89802 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 16:23:04 -0600 Subject: [PATCH 089/317] Cleaning up monitors in preparation for Linux inotify --- extra/io/monitor/monitor.factor | 32 ++++++++++++++- extra/io/unix/backend/backend.factor | 8 ++-- extra/io/windows/nt/monitor/monitor.factor | 48 +++++++++------------- 3 files changed, 53 insertions(+), 35 deletions(-) diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 4dc5081513..fe33045e01 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -1,11 +1,39 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend kernel continuations ; +USING: io.backend kernel continuations namespaces sequences +assocs hashtables sorting arrays ; IN: io.monitor +array ; + +PRIVATE> + HOOK: io-backend ( path recursive? -- monitor ) -HOOK: next-change io-backend ( monitor -- path changes ) +: next-change ( monitor -- path changed ) + dup check-monitor + dup monitor-queue dup assoc-empty? [ + drop dup fill-queue over set-monitor-queue next-change + ] [ nip dequeue-change ] if ; SYMBOL: +add-file+ SYMBOL: +remove-file+ diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 1b66c0332e..7112c48551 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,9 +14,9 @@ TUPLE: io-task port callbacks ; : io-task-fd io-task-port port-handle ; -: ( port continuation class -- task ) - >r 1vector io-task construct-boa r> construct-delegate ; - inline +: ( port continuation/f class -- task ) + >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa + r> construct-delegate ; inline TUPLE: input-task ; @@ -194,7 +194,7 @@ TUPLE: mx-port mx ; TUPLE: mx-task ; : ( port -- task ) - f io-task construct-boa mx-task construct-delegate ; + f mx-task ; M: mx-task do-io-task io-task-port mx-port-mx 0 swap wait-for-events f ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index 8e0e63923d..1be91263c4 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -3,12 +3,10 @@ USING: alien.c-types destructors io.windows io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations -io.monitor io.nonblocking io.buffers io.files io sequences -hashtables sorting arrays combinators ; +io.monitor io.monitor.private io.nonblocking io.buffers io.files +io sequences hashtables sorting arrays combinators ; IN: io.windows.nt.monitor -TUPLE: monitor path recursive? queue closed? ; - : open-directory ( path -- handle ) FILE_LIST_DIRECTORY share-mode @@ -22,23 +20,26 @@ TUPLE: monitor path recursive? queue closed? ; dup add-completion f ; +TUPLE: win32-monitor path recursive? ; + +: ( path recursive? port -- monitor ) + (monitor) { + set-win32-monitor-path + set-win32-monitor-recursive? + set-delegate + } win32-monitor construct ; + M: windows-nt-io ( path recursive? -- monitor ) [ - >r dup open-directory monitor r> { - set-monitor-path - set-delegate - set-monitor-recursive? - } monitor construct + over open-directory win32-monitor + ] with-destructors ; -: check-closed ( monitor -- ) - port-type closed eq? [ "Monitor closed" throw ] when ; - : begin-reading-changes ( monitor -- overlapped ) dup port-handle win32-file-handle over buffer-ptr pick buffer-size - roll monitor-recursive? 1 0 ? + roll win32-monitor-recursive? 1 0 ? FILE_NOTIFY_CHANGE_ALL 0 (make-overlapped) @@ -49,6 +50,7 @@ M: windows-nt-io ( path recursive? -- monitor ) [ dup begin-reading-changes swap [ save-callback ] 2keep + dup check-monitor ! we may have closed it... get-overlapped-result ] with-port-timeout ] with-destructors ; @@ -63,7 +65,7 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; -: changed-file ( directory buffer -- changed path ) +: parse-file-notify ( directory buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength @@ -71,22 +73,10 @@ M: windows-nt-io ( path recursive? -- monitor ) } get-slots >r memory>u16-string path+ r> parse-action swap ; : (changed-files) ( directory buffer -- ) - 2dup changed-file namespace [ swap add ] change-at + 2dup parse-file-notify changed-file dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 3drop ] [ swap (changed-files) ] if ; -: changed-files ( directory buffer len -- assoc ) +M: windows-nt-io fill-queue ( monitor -- assoc ) + dup win32-monitor-path over buffer-ptr rot read-changes [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ; - -: fill-queue ( monitor -- ) - dup monitor-path over buffer-ptr pick read-changes - changed-files - swap set-monitor-queue ; - -M: windows-nt-io next-change ( monitor -- path changes ) - dup check-closed - dup monitor-queue dup assoc-empty? [ - drop dup fill-queue next-change - ] [ - nip delete-any prune natural-sort >array - ] if ; From ff46bfaa9610a95299a3afb0bac745c9825f7852 Mon Sep 17 00:00:00 2001 From: sheeple Date: Sat, 2 Feb 2008 11:51:16 -0600 Subject: [PATCH 090/317] Linux inotify support work in progress --- extra/io/unix/linux/linux.factor | 127 +++++++++++++++++++++++- extra/unix/linux/inotify/inotify.factor | 17 +++- vm/os-linux.h | 2 + 3 files changed, 138 insertions(+), 8 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 6d55decb5a..01d6159e45 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,15 +1,136 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.backend io.monitor io.monitor.private io.files +io.buffers io.nonblocking io.unix.backend io.unix.select +io.unix.launcher unix.linux.inotify assocs namespaces threads +continuations init math alien.c-types alien ; IN: io.unix.linux -USING: io.backend io.unix.backend io.unix.launcher io.unix.select -namespaces kernel assocs unix.process init ; TUPLE: linux-io ; INSTANCE: linux-io unix-io +TUPLE: linux-monitor path wd callback ; + +: ( path wd -- monitor ) + f (monitor) { + set-linux-monitor-path + set-linux-monitor-wd + set-delegate + } linux-monitor construct ; + +TUPLE: inotify watches ; + +: wd>path ( wd -- path ) + inotify get-global inotify-watches at linux-monitor-path ; + +: ( -- port ) + H{ } clone + inotify_init dup io-error inotify + { set-inotify-watches set-delegate } inotify construct ; + +: inotify-fd inotify get-global port-handle ; + +: watches inotify get-global inotify-watches ; + +: (add-watch) ( path mask -- wd ) + inotify-fd -rot inotify_add_watch dup io-error ; + +: check-existing ( wd -- ) + watches key? [ + "Cannot open multiple monitors for the same file" throw + ] when ; + +: add-watch ( path mask -- monitor ) + dupd (add-watch) + dup check-existing + [ dup ] keep watches set-at ; + +: remove-watch ( monitor -- ) + dup linux-monitor-wd watches delete-at + linux-monitor-wd inotify-fd swap inotify_rm_watch io-error ; + +M: linux-io ( path recursive? -- monitor ) + drop IN_CHANGE_EVENTS add-watch ; + +: notify-callback ( assoc monitor -- ) + linux-monitor-callback dup + [ schedule-thread-with ] [ 2drop ] if ; + +M: linux-io fill-queue ( monitor -- assoc ) + dup linux-monitor-callback [ + "Cannot wait for changes on the same file from multiple threads" throw + ] when + [ swap set-linux-monitor-callback stop ] callcc1 + swap check-monitor ; + +M: linux-monitor dispose ( monitor -- ) + dup check-monitor + t over set-monitor-closed? + H{ } over notify-callback + remove-watch ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; + +: parse-action ( mask -- changed ) + [ + IN_CREATE +add-file+ ?flag + IN_DELETE +remove-file+ ?flag + IN_DELETE_SELF +remove-file+ ?flag + IN_MODIFY +modify-file+ ?flag + IN_ATTRIB +modify-file+ ?flag + IN_MOVED_FROM +rename-file+ ?flag + IN_MOVED_TO +rename-file+ ?flag + IN_MOVE_SELF +rename-file+ ?flag + drop + ] { } make ; + +: parse-file-notify ( buffer -- changed path ) + { + inotify-event-wd + inotify-event-name + inotify-event-mask + } get-slots + parse-action -rot alien>char-string >r wd>path r> path+ ; + +: events-exhausted? ( i buffer -- ? ) + buffer-fill >= ; + +: inotify-event@ ( i buffer -- alien ) + buffer-ptr ; + +: next-event ( i buffer -- i buffer ) + 2dup inotify-event@ + inotify-event-len "inotify-event" heap-size + + swap >r + r> ; + +: parse-file-notifications ( i buffer -- ) + 2dup events-exhausted? [ 2drop ] [ + 2dup inotify-event@ parse-file-notify changed-file + next-event parse-file-notifications + ] if ; + +: read-notifications ( port -- ) + dup refill drop + 0 over parse-file-notifications + 0 swap buffer-reset ; + +TUPLE: inotify-task ; + +: ( port -- task ) + f inotify-task ; + +: init-inotify ( mx -- ) + + dup inotify set-global + swap register-io-task ; + +M: inotify-task do-io-task ( task -- ) + io-task-port read-notifications f ; + M: linux-io init-io ( -- ) - mx set-global ; + mx set-global ; ! init-inotify ; T{ linux-io } set-io-backend diff --git a/extra/unix/linux/inotify/inotify.factor b/extra/unix/linux/inotify/inotify.factor index 14840b380a..b7b721efc7 100644 --- a/extra/unix/linux/inotify/inotify.factor +++ b/extra/unix/linux/inotify/inotify.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax math math.bitfields ; IN: unix.linux.inotify C-STRUCT: inotify-event @@ -8,7 +8,7 @@ C-STRUCT: inotify-event { "uint" "mask" } ! watch mask { "uint" "cookie" } ! cookie to synchronize two events { "uint" "len" } ! length (including nulls) of name - { "char[1]" "name" } ! stub for possible name + { "char[0]" "name" } ! stub for possible name ; : IN_ACCESS HEX: 1 ; inline ! File was accessed @@ -37,6 +37,13 @@ C-STRUCT: inotify-event : IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir : IN_ONESHOT HEX: 80000000 ; inline ! only send event once +: IN_CHANGE_EVENTS + { + IN_MODIFY IN_ATTRIB IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } flags ; foldable + : IN_ALL_EVENTS { IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE @@ -45,6 +52,6 @@ C-STRUCT: inotify-event IN_MOVE_SELF } flags ; foldable -FUNCTION: int inotify_init ( void ) ; -FUNCTION: int inotify_add_watch ( int fd, char* name, u32 mask ) ; -FUNCTION: int inotify_rm_watch ( int fd, u32 wd ) ; +FUNCTION: int inotify_init ( ) ; +FUNCTION: int inotify_add_watch ( int fd, char* name, uint mask ) ; +FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ; diff --git a/vm/os-linux.h b/vm/os-linux.h index 2b5371ff1b..1a1e088359 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -1,3 +1,5 @@ +#include + #define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) From d2079c50fbfb4abf172271430e748405a3861a17 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 2 Feb 2008 12:23:51 -0600 Subject: [PATCH 091/317] Fixing stupid splay trees bug --- extra/trees/splay/splay.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/trees/splay/splay.factor b/extra/trees/splay/splay.factor index 4fe6fe79a5..2fca5eca95 100644 --- a/extra/trees/splay/splay.factor +++ b/extra/trees/splay/splay.factor @@ -7,7 +7,7 @@ IN: trees.splay TUPLE: splay ; : ( -- splay-tree ) - splay construct-tree ; + \ splay construct-tree ; INSTANCE: splay tree-mixin From a0dad18f4f96ffc0a93a07f90a7c42453c5e6ebb Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 13:37:53 -0500 Subject: [PATCH 092/317] Solution to Project Euler problem 39 --- extra/project-euler/039/039.factor | 76 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 8 +-- 2 files changed, 80 insertions(+), 4 deletions(-) create mode 100644 extra/project-euler/039/039.factor diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor new file mode 100644 index 0000000000..4df7ba610a --- /dev/null +++ b/extra/project-euler/039/039.factor @@ -0,0 +1,76 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.matrices math.ranges namespaces + sequences ; +IN: project-euler.039 + +! http://projecteuler.net/index.php?section=problems&id=39 + +! DESCRIPTION +! ----------- + +! If p is the perimeter of a right angle triangle with integral length sides, +! {a,b,c}, there are exactly three solutions for p = 120. + +! {20,48,52}, {24,45,51}, {30,40,50} + +! For which value of p < 1000, is the number of solutions maximised? + + +! SOLUTION +! -------- + +! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html + +! Basically, this makes an array of 1000 zeros, recursively creates primitive +! triples using the three transforms and then increments the array at index +! [a+b+c] by one for each triple's sum AND its multiples under 1000 (to account +! for non-primitive triples). The answer is just the index that has the highest +! number. + +SYMBOL: p-count + + p-count get + [ [ 1+ ] change-nth ] curry each ; + +: transform ( triple matrix -- new-triple ) + [ 1array ] dip m. first ; + +: u-transform ( triple -- new-triple ) + { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ; + +: a-transform ( triple -- new-triple ) + { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ; + +: d-transform ( triple -- new-triple ) + { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ; + +: (count-perimeters) ( seq -- ) + dup sum max-p < [ + dup sum adjust-p-count + [ u-transform ] keep [ a-transform ] keep d-transform + [ (count-perimeters) ] 3apply + ] [ + drop + ] if ; + +: count-perimeters ( n -- ) + 0 p-count set { 3 4 5 } (count-perimeters) ; + +PRIVATE> + +: euler039 ( -- answer ) + [ + 1000 count-perimeters p-count get [ supremum ] keep index + ] with-scope ; + +! [ euler039 ] 100 ave-time +! 2 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler039 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 0037e4462f..86dff7a192 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files kernel math.parser sequences vocabs - vocabs.loader project-euler.ave-time project-euler.common math +USING: definitions io io.files kernel math math.parser project-euler.ave-time + sequences vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 @@ -11,8 +11,8 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.037 project-euler.038 project-euler.067 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.037 project-euler.038 project-euler.039 project-euler.067 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sat, 2 Feb 2008 13:09:23 -0600 Subject: [PATCH 093/317] Removed obsolete vocabs --- extra/macros/zoo/authors.txt | 1 - extra/macros/zoo/zoo.factor | 38 ----------------------------------- extra/strings/lib/authors.txt | 1 - extra/strings/lib/lib.factor | 14 ------------- extra/strings/lib/tags.txt | 1 - 5 files changed, 55 deletions(-) delete mode 100755 extra/macros/zoo/authors.txt delete mode 100644 extra/macros/zoo/zoo.factor delete mode 100755 extra/strings/lib/authors.txt delete mode 100644 extra/strings/lib/lib.factor delete mode 100644 extra/strings/lib/tags.txt diff --git a/extra/macros/zoo/authors.txt b/extra/macros/zoo/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/macros/zoo/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/macros/zoo/zoo.factor b/extra/macros/zoo/zoo.factor deleted file mode 100644 index 21edc39f19..0000000000 --- a/extra/macros/zoo/zoo.factor +++ /dev/null @@ -1,38 +0,0 @@ - -USING: kernel quotations arrays sequences sequences.private macros ; - -IN: macros.zoo - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! MACRO: narray ( n -- quot ) -! dup [ f ] curry -! swap [ -! [ swap [ set-nth-unsafe ] keep ] curry -! ] map concat append ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! MACRO: map-call-with ( quots -- ) -! [ [ [ keep ] curry ] map concat ] keep length [ nip narray ] curry compose ; - -! MACRO: map-call-with2 ( quots -- ) -! dup >r -! [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat -! [ 2drop ] append -! r> length [ narray ] curry append ; - -! MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Conceptual implementation: - -! : pcall ( seq quots -- seq ) [ call ] 2map ; - -! MACRO: pcall ( quots -- ) -! [ [ unclip ] swap append ] map -! [ [ r> swap add >r ] append ] map -! concat -! [ { } >r ] swap append ! pre -! [ drop r> ] append ; ! post diff --git a/extra/strings/lib/authors.txt b/extra/strings/lib/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/strings/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor deleted file mode 100644 index 223fdb2090..0000000000 --- a/extra/strings/lib/lib.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: math arrays sequences kernel splitting strings ; -IN: strings.lib - -: char>digit ( c -- i ) 48 - ; - -: string>digits ( s -- seq ) [ char>digit ] { } map-as ; - -: >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string swap append - ] unless ; - -: >Upper-dashes ( str -- str ) - "-" split [ >Upper ] map "-" join ; diff --git a/extra/strings/lib/tags.txt b/extra/strings/lib/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/extra/strings/lib/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections From 8575bc62e3e8c1575e000b44aa07f1fe7ed45f45 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 13:29:09 -0600 Subject: [PATCH 094/317] Updating extra/ to use flags --- extra/cocoa/windows/windows.factor | 10 +++++--- extra/io/unix/files/files.factor | 4 +-- extra/io/windows/windows.factor | 7 ++++-- extra/ui/windows/windows.factor | 4 +-- extra/unix/linux/ifreq/ifreq.factor | 8 +----- extra/windows/advapi32/advapi32.factor | 34 +++++++++++++++----------- extra/windows/opengl32/opengl32.factor | 2 +- extra/windows/user32/user32.factor | 18 ++++++++++---- extra/windows/winsock/winsock.factor | 2 +- extra/x/widgets/wm/frame/frame.factor | 18 ++++++++------ extra/x11/windows/windows.factor | 27 ++++++++++---------- extra/x11/xim/xim.factor | 0 extra/x11/xlib/xlib.factor | 4 +-- 13 files changed, 77 insertions(+), 61 deletions(-) mode change 100644 => 100755 extra/cocoa/windows/windows.factor mode change 100644 => 100755 extra/unix/linux/ifreq/ifreq.factor mode change 100644 => 100755 extra/windows/advapi32/advapi32.factor mode change 100644 => 100755 extra/windows/user32/user32.factor mode change 100644 => 100755 extra/x/widgets/wm/frame/frame.factor mode change 100644 => 100755 extra/x11/windows/windows.factor mode change 100644 => 100755 extra/x11/xim/xim.factor mode change 100644 => 100755 extra/x11/xlib/xlib.factor diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor old mode 100644 new mode 100755 index f1c66f5e58..caf5f713b7 --- a/extra/cocoa/windows/windows.factor +++ b/extra/cocoa/windows/windows.factor @@ -15,10 +15,12 @@ IN: cocoa.windows : NSBackingStoreBuffered 2 ; inline : standard-window-type - NSTitledWindowMask - NSClosableWindowMask bitor - NSMiniaturizableWindowMask bitor - NSResizableWindowMask bitor ; inline + { + NSTitledWindowMask + NSClosableWindowMask + NSMiniaturizableWindowMask + NSResizableWindowMask + } flags ; inline : ( rect -- window ) NSWindow -> alloc swap diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index b56e62d3c4..8b32b19e1b 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -12,7 +12,7 @@ IN: io.unix.files M: unix-io ( path -- stream ) open-read ; -: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline +: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : open-write ( path -- fd ) write-flags file-mode open dup io-error ; @@ -20,7 +20,7 @@ M: unix-io ( path -- stream ) M: unix-io ( path -- stream ) open-write ; -: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline +: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) append-flags file-mode open dup io-error diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 419864b624..3cf40fedf7 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -31,8 +31,11 @@ M: windows-io normalize-directory ( string -- string ) "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) - FILE_SHARE_READ FILE_SHARE_WRITE bitor - FILE_SHARE_DELETE bitor ; foldable + { + FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE + } flags ; foldable : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index c3ef328b29..3ee339209c 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -370,7 +370,7 @@ M: windows-ui-backend (close-window) class-name-ptr get-global pick GetClassInfoEx zero? [ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize - CS_HREDRAW CS_VREDRAW bitor CS_OWNDC bitor over set-WNDCLASSEX-style + { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style ui-wndproc over set-WNDCLASSEX-lpfnWndProc 0 over set-WNDCLASSEX-cbClsExtra 0 over set-WNDCLASSEX-cbWndExtra @@ -387,7 +387,7 @@ M: windows-ui-backend (close-window) make-adjusted-RECT >r class-name-ptr get-global f r> >r >r >r ex-style r> r> - WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor + { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags CW_USEDEFAULT dup r> get-RECT-dimensions f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ; diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor old mode 100644 new mode 100755 index c75ee9a5e4..31adc5c237 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -58,10 +58,4 @@ IN: unix.linux.ifreq rot string>char-alien over set-struct-ifreq-ifr-ifrn swap over set-struct-ifreq-ifr-ifru - AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: words quotations sequences math macros ; - -MACRO: flags ( seq -- ) 0 swap [ execute bitor ] each 1quotation ; \ No newline at end of file + AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ; \ No newline at end of file diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor old mode 100644 new mode 100755 index a749fcb52b..e755d4707f --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -483,20 +483,26 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, : TOKEN_QUERY_SOURCE HEX: 0010 ; inline : TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline : TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; -: TOKEN_WRITE STANDARD_RIGHTS_WRITE - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable -: TOKEN_ALL_ACCESS STANDARD_RIGHTS_REQUIRED - TOKEN_ASSIGN_PRIMARY bitor - TOKEN_DUPLICATE bitor - TOKEN_IMPERSONATE bitor - TOKEN_QUERY bitor - TOKEN_QUERY_SOURCE bitor - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_SESSIONID bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable +: TOKEN_WRITE + { + STANDARD_RIGHTS_WRITE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_DEFAULT + } flags ; foldable +: TOKEN_ALL_ACCESS + { + STANDARD_RIGHTS_REQUIRED + TOKEN_ASSIGN_PRIMARY + TOKEN_DUPLICATE + TOKEN_IMPERSONATE + TOKEN_QUERY + TOKEN_QUERY_SOURCE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_SESSIONID + TOKEN_ADJUST_DEFAULT + } flags ; foldable FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor index a8d8ad8153..e4254d779b 100755 --- a/extra/windows/opengl32/opengl32.factor +++ b/extra/windows/opengl32/opengl32.factor @@ -73,7 +73,7 @@ IN: windows.opengl32 : pfd-dwFlags - PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL bitor PFD_DOUBLEBUFFER bitor ; + { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; ! TODO: compare to http://www.nullterminator.net/opengl32.html : make-pfd ( bits -- pfd ) diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor old mode 100644 new mode 100755 index c8f6a82fb5..18d1956bda --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -32,9 +32,18 @@ IN: windows.user32 : WS_MAXIMIZEBOX HEX: 00010000 ; inline ! Common window styles -: WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ; foldable inline +: WS_OVERLAPPEDWINDOW + { + WS_OVERLAPPED + WS_CAPTION + WS_SYSMENU + WS_THICKFRAME + WS_MINIMIZEBOX + WS_MAXIMIZEBOX + } flags ; foldable -: WS_POPUPWINDOW WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ; foldable inline +: WS_POPUPWINDOW + { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable : WS_CHILDWINDOW WS_CHILD ; inline @@ -66,10 +75,9 @@ IN: windows.user32 : WS_EX_STATICEDGE HEX: 00020000 ; inline : WS_EX_APPWINDOW HEX: 00040000 ; inline : WS_EX_OVERLAPPEDWINDOW ( -- n ) - WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable inline + WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable : WS_EX_PALETTEWINDOW ( -- n ) - WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor - WS_EX_TOPMOST bitor ; foldable inline + { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable : CS_VREDRAW HEX: 0001 ; inline : CS_HREDRAW HEX: 0002 ; inline diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor index ffab6786b5..197a16ea31 100755 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -74,7 +74,7 @@ TYPEDEF: void* SOCKET : AI_PASSIVE 1 ; inline : AI_CANONNAME 2 ; inline : AI_NUMERICHOST 4 ; inline -: AI_MASK AI_PASSIVE AI_CANONNAME bitor AI_NUMERICHOST bitor ; +: AI_MASK { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; : NI_NUMERICHOST 1 ; : NI_NUMERICSERV 2 ; diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor old mode 100644 new mode 100755 index d8f08d8772..36b4fa1160 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -21,14 +21,16 @@ SYMBOL: swap new* >>child new* "white" <-- set-foreground >>gc - SubstructureRedirectMask - ExposureMask bitor - ButtonPressMask bitor - ButtonReleaseMask bitor - ButtonMotionMask bitor - EnterWindowMask bitor - ! experimental masks - SubstructureNotifyMask bitor + { + SubstructureRedirectMask + ExposureMask + ButtonPressMask + ButtonReleaseMask + ButtonMotionMask + EnterWindowMask + ! experimental masks + SubstructureNotifyMask + } flags >>mask <- init-widget diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor old mode 100644 new mode 100755 index 1f44460026..586acc1210 --- a/extra/x11/windows/windows.factor +++ b/extra/x11/windows/windows.factor @@ -5,25 +5,26 @@ namespaces sequences x11.xlib x11.constants x11.glx ; IN: x11.windows : create-window-mask ( -- n ) - CWBackPixel CWBorderPixel bitor - CWColormap bitor CWEventMask bitor ; + { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) dpy get root get rot XVisualInfo-visual AllocNone XCreateColormap ; : event-mask ( -- n ) - ExposureMask - StructureNotifyMask bitor - KeyPressMask bitor - KeyReleaseMask bitor - ButtonPressMask bitor - ButtonReleaseMask bitor - PointerMotionMask bitor - FocusChangeMask bitor - EnterWindowMask bitor - LeaveWindowMask bitor - PropertyChangeMask bitor ; + { + ExposureMask + StructureNotifyMask + KeyPressMask + KeyReleaseMask + ButtonPressMask + ButtonReleaseMask + PointerMotionMask + FocusChangeMask + EnterWindowMask + LeaveWindowMask + PropertyChangeMask + } flags ; : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" diff --git a/extra/x11/xim/xim.factor b/extra/x11/xim/xim.factor old mode 100644 new mode 100755 diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor old mode 100644 new mode 100755 index 730c4cf7cd..a13b553975 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -1088,8 +1088,8 @@ FUNCTION: Status XWithdrawWindow ( : PAspect 1 7 shift ; inline : PBaseSize 1 8 shift ; inline : PWinGravity 1 9 shift ; inline -: PAllHints [ PPosition PSize PMinSize PMaxSize PResizeInc PAspect ] -0 [ execute bitor ] reduce ; inline +: PAllHints + { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable C-STRUCT: XSizeHints { "long" "flags" } From 61a9adb2bb28cb290dcb46a5b094a4ae64ca480b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 14:59:36 -0600 Subject: [PATCH 095/317] Remove a tab --- core/compiler/test/alien.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index e737a76e1e..acb9a4a4fa 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -132,8 +132,8 @@ FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; + double y1, double y2, double y3, + double z1, double z2, double z3 ; [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test From b381c123dd0a24cad6c0f0d776c84bee458e5bf6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 15:00:05 -0600 Subject: [PATCH 096/317] Test fixes --- core/prettyprint/prettyprint-tests.factor | 6 +++--- core/strings/strings-tests.factor | 6 ++---- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 7f7d946347..5907c22686 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -21,9 +21,9 @@ IN: temporary [ "hello\\backslash" unparse ] unit-test -[ "\"\\u123456\"" ] -[ "\u123456" unparse ] -unit-test +! [ "\"\\u123456\"" ] +! [ "\u123456" unparse ] +! unit-test [ "\"\\e\"" ] [ "\e" unparse ] diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 459ec7b153..985c025827 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -88,8 +88,6 @@ unit-test ! Make sure aux vector is not shared [ "\udeadbe" ] [ - "\udeadbe" clone - CHAR: \u123456 over clone set-first + "\udeadbe" clone + CHAR: \u123456 over clone set-first ] unit-test - - From 70b685fad883132d6da87a1d4ae8fa0141fc1d8a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 15:00:16 -0600 Subject: [PATCH 097/317] Load fixes, FreeType memory usage fix --- extra/io/windows/windows.factor | 2 +- extra/opengl/opengl.factor | 7 ++++--- extra/ui/freetype/freetype.factor | 12 ++++++------ extra/ui/windows/windows.factor | 3 ++- extra/windows/advapi32/advapi32.factor | 2 +- extra/windows/opengl32/opengl32.factor | 5 ++--- extra/windows/user32/user32.factor | 2 +- extra/windows/winsock/winsock.factor | 6 +++--- 8 files changed, 20 insertions(+), 19 deletions(-) diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 3cf40fedf7..ee3f744bb0 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.nonblocking io.sockets io.binary io.sockets.impl windows.errors strings io.streams.duplex kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations ; +continuations math.bitfields ; IN: io.windows TUPLE: windows-nt-io ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 4ea91b867b..22bf657637 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays ; +splitting words byte-arrays assocs ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -233,7 +233,8 @@ TUPLE: sprite loc dim dim2 dlist texture ; dup sprite-dlist delete-dlist sprite-texture delete-texture ; -: free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ; +: free-sprites ( sprites -- ) + [ nip [ free-sprite ] when* ] assoc-each ; : with-translation ( loc quot -- ) GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 0d7522332f..2dade0f58e 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -36,13 +36,13 @@ M: font hashcode* drop font hashcode* ; : close-freetype ( -- ) global [ - open-fonts [ values [ close-font ] each f ] change + open-fonts [ [ drop close-font ] assoc-each f ] change freetype [ FT_Done_FreeType f ] change ] bind ; M: freetype-renderer free-fonts ( world -- ) dup world-handle select-gl-context - world-fonts values [ second free-sprites ] each ; + world-fonts [ nip second free-sprites ] assoc-each ; : ttf-name ( font style -- name ) 2array H{ @@ -100,7 +100,7 @@ SYMBOL: dpi swap set-font-height ; : ( handle -- font ) - V{ } clone + H{ } clone { set-font-handle set-font-widths } font construct dup init-font ; @@ -119,7 +119,7 @@ M: freetype-renderer open-font ( font -- open-font ) : char-width ( open-font char -- w ) over font-widths [ dupd load-glyph glyph-hori-advance ft-ceil - ] cache-nth nip ; + ] cache nip ; M: freetype-renderer string-width ( open-font string -- w ) 0 -rot [ char-width + ] with each ; @@ -175,7 +175,7 @@ M: freetype-renderer string-height ( open-font string -- h ) [ bitmap>texture ] keep [ init-sprite ] keep ; : draw-char ( open-font char sprites -- ) - [ dupd ] cache-nth nip + [ dupd ] cache nip sprite-dlist glCallList ; : (draw-string) ( open-font sprites string loc -- ) @@ -186,7 +186,7 @@ M: freetype-renderer string-height ( open-font string -- h ) ] do-enabled ; : font-sprites ( open-font world -- pair ) - world-fonts [ open-font V{ } clone 2array ] cache ; + world-fonts [ open-font H{ } clone 2array ] cache ; M: freetype-renderer draw-string ( font string loc -- ) >r >r world get font-sprites first2 r> r> (draw-string) ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 3ee339209c..c831a959d0 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,8 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads timers libc combinators continuations -command-line shuffle opengl ui.render unicode.case ascii ; +command-line shuffle opengl ui.render unicode.case ascii +math.bitfields ; IN: ui.windows TUPLE: windows-ui-backend ; diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 3f62082047..d3413b5695 100755 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -1,4 +1,4 @@ -USING: alien.syntax kernel math windows.types ; +USING: alien.syntax kernel math windows.types math.bitfields ; IN: windows.advapi32 LIBRARY: advapi32 diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor index e4254d779b..c38579c95e 100755 --- a/extra/windows/opengl32/opengl32.factor +++ b/extra/windows/opengl32/opengl32.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math windows.types windows.types init assocs sequences libc ; +math math.bitfields windows.types windows.types init assocs +sequences libc ; IN: windows.opengl32 ! PIXELFORMATDESCRIPTOR flags @@ -70,8 +71,6 @@ IN: windows.opengl32 : WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline : WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline - - : pfd-dwFlags { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor index 18d1956bda..39879bf91d 100755 --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types shuffle ; +windows.types shuffle math.bitfields ; IN: windows.user32 ! HKL for ActivateKeyboardLayout diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor index 197a16ea31..cc19cdc2a3 100755 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman. -USING: alien alien.c-types alien.syntax arrays byte-arrays kernel -math sequences windows.types windows.kernel32 windows.errors structs -windows ; +USING: alien alien.c-types alien.syntax arrays byte-arrays +kernel math sequences windows.types windows.kernel32 +windows.errors structs windows math.bitfields ; IN: windows.winsock USE: libc From 9667afcb816c042e4c396a0b048cbebdbd9b75f0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 Feb 2008 13:14:22 -0800 Subject: [PATCH 098/317] cel-shading, line-art, and bunny touch their magic rings together and become Super Bunny Demo --- core/alien/c-types/c-types.factor | 2 +- extra/bunny/bunny.factor | 158 ++++------- extra/cel-shading/cel-shading.factor | 115 -------- extra/line-art/line-art.factor | 254 ------------------ .../demo-support}/authors.txt | 0 .../demo-support/demo-support.factor} | 2 +- .../demo-support}/summary.txt | 0 .../demo-support}/tags.txt | 0 extra/opengl/opengl.factor | 11 +- 9 files changed, 63 insertions(+), 479 deletions(-) delete mode 100644 extra/cel-shading/cel-shading.factor delete mode 100644 extra/line-art/line-art.factor rename extra/{opengl-demo-support => opengl/demo-support}/authors.txt (100%) rename extra/{opengl-demo-support/opengl-demo-support.factor => opengl/demo-support/demo-support.factor} (99%) rename extra/{opengl-demo-support => opengl/demo-support}/summary.txt (100%) rename extra/{opengl-demo-support => opengl/demo-support}/tags.txt (100%) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index d260eb9b8f..8ab703eb7e 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -109,7 +109,7 @@ M: c-type stack-size c-type-size ; GENERIC: byte-length ( seq -- n ) flushable -M: float-array byte-length length "float" heap-size * ; +M: float-array byte-length length "double" heap-size * ; M: byte-array byte-length length ; diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 479d9cb39b..efebefcef3 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -1,123 +1,73 @@ -! From http://www.ffconsultancy.com/ocaml/bunny/index.html USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl opengl.gl opengl.glu shuffle http.client vectors timers namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting combinators tools.time system combinators.lib combinators.cleave -float-arrays ; +float-arrays continuations opengl.demo-support multiline +ui.gestures +bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ; IN: bunny -: numbers ( str -- seq ) - " " split [ string>number ] map [ ] subset ; + -: parse-model ( stream -- vs is ) - [ - 100000 100000 (parse-model) - ] with-stream - [ - over length # " vertices, " % - dup length # " triangles" % - ] "" make print ; +TUPLE: bunny-gadget model geom draw-seq draw-n ; -: n ( vs triple -- n ) - swap [ nth ] curry map - dup third over first v- >r dup second swap first v- r> cross - vneg normalize ; +: ( -- bunny-gadget ) + 0.0 0.0 0.375 + maybe-download read-model { + set-delegate + set-bunny-gadget-model + } bunny-gadget construct ; -: normal ( ns vs triple -- ) - [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ; +: bunny-gadget-draw ( gadget -- draw ) + { bunny-gadget-draw-n bunny-gadget-draw-seq } + get-slots nth ; -: normals ( vs is -- ns ) - over length { 0.0 0.0 0.0 } -rot - [ >r 2dup r> normal ] each drop - [ normalize ] map ; +: bunny-gadget-next-draw ( gadget -- ) + dup { bunny-gadget-draw-seq bunny-gadget-draw-n } + get-slots + 1+ swap length mod + swap [ set-bunny-gadget-draw-n ] keep relayout-1 ; -: read-model ( stream -- model ) - "Reading model" print flush [ - parse-model [ normals ] 2keep 3array - ] time ; - -: make-vertex-buffers ( model -- array element-array ) - [ - [ first concat ] [ second concat ] bi - append >float-array - GL_ARRAY_BUFFER swap GL_STATIC_DRAW - ] [ - third concat >c-uint-array - GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW - ] bi ; - -: model-path "bun_zipper.ply" ; - -: model-url "http://factorcode.org/bun_zipper.ply" ; - -: maybe-download ( -- path ) - model-path resource-path dup exists? [ - "Downloading bunny from " write - model-url dup print flush - over download-to - ] unless ; - -: draw-triangle ( ns vs triple -- ) - [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ; - -: draw-bunny ( ns vs is -- ) - GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ; - -TUPLE: bunny-gadget model ; - -: ( model -- gadget ) - - { set-bunny-gadget-model set-delegate } - bunny-gadget construct ; - -M: bunny-gadget graft* 10 10 add-timer ; - -M: bunny-gadget ungraft* dup delegate ungraft* remove-timer ; - -M: bunny-gadget tick relayout-1 ; - -: aspect ( gadget -- x ) rect-dim first2 /f ; - -M: bunny-gadget draw-gadget* +M: bunny-gadget graft* ( gadget -- ) GL_DEPTH_TEST glEnable - GL_SCISSOR_TEST glDisable - 1.0 glClearDepth - 0.0 0.0 0.0 1.0 glClearColor - GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear - GL_PROJECTION glMatrixMode - glLoadIdentity - 45.0 over aspect 0.1 1.0 gluPerspective - 0.0 0.12 -0.25 0.0 0.1 0.0 0.0 1.0 0.0 gluLookAt - GL_MODELVIEW glMatrixMode - glLoadIdentity - GL_LEQUAL glDepthFunc - GL_LIGHTING glEnable - GL_LIGHT0 glEnable - GL_COLOR_MATERIAL glEnable - GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv - millis 24000 mod 0.015 * 0.0 1.0 0.0 glRotated - GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf - GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial - GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial - 0.6 0.5 0.5 1.0 glColor4d - [ bunny-gadget-model first3 draw-bunny ] draw-canvas ; + dup bunny-gadget-model + over { + [ ] + [ ] + [ ] + } map-call-with [ ] subset + 0 + roll { + set-bunny-gadget-geom + set-bunny-gadget-draw-seq + set-bunny-gadget-draw-n + } set-slots ; -M: bunny-gadget pref-dim* drop { 400 300 } ; +M: bunny-gadget ungraft* ( gadget -- ) + { bunny-gadget-geom bunny-gadget-draw-seq } get-slots + [ [ dispose ] when* ] each + [ dispose ] when* ; + +M: bunny-gadget draw-gadget* ( gadget -- ) + 0.15 0.15 0.15 1.0 glClearColor + GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear + dup demo-gadget-set-matrices + GL_MODELVIEW glMatrixMode + 0.0 -0.12 0.0 glTranslatef + { bunny-gadget-geom bunny-gadget-draw } get-slots + draw-bunny ; + +M: bunny-gadget pref-dim* ( gadget -- dim ) + drop { 640 480 } ; + +bunny-gadget H{ + { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] } +} set-gestures : bunny-window ( -- ) - [ - maybe-download read-model - "Bunny" open-window - ] with-ui ; + [ "Bunny" open-window ] with-ui ; MAIN: bunny-window diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor deleted file mode 100644 index 992fd9655d..0000000000 --- a/extra/cel-shading/cel-shading.factor +++ /dev/null @@ -1,115 +0,0 @@ -USING: arrays bunny combinators.lib io io.files kernel - math math.functions multiline continuations debugger - opengl opengl.gl opengl-demo-support - sequences ui ui.gadgets ui.render ; -IN: cel-shading - -TUPLE: cel-shading-gadget model program vertices elements ; - -: ( -- cel-shading-gadget ) - 0.0 0.0 0.375 - maybe-download read-model { - set-delegate - set-cel-shading-gadget-model - } cel-shading-gadget construct ; - -STRING: cel-shading-vertex-shader-source -varying vec3 position, normal; - -void -main() -{ - gl_Position = ftransform(); - - position = gl_Vertex.xyz; - normal = gl_Normal; -} - -; - -STRING: cel-shading-fragment-shader-source -varying vec3 position, normal; -uniform vec3 light_direction; -uniform vec4 color; -uniform vec4 ambient, diffuse; - -float -smooth_modulate(vec3 direction, vec3 normal) -{ - return clamp(dot(direction, normal), 0.0, 1.0); -} - -float -modulate(vec3 direction, vec3 normal) -{ - float m = smooth_modulate(direction, normal); - return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5; -} - -void -main() -{ - vec3 direction = normalize(light_direction - position); - gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1); -} - -; - -: make-cel-shading-program ( -- program ) - cel-shading-vertex-shader-source cel-shading-fragment-shader-source - ; - -M: cel-shading-gadget graft* ( gadget -- ) - "2.0" { - "GL_ARB_shader_objects" - "GL_ARB_vertex_buffer_object" - } require-gl-version-or-extensions - 0.0 0.0 0.0 1.0 glClearColor - GL_CULL_FACE glEnable - GL_DEPTH_TEST glEnable - dup cel-shading-gadget-model make-vertex-buffers - make-cel-shading-program roll { - set-cel-shading-gadget-vertices - set-cel-shading-gadget-elements - set-cel-shading-gadget-program - } set-slots ; - -M: cel-shading-gadget ungraft* ( gadget -- ) - { - [ cel-shading-gadget-program [ delete-gl-program ] when* ] - [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ] - [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ] - } call-with ; - -: cel-shading-draw-setup ( gadget -- gadget ) - [ demo-gadget-set-matrices ] keep - [ cel-shading-gadget-program { - [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ] - [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] - [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] - [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] - } call-with ] keep ; - -M: cel-shading-gadget draw-gadget* ( gadget -- ) - dup cel-shading-gadget-program [ - cel-shading-draw-setup - 0.0 -0.12 0.0 glTranslatef - dup { - cel-shading-gadget-vertices - cel-shading-gadget-elements - } get-slots [ - GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [ - GL_FLOAT 0 0 buffer-offset glNormalPointer - cel-shading-gadget-model dup - first length 3 * 4 * buffer-offset - 3 GL_FLOAT 0 roll glVertexPointer - third length 3 * - GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements - ] all-enabled-client-state - ] with-array-element-buffers - ] with-gl-program ; - -: cel-shading-window ( -- ) - [ "Cel Shading" open-window ] with-ui ; - -MAIN: cel-shading-window diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor deleted file mode 100644 index d78ea8a4ee..0000000000 --- a/extra/line-art/line-art.factor +++ /dev/null @@ -1,254 +0,0 @@ -USING: arrays bunny combinators.lib continuations io io.files kernel - math math.functions math.vectors multiline - namespaces debugger - opengl opengl.gl opengl-demo-support - prettyprint - sequences ui ui.gadgets ui.gestures ui.render ; -IN: line-art - -TUPLE: line-art-gadget - model step1-program step2-program - framebuffer color-texture normal-texture depth-texture framebuffer-dim ; - -: ( -- line-art-gadget ) - 40.0 -5.0 0.275 - maybe-download read-model - { set-delegate set-line-art-gadget-model } line-art-gadget construct ; - -STRING: line-art-step1-vertex-shader-source -varying vec3 normal; - -void -main() -{ - gl_Position = ftransform(); - normal = gl_Normal; -} - -; - -STRING: line-art-step1-fragment-shader-source -varying vec3 normal; -uniform vec4 color; - -void -main() -{ - gl_FragData[0] = color; - gl_FragData[1] = vec4(normal, 1); -} - -; - -STRING: line-art-step2-vertex-shader-source -varying vec2 coord; - -void -main() -{ - gl_Position = ftransform(); - coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy; -} - -; - -STRING: line-art-step2-fragment-shader-source -uniform sampler2D colormap, normalmap, depthmap; -uniform vec4 line_color; -varying vec2 coord; - -const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0; - -float -depth_sample(vec2 c) -{ - return texture2D(depthmap, c).x; -} -bool -are_depths_border(vec3 depths) -{ - return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD))) - || any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD))); -} - -vec3 -normal_sample(vec2 c) -{ - return texture2D(normalmap, c).xyz; -} - -float -min6(float a, float b, float c, float d, float e, float f) -{ - return min(min(min(min(min(a, b), c), d), e), f); -} - -float -border_factor(vec2 c) -{ - vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD), - coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD), - coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD), - coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD); - - vec3 normal1 = normal_sample(coord1), - normal2 = normal_sample(coord2), - normal3 = normal_sample(coord3), - normal4 = normal_sample(coord4); - - if (dot(normal1, normal1) < 0.5 - && dot(normal2, normal2) < 0.5 - && dot(normal3, normal3) < 0.5 - && dot(normal4, normal4) < 0.5) { - return 0.0; - } else { - vec4 depths = vec4(depth_sample(coord1), - depth_sample(coord2), - depth_sample(coord3), - depth_sample(coord4)); - - vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww; - - if (are_depths_border(ratios1) || are_depths_border(ratios2)) { - return 1.0; - } else { - float normal_border = 1.0 - min6( - dot(normal1, normal2), - dot(normal1, normal3), - dot(normal1, normal4), - dot(normal2, normal3), - dot(normal2, normal4), - dot(normal3, normal4) - ); - - return normal_border; - } - } -} - -void -main() -{ - gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord)); -} - -; - -: (line-art-step1-program) ( -- step1 ) - line-art-step1-vertex-shader-source line-art-step1-fragment-shader-source - ; -: (line-art-step2-program) ( -- step2 ) - line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source - ; - -: (line-art-framebuffer-texture) ( dim iformat xformat -- texture ) - swapd >r >r >r - GL_TEXTURE0 glActiveTexture - gen-texture GL_TEXTURE_2D over glBindTexture - GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri - GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri - GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ; - -: (line-art-color-texture) ( dim -- texture ) - GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ; - -: (line-art-normal-texture) ( dim -- texture ) - GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ; - -: (line-art-depth-texture) ( dim -- texture ) - GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (line-art-framebuffer-texture) ; - -: (attach-framebuffer-texture) ( texture attachment -- ) - swap >r >r GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT gl-error ; - -: (line-art-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer ) - 3array gen-framebuffer dup [ - swap GL_COLOR_ATTACHMENT0_EXT - GL_COLOR_ATTACHMENT1_EXT - GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each - check-framebuffer - ] with-framebuffer ; - -: line-art-remake-framebuffer-if-needed ( gadget -- ) - dup { rect-dim rect-dim line-art-gadget-framebuffer-dim } get-slots = [ 2drop ] [ - swap >r - dup (line-art-color-texture) gl-error - swap dup (line-art-normal-texture) gl-error - swap dup (line-art-depth-texture) gl-error - swap >r - [ (line-art-framebuffer) ] 3keep - r> r> { set-line-art-gadget-framebuffer - set-line-art-gadget-color-texture - set-line-art-gadget-normal-texture - set-line-art-gadget-depth-texture - set-line-art-gadget-framebuffer-dim } set-slots - ] if ; - -M: line-art-gadget graft* ( gadget -- ) - "2.0" { "GL_ARB_draw_buffers" - "GL_ARB_shader_objects" - "GL_ARB_multitexture" - "GL_ARB_texture_float" } - require-gl-version-or-extensions - { "GL_EXT_framebuffer_object" } require-gl-extensions - GL_CULL_FACE glEnable - GL_DEPTH_TEST glEnable - (line-art-step1-program) over set-line-art-gadget-step1-program - (line-art-step2-program) swap set-line-art-gadget-step2-program ; - -M: line-art-gadget ungraft* ( gadget -- ) - dup line-art-gadget-framebuffer [ - { [ line-art-gadget-step1-program [ delete-gl-program ] when* ] - [ line-art-gadget-step2-program [ delete-gl-program ] when* ] - [ line-art-gadget-framebuffer [ delete-framebuffer ] when* ] - [ line-art-gadget-color-texture [ delete-texture ] when* ] - [ line-art-gadget-normal-texture [ delete-texture ] when* ] - [ line-art-gadget-depth-texture [ delete-texture ] when* ] - [ f swap set-line-art-gadget-framebuffer-dim ] - [ f swap set-line-art-gadget-framebuffer ] } call-with - ] [ drop ] if ; - -: line-art-draw-setup ( gadget -- gadget ) - 0.0 0.0 0.0 1.0 glClearColor - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - dup demo-gadget-set-matrices - dup line-art-remake-framebuffer-if-needed - gl-error ; - -: line-art-clear-framebuffer ( -- ) - GL_COLOR_ATTACHMENT0_EXT glDrawBuffer - 0.2 0.2 0.2 1.0 glClearColor - GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear - GL_COLOR_ATTACHMENT1_EXT glDrawBuffer - 0.0 0.0 0.0 0.0 glClearColor - GL_COLOR_BUFFER_BIT glClear ; - -M: line-art-gadget draw-gadget* ( gadget -- ) - line-art-draw-setup - dup line-art-gadget-framebuffer [ - line-art-clear-framebuffer - { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers - dup line-art-gadget-step1-program dup [ - "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f - 0.0 -0.12 0.0 glTranslatef - dup line-art-gadget-model first3 draw-bunny - ] with-gl-program - ] with-framebuffer - init-matrices - dup line-art-gadget-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit - dup line-art-gadget-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit - dup line-art-gadget-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit - line-art-gadget-step2-program dup [ - { [ "colormap" glGetUniformLocation 0 glUniform1i ] - [ "normalmap" glGetUniformLocation 1 glUniform1i ] - [ "depthmap" glGetUniformLocation 2 glUniform1i ] - [ "line_color" glGetUniformLocation 0.2 0.0 0.0 1.0 glUniform4f ] } call-with - { -1.0 -1.0 } { 1.0 1.0 } rect-vertices - ] with-gl-program ; - -: line-art-window ( -- ) - [ "Line Art" open-window ] with-ui ; - -MAIN: line-art-window diff --git a/extra/opengl-demo-support/authors.txt b/extra/opengl/demo-support/authors.txt similarity index 100% rename from extra/opengl-demo-support/authors.txt rename to extra/opengl/demo-support/authors.txt diff --git a/extra/opengl-demo-support/opengl-demo-support.factor b/extra/opengl/demo-support/demo-support.factor similarity index 99% rename from extra/opengl-demo-support/opengl-demo-support.factor rename to extra/opengl/demo-support/demo-support.factor index ecc6458d41..59b7a3bcc3 100644 --- a/extra/opengl-demo-support/opengl-demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; -IN: opengl-demo-support +IN: opengl.demo-support : NEAR-PLANE 1.0 64.0 / ; inline : FAR-PLANE 4.0 ; inline diff --git a/extra/opengl-demo-support/summary.txt b/extra/opengl/demo-support/summary.txt similarity index 100% rename from extra/opengl-demo-support/summary.txt rename to extra/opengl/demo-support/summary.txt diff --git a/extra/opengl-demo-support/tags.txt b/extra/opengl/demo-support/tags.txt similarity index 100% rename from extra/opengl-demo-support/tags.txt rename to extra/opengl/demo-support/tags.txt diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index a6aecf1b77..9b26662cef 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -444,8 +444,11 @@ PREDICATE: integer gl-program (gl-program?) ; [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] (require-gl) ; +: has-gl-version-or-extensions? ( version extensions -- ? ) + has-gl-extensions? swap has-gl-version? or ; + : require-gl-version-or-extensions ( version extensions -- ) - 2array [ first2 has-gl-extensions? swap has-gl-version? or ] - [ dup first (make-gl-version-error) "\n" % - second (make-gl-extensions-error) "\n" % ] - (require-gl) ; + 2array [ first2 has-gl-version-or-extensions? ] [ + dup first (make-gl-version-error) "\n" % + second (make-gl-extensions-error) "\n" % + ] (require-gl) ; From ba6660cabe1c155884ec8388e38bac51a2a378c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 2 Feb 2008 15:44:43 -0600 Subject: [PATCH 099/317] Fix bootstrap --- extra/cocoa/windows/windows.factor | 2 +- extra/io/unix/files/files.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor index caf5f713b7..b45acaf852 100755 --- a/extra/cocoa/windows/windows.factor +++ b/extra/cocoa/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math cocoa cocoa.messages cocoa.classes -sequences ; +sequences math.bitfields ; IN: cocoa.windows : NSBorderlessWindowMask 0 ; inline diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 8b32b19e1b..edee598435 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations ; +unix kernel math continuations math.bitfields ; IN: io.unix.files : read-flags O_RDONLY ; inline From 8b207d1f48891d201387da7930419e9287745308 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 17:22:20 -0500 Subject: [PATCH 100/317] Solution to Project Euler problem 75 --- extra/project-euler/039/039.factor | 17 +----- extra/project-euler/075/075.factor | 78 ++++++++++++++++++++++++ extra/project-euler/common/common.factor | 16 ++++- extra/project-euler/project-euler.factor | 3 +- 4 files changed, 98 insertions(+), 16 deletions(-) create mode 100644 extra/project-euler/075/075.factor diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor index 4df7ba610a..67578dc5f2 100644 --- a/extra/project-euler/039/039.factor +++ b/extra/project-euler/039/039.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays combinators.lib kernel math math.matrices math.ranges namespaces - sequences ; +USING: arrays combinators.lib kernel math math.ranges namespaces + project-euler.common sequences ; IN: project-euler.039 ! http://projecteuler.net/index.php?section=problems&id=39 @@ -21,6 +21,7 @@ IN: project-euler.039 ! -------- ! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html +! Identical implementation as problem #75 ! Basically, this makes an array of 1000 zeros, recursively creates primitive ! triples using the three transforms and then increments the array at index @@ -39,18 +40,6 @@ SYMBOL: p-count max-p 1- over p-count get [ [ 1+ ] change-nth ] curry each ; -: transform ( triple matrix -- new-triple ) - [ 1array ] dip m. first ; - -: u-transform ( triple -- new-triple ) - { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ; - -: a-transform ( triple -- new-triple ) - { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ; - -: d-transform ( triple -- new-triple ) - { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ; - : (count-perimeters) ( seq -- ) dup sum max-p < [ dup sum adjust-p-count diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor new file mode 100644 index 0000000000..f8ee9d50db --- /dev/null +++ b/extra/project-euler/075/075.factor @@ -0,0 +1,78 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.ranges namespaces + project-euler.common sequences ; +IN: project-euler.075 + +! http://projecteuler.net/index.php?section=problems&id=75 + +! DESCRIPTION +! ----------- + +! It turns out that 12 cm is the smallest length of wire can be bent to form a +! right angle triangle in exactly one way, but there are many more examples. + +! 12 cm: (3,4,5) +! 24 cm: (6,8,10) +! 30 cm: (5,12,13) +! 36 cm: (9,12,15) +! 40 cm: (8,15,17) +! 48 cm: (12,16,20) + +! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right +! angle triangle, and other lengths allow more than one solution to be found; +! for example, using 120 cm it is possible to form exactly three different +! right angle triangles. + +! 120 cm: (30,40,50), (20,48,52), (24,45,51) + +! Given that L is the length of the wire, for how many values of L ≤ 1,000,000 +! can exactly one right angle triangle be formed? + + +! SOLUTION +! -------- + +! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html +! Identical implementation as problem #39 + +! Basically, this makes an array of 1000000 zeros, recursively creates +! primitive triples using the three transforms and then increments the array at +! index [a+b+c] by one for each triple's sum AND its multiples under 1000000 +! (to account for non-primitive triples). The answer is just the number of +! indexes that equal one. + +SYMBOL: p-count + + p-count get + [ [ 1+ ] change-nth ] curry each ; + +: (count-perimeters) ( seq -- ) + dup sum max-p < [ + dup sum adjust-p-count + [ u-transform ] keep [ a-transform ] keep d-transform + [ (count-perimeters) ] 3apply + ] [ + drop + ] if ; + +: count-perimeters ( n -- ) + 0 p-count set { 3 4 5 } (count-perimeters) ; + +PRIVATE> + +: euler075 ( -- answer ) + [ + 1000000 count-perimeters p-count get [ 1 = ] count + ] with-scope ; + +! [ euler075 ] 100 ave-time +! 1873 ms run / 123 ms GC ave time - 100 trials + +MAIN: euler075 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 609492c724..50adbe4953 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,5 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin - math.parser math.primes.factors math.ranges namespaces sequences sorting ; + math.matrices math.parser math.primes.factors math.ranges namespaces + sequences sorting ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -16,6 +17,7 @@ IN: project-euler.common ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 +! [uad]-transform - #39, #75 : nth-pair ( n seq -- nth next ) @@ -45,6 +47,9 @@ IN: project-euler.common dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if ] { } make sum ; +: transform ( triple matrix -- new-triple ) + [ 1array ] dip m. first ; + PRIVATE> : cartesian-product ( seq1 seq2 -- seq1xseq2 ) @@ -101,3 +106,12 @@ PRIVATE> dup sqrt >fixnum [1,b] [ dupd mod zero? [ [ 2 + ] dip ] when ] each drop * ; + +! These transforms are for generating primitive Pythagorean triples +: u-transform ( triple -- new-triple ) + { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ; +: a-transform ( triple -- new-triple ) + { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ; +: d-transform ( triple -- new-triple ) + { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ; + diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 86dff7a192..f5766536ef 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,7 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.067 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.075 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Sat, 2 Feb 2008 14:24:03 -0800 Subject: [PATCH 101/317] Fix has-gl-extensions? when requested extensions are not contiguous in the gl-extensions string --- extra/opengl/opengl.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index e000a3103e..d26c2c7685 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -401,7 +401,7 @@ PREDICATE: integer gl-program (gl-program?) ; : gl-extensions ( -- seq ) GL_EXTENSIONS glGetString " " split ; : has-gl-extensions? ( extensions -- ? ) - gl-extensions subseq? ; + gl-extensions swap [ over member? ] all? nip ; : (make-gl-extensions-error) ( required-extensions -- ) gl-extensions swap seq-diff "Required OpenGL extensions not supported:\n" % From 7da1da5fff0e539fefd5772b891977f283639d65 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 2 Feb 2008 15:33:05 -0800 Subject: [PATCH 102/317] Modularize the new bunny demo, and adjust the bikeshed parameters a bit --- extra/bunny/cel-shaded/cel-shaded.factor | 95 +++++++ .../fixed-pipeline/fixed-pipeline.factor | 25 ++ extra/bunny/model/model.factor | 114 +++++++++ extra/bunny/outlined/outlined.factor | 235 ++++++++++++++++++ 4 files changed, 469 insertions(+) create mode 100644 extra/bunny/cel-shaded/cel-shaded.factor create mode 100644 extra/bunny/fixed-pipeline/fixed-pipeline.factor create mode 100644 extra/bunny/model/model.factor create mode 100644 extra/bunny/outlined/outlined.factor diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor new file mode 100644 index 0000000000..eb0924f50e --- /dev/null +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -0,0 +1,95 @@ +USING: arrays bunny.model combinators.lib continuations +kernel multiline opengl opengl.gl sequences ; +IN: bunny.cel-shaded + +STRING: vertex-shader-source +varying vec3 position, normal, viewer; + +void +main() +{ + gl_Position = ftransform(); + + position = gl_Vertex.xyz; + normal = gl_Normal; + viewer = vec3(0, 0, 1) * gl_NormalMatrix; +} + +; + +STRING: cel-shaded-fragment-shader-lib-source +varying vec3 position, normal, viewer; +uniform vec3 light_direction; +uniform vec4 color; +uniform vec4 ambient, diffuse; +uniform float shininess; + +float +modulate(vec3 direction, vec3 normal) +{ + return dot(direction, normal) * 0.5 + 0.5; +} + +float +cel(float m) +{ + return smoothstep(0.25, 0.255, m) * 0.4 + smoothstep(0.695, 0.70, m) * 0.5; +} + +vec4 +cel_light() +{ + vec3 direction = normalize(light_direction - position); + vec3 reflection = reflect(direction, normal); + vec4 ad = (ambient + diffuse * vec4(vec3(cel(modulate(direction, normal))), 1)); + float s = cel(pow(max(dot(-reflection, viewer), 0.0), shininess)); + return ad * color + vec4(vec3(s), 0); +} + +; + +STRING: cel-shaded-fragment-shader-main-source +vec4 cel_light(); + +void +main() +{ + gl_FragColor = cel_light(); +} + +; + +TUPLE: bunny-cel-shaded program ; + +: cel-shading-supported? ( -- ? ) + "2.0" { "GL_ARB_shader_objects" } + has-gl-version-or-extensions? ; + +: ( gadget -- draw ) + drop + cel-shading-supported? [ + vertex-shader-source check-gl-shader + cel-shaded-fragment-shader-lib-source check-gl-shader + cel-shaded-fragment-shader-main-source check-gl-shader + 3array check-gl-program + { set-bunny-cel-shaded-program } bunny-cel-shaded construct + ] [ f ] if ; + +: (draw-cel-shaded-bunny) ( geom program -- ) + dup [ + { + [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ] + [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] + [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] + [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] + [ "shininess" glGetUniformLocation 100.0 glUniform1f ] + } call-with + bunny-geom + ] with-gl-program ; + +M: bunny-cel-shaded draw-bunny + bunny-cel-shaded-program (draw-cel-shaded-bunny) ; + +M: bunny-cel-shaded dispose + bunny-cel-shaded-program delete-gl-program ; + diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor new file mode 100644 index 0000000000..f3fb68e515 --- /dev/null +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -0,0 +1,25 @@ +USING: alien.c-types continuations kernel +opengl opengl.gl bunny.model ; +IN: bunny.fixed-pipeline + +TUPLE: bunny-fixed-pipeline ; + +: ( gadget -- draw ) + drop + { } bunny-fixed-pipeline construct ; + +M: bunny-fixed-pipeline draw-bunny + drop + GL_LIGHTING glEnable + GL_LIGHT0 glEnable + GL_COLOR_MATERIAL glEnable + GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv + GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf + GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial + GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial + 0.6 0.5 0.5 1.0 glColor4f + bunny-geom ; + +M: bunny-fixed-pipeline dispose + drop ; + diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor new file mode 100644 index 0000000000..a19adcb782 --- /dev/null +++ b/extra/bunny/model/model.factor @@ -0,0 +1,114 @@ +USING: alien alien.c-types arrays sequences math +math.vectors math.matrices math.parser io io.files kernel opengl +opengl.gl opengl.glu shuffle http.client vectors splitting +tools.time system combinators combinators.lib combinators.cleave +float-arrays continuations namespaces ; +IN: bunny.model + +: numbers ( str -- seq ) + " " split [ string>number ] map [ ] subset ; + +: (parse-model) ( vs is -- vs is ) + readln [ + numbers { + { [ dup length 5 = ] [ 3 head pick push ] } + { [ dup first 3 = ] [ 1 tail over push ] } + { [ t ] [ drop ] } + } cond (parse-model) + ] when* ; + +: parse-model ( stream -- vs is ) + [ + 100000 100000 (parse-model) + ] with-stream + [ + over length # " vertices, " % + dup length # " triangles" % + ] "" make print ; + +: n ( vs triple -- n ) + swap [ nth ] curry map + dup third over first v- >r dup second swap first v- r> cross + vneg normalize ; + +: normal ( ns vs triple -- ) + [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ; + +: normals ( vs is -- ns ) + over length { 0.0 0.0 0.0 } -rot + [ >r 2dup r> normal ] each drop + [ normalize ] map ; + +: read-model ( stream -- model ) + "Reading model" print flush [ + parse-model [ normals ] 2keep 3array + ] time ; + +: model-path "bun_zipper.ply" ; + +: model-url "http://factorcode.org/bun_zipper.ply" ; + +: maybe-download ( -- path ) + model-path resource-path dup exists? [ + "Downloading bunny from " write + model-url dup print flush + over download-to + ] unless ; + +: (draw-triangle) ( ns vs triple -- ) + [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ; + +: draw-triangles ( ns vs is -- ) + GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ; + +TUPLE: bunny-dlist list ; +TUPLE: bunny-buffers array element-array nv ni ; + +: ( model -- geom ) + GL_COMPILE [ first3 draw-triangles ] make-dlist + bunny-dlist construct-boa ; + +: ( model -- geom ) + [ + [ first concat ] [ second concat ] bi + append >float-array + GL_ARRAY_BUFFER swap GL_STATIC_DRAW + ] [ + third concat >c-uint-array + GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW + ] + [ first length 3 * ] [ third length 3 * ] tetra + bunny-buffers construct-boa ; + +GENERIC: bunny-geom ( geom -- ) +GENERIC: draw-bunny ( geom draw -- ) + +M: bunny-dlist bunny-geom + bunny-dlist-list glCallList ; + +M: bunny-buffers bunny-geom + dup { + bunny-buffers-array + bunny-buffers-element-array + } get-slots [ + GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [ + GL_DOUBLE 0 0 buffer-offset glNormalPointer + dup bunny-buffers-nv "double" heap-size * buffer-offset + 3 GL_DOUBLE 0 roll glVertexPointer + bunny-buffers-ni + GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements + ] all-enabled-client-state + ] with-array-element-buffers ; + +M: bunny-dlist dispose + bunny-dlist-list delete-dlist ; + +M: bunny-buffers dispose + { bunny-buffers-array bunny-buffers-element-array } get-slots + delete-gl-buffer delete-gl-buffer ; + +: ( model -- geom ) + "1.5" { "GL_ARB_vertex_buffer_object" } + has-gl-version-or-extensions? + [ ] [ ] if ; + diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor new file mode 100644 index 0000000000..021ac6b4d8 --- /dev/null +++ b/extra/bunny/outlined/outlined.factor @@ -0,0 +1,235 @@ +USING: arrays bunny.model bunny.cel-shaded +combinators.lib continuations kernel math multiline +opengl opengl.gl sequences ui.gadgets ; +IN: bunny.outlined + +STRING: outlined-pass1-fragment-shader-main-source +varying vec3 normal; +vec4 cel_light(); + +void +main() +{ + gl_FragData[0] = cel_light(); + gl_FragData[1] = vec4(normal, 1); +} + +; + +STRING: outlined-pass2-vertex-shader-source +varying vec2 coord; + +void +main() +{ + gl_Position = ftransform(); + coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy; +} + +; + +STRING: outlined-pass2-fragment-shader-source +uniform sampler2D colormap, normalmap, depthmap; +uniform vec4 line_color; +varying vec2 coord; + +const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0; + +float +depth_sample(vec2 c) +{ + return texture2D(depthmap, c).x; +} +bool +are_depths_border(vec3 depths) +{ + return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD))) + || any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD))); +} + +vec3 +normal_sample(vec2 c) +{ + return texture2D(normalmap, c).xyz; +} + +float +min6(float a, float b, float c, float d, float e, float f) +{ + return min(min(min(min(min(a, b), c), d), e), f); +} + +float +border_factor(vec2 c) +{ + vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD), + coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD), + coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD), + coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD); + + vec3 normal1 = normal_sample(coord1), + normal2 = normal_sample(coord2), + normal3 = normal_sample(coord3), + normal4 = normal_sample(coord4); + + if (dot(normal1, normal1) < 0.5 + && dot(normal2, normal2) < 0.5 + && dot(normal3, normal3) < 0.5 + && dot(normal4, normal4) < 0.5) { + return 0.0; + } else { + vec4 depths = vec4(depth_sample(coord1), + depth_sample(coord2), + depth_sample(coord3), + depth_sample(coord4)); + + vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww; + + if (are_depths_border(ratios1) || are_depths_border(ratios2)) { + return 1.0; + } else { + float normal_border = 1.0 - min6( + dot(normal1, normal2), + dot(normal1, normal3), + dot(normal1, normal4), + dot(normal2, normal3), + dot(normal2, normal4), + dot(normal3, normal4) + ); + + return normal_border; + } + } +} + +void +main() +{ + gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord)); +} + +; + +TUPLE: bunny-outlined + gadget + pass1-program pass2-program + color-texture normal-texture depth-texture + framebuffer framebuffer-dim ; + +: outlining-supported? ( -- ? ) + "2.0" { + "GL_ARB_shading_objects" + "GL_ARB_draw_buffers" + "GL_ARB_multitexture" + } has-gl-version-or-extensions? { + "GL_EXT_framebuffer_object" + "GL_ARB_texture_float" + } has-gl-extensions? and ; + +: pass1-program ( -- program ) + vertex-shader-source check-gl-shader + cel-shaded-fragment-shader-lib-source check-gl-shader + outlined-pass1-fragment-shader-main-source check-gl-shader + 3array check-gl-program ; + +: pass2-program ( -- program ) + outlined-pass2-vertex-shader-source + outlined-pass2-fragment-shader-source ; + +: ( gadget -- draw ) + outlining-supported? [ + pass1-program pass2-program { + set-bunny-outlined-gadget + set-bunny-outlined-pass1-program + set-bunny-outlined-pass2-program + } bunny-outlined construct + ] [ drop f ] if ; + +: (framebuffer-texture) ( dim iformat xformat -- texture ) + swapd >r >r >r + GL_TEXTURE0 glActiveTexture + gen-texture GL_TEXTURE_2D over glBindTexture + GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri + GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ; + +: (attach-framebuffer-texture) ( texture attachment -- ) + swap >r >r + GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT + gl-error ; + +: (make-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer ) + 3array gen-framebuffer dup [ + swap GL_COLOR_ATTACHMENT0_EXT + GL_COLOR_ATTACHMENT1_EXT + GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each + check-framebuffer + ] with-framebuffer ; + +: remake-framebuffer-if-needed ( draw -- ) + dup bunny-outlined-gadget rect-dim + over bunny-outlined-framebuffer-dim + over = + [ 2drop ] + [ + swap >r + dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) + swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) + swap >r + [ (make-framebuffer) ] 3keep + r> r> { + set-bunny-outlined-framebuffer + set-bunny-outlined-color-texture + set-bunny-outlined-normal-texture + set-bunny-outlined-depth-texture + set-bunny-outlined-framebuffer-dim + } set-slots + ] if ; + +: clear-framebuffer ( -- ) + GL_COLOR_ATTACHMENT0_EXT glDrawBuffer + 0.15 0.15 0.15 1.0 glClearColor + GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear + GL_COLOR_ATTACHMENT1_EXT glDrawBuffer + 0.0 0.0 0.0 0.0 glClearColor + GL_COLOR_BUFFER_BIT glClear ; + +: (pass1) ( geom draw -- ) + dup bunny-outlined-framebuffer [ + clear-framebuffer + { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers + bunny-outlined-pass1-program (draw-cel-shaded-bunny) + ] with-framebuffer ; + +: (pass2) ( draw -- ) + init-matrices + dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit + dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit + dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit + bunny-outlined-pass2-program dup [ + { + [ "colormap" glGetUniformLocation 0 glUniform1i ] + [ "normalmap" glGetUniformLocation 1 glUniform1i ] + [ "depthmap" glGetUniformLocation 2 glUniform1i ] + [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ] + } call-with + { -1.0 -1.0 } { 1.0 1.0 } rect-vertices + ] with-gl-program ; + +M: bunny-outlined draw-bunny + dup remake-framebuffer-if-needed + [ (pass1) ] keep (pass2) ; + +M: bunny-outlined dispose + { + [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] + [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] + [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ] + [ bunny-outlined-color-texture [ delete-texture ] when* ] + [ bunny-outlined-normal-texture [ delete-texture ] when* ] + [ bunny-outlined-depth-texture [ delete-texture ] when* ] + [ f swap set-bunny-outlined-framebuffer-dim ] + } call-with ; From 557bde6206e5243140307bff964a0b73e204d139 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 18:53:32 -0500 Subject: [PATCH 103/317] Solution to Project Euler problem 40 --- extra/project-euler/040/040.factor | 51 ++++++++++++++++++++++++ extra/project-euler/075/075.factor | 4 +- extra/project-euler/project-euler.factor | 6 +-- 3 files changed, 56 insertions(+), 5 deletions(-) create mode 100644 extra/project-euler/040/040.factor diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor new file mode 100644 index 0000000000..8984559265 --- /dev/null +++ b/extra/project-euler/040/040.factor @@ -0,0 +1,51 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser sequences strings ; +IN: project-euler.040 + +! http://projecteuler.net/index.php?section=problems&id=40 + +! DESCRIPTION +! ----------- + +! An irrational decimal fraction is created by concatenating the positive +! integers: + +! 0.123456789101112131415161718192021... + +! It can be seen that the 12th digit of the fractional part is 1. + +! If dn represents the nth digit of the fractional part, find the value of the +! following expression. + +! d1 × d10 × d100 × d1000 × d10000 × d100000 × d1000000 + + +! SOLUTION +! -------- + + [ + pick number>string over push-all rot 1+ -rot (concat-upto) + ] [ + 2nip + ] if ; + +: concat-upto ( n -- str ) + SBUF" " clone 1 -rot (concat-upto) ; + +: nth-integer ( n str -- m ) + [ 1- ] dip nth 1string 10 string>integer ; + +PRIVATE> + +: euler040 ( -- answer ) + 1000000 concat-upto { 1 10 100 1000 10000 100000 1000000 } + [ swap nth-integer ] with map product ; + +! [ euler040 ] 100 ave-time +! 1002 ms run / 43 ms GC ave time - 100 trials + +MAIN: euler040 diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor index f8ee9d50db..8399235c0d 100644 --- a/extra/project-euler/075/075.factor +++ b/extra/project-euler/075/075.factor @@ -39,8 +39,8 @@ IN: project-euler.075 ! Basically, this makes an array of 1000000 zeros, recursively creates ! primitive triples using the three transforms and then increments the array at ! index [a+b+c] by one for each triple's sum AND its multiples under 1000000 -! (to account for non-primitive triples). The answer is just the number of -! indexes that equal one. +! (to account for non-primitive triples). The answer is just the total number +! of indexes that are equal to one. SYMBOL: p-count diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index f5766536ef..eb9d7d1300 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -11,9 +11,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.037 project-euler.038 project-euler.039 project-euler.067 - project-euler.075 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.037 project-euler.038 project-euler.039 project-euler.040 + project-euler.067 project-euler.075 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Sat, 2 Feb 2008 18:14:26 -0600 Subject: [PATCH 104/317] Monitors work in progress --- extra/io/buffers/buffers.factor | 2 +- extra/io/monitor/monitor.factor | 2 +- extra/io/windows/nt/monitor/monitor.factor | 3 ++- 3 files changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index f26fe50d79..ef12543d52 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -14,7 +14,7 @@ TUPLE: buffer size ptr fill pos ; dup buffer-ptr free f swap set-buffer-ptr ; : buffer-reset ( n buffer -- ) - [ set-buffer-fill ] keep 0 swap set-buffer-pos ; + 0 swap { set-buffer-fill set-buffer-pos } set-slots ; : buffer-consume ( n buffer -- ) [ buffer-pos + ] keep diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index fe33045e01..11d1b6ecf9 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -20,7 +20,7 @@ TUPLE: monitor queue closed? ; HOOK: fill-queue io-backend ( monitor -- assoc ) : changed-file ( changed path -- ) - namespace [ swap add ] change-at ; + namespace [ append ] change-at ; : dequeue-change ( assoc -- path changes ) delete-any prune natural-sort >array ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index 1be91263c4..f2cc4ef92a 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -70,7 +70,8 @@ M: windows-nt-io ( path recursive? -- monitor ) FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots >r memory>u16-string path+ r> parse-action swap ; + } get-slots parse-action 1array -rot + memory>u16-string path+ ; : (changed-files) ( directory buffer -- ) 2dup parse-file-notify changed-file From ac10c4067a5401a6088ba6ba95f371e57af5714b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:31:55 -0500 Subject: [PATCH 105/317] Better method for getting last digits of an integer --- extra/project-euler/032/032.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 2baa6f8714..e03ab6f89b 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences ; +USING: combinators.lib hashtables kernel math math.combinatorics math.functions + math.parser math.ranges project-euler.common sequences ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 @@ -41,7 +41,7 @@ IN: project-euler.032 dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ 10 4 ^ mod ] map ; PRIVATE> @@ -49,7 +49,7 @@ PRIVATE> source-032 [ valid? ] subset products prune sum ; ! [ euler032 ] 10 ave-time -! 27609 ms run / 2484 ms GC ave time - 10 trials +! 23922 ms run / 1505 ms GC ave time - 10 trials ! ALTERNATE SOLUTIONS From 1954114d85e75a13b2274a093af8d4f94372f024 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:42:47 -0500 Subject: [PATCH 106/317] Solution to Project Euler problem 48 --- extra/project-euler/048/048.factor | 25 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 ++-- 2 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/048/048.factor diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor new file mode 100644 index 0000000000..ba58792987 --- /dev/null +++ b/extra/project-euler/048/048.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions ; +IN: project-euler.048 + +! http://projecteuler.net/index.php?section=problems&id=48 + +! DESCRIPTION +! ----------- + +! The series, 1^1 + 2^2 + 3^3 + ... + 10^10 = 10405071317. + +! Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000. + + +! SOLUTION +! -------- + +: euler048 ( -- answer ) + 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ; + +! [ euler048 ] 100 ave-time +! 276 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler048 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index eb9d7d1300..d89453eb14 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.048 project-euler.067 project-euler.075 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sat, 2 Feb 2008 18:15:22 -0800 Subject: [PATCH 107/317] Make setting up shader uniform parameters nicer from with-gl-program --- extra/bunny/bunny.factor | 4 --- extra/bunny/cel-shaded/cel-shaded.factor | 17 +++++------- extra/bunny/outlined/outlined.factor | 34 +++++++++++++----------- extra/opengl/opengl-docs.factor | 25 +++++++++++++---- extra/opengl/opengl.factor | 18 +++++++++++-- 5 files changed, 62 insertions(+), 36 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index efebefcef3..38f8e32fb6 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -8,10 +8,6 @@ ui.gestures bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ; IN: bunny - - TUPLE: bunny-gadget model geom draw-seq draw-n ; : ( -- bunny-gadget ) diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index eb0924f50e..fc42ca971e 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -76,16 +76,13 @@ TUPLE: bunny-cel-shaded program ; ] [ f ] if ; : (draw-cel-shaded-bunny) ( geom program -- ) - dup [ - { - [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ] - [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ] - [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ] - [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] - [ "shininess" glGetUniformLocation 100.0 glUniform1f ] - } call-with - bunny-geom - ] with-gl-program ; + { + { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } + { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } + { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } + { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } + { "shininess" [ 100.0 glUniform1f ] } + } [ bunny-geom ] with-gl-program ; M: bunny-cel-shaded draw-bunny bunny-cel-shaded-program (draw-cel-shaded-bunny) ; diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 021ac6b4d8..9de341561c 100644 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -168,13 +168,24 @@ TUPLE: bunny-outlined check-framebuffer ] with-framebuffer ; +: dispose-framebuffer ( draw -- ) + dup bunny-outlined-framebuffer-dim [ + { + [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ] + [ bunny-outlined-color-texture [ delete-texture ] when* ] + [ bunny-outlined-normal-texture [ delete-texture ] when* ] + [ bunny-outlined-depth-texture [ delete-texture ] when* ] + [ f swap set-bunny-outlined-framebuffer-dim ] + } call-with + ] [ drop ] if ; + : remake-framebuffer-if-needed ( draw -- ) dup bunny-outlined-gadget rect-dim over bunny-outlined-framebuffer-dim over = [ 2drop ] [ - swap >r + swap dup dispose-framebuffer >r dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture) swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture) @@ -209,15 +220,12 @@ TUPLE: bunny-outlined dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit - bunny-outlined-pass2-program dup [ - { - [ "colormap" glGetUniformLocation 0 glUniform1i ] - [ "normalmap" glGetUniformLocation 1 glUniform1i ] - [ "depthmap" glGetUniformLocation 2 glUniform1i ] - [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ] - } call-with - { -1.0 -1.0 } { 1.0 1.0 } rect-vertices - ] with-gl-program ; + bunny-outlined-pass2-program { + { "colormap" [ 0 glUniform1i ] } + { "normalmap" [ 1 glUniform1i ] } + { "depthmap" [ 2 glUniform1i ] } + { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] } + } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ; M: bunny-outlined draw-bunny dup remake-framebuffer-if-needed @@ -227,9 +235,5 @@ M: bunny-outlined dispose { [ bunny-outlined-pass1-program [ delete-gl-program ] when* ] [ bunny-outlined-pass2-program [ delete-gl-program ] when* ] - [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ] - [ bunny-outlined-color-texture [ delete-texture ] when* ] - [ bunny-outlined-normal-texture [ delete-texture ] when* ] - [ bunny-outlined-depth-texture [ delete-texture ] when* ] - [ f swap set-bunny-outlined-framebuffer-dim ] + [ dispose-framebuffer ] } call-with ; diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index 63875e91a8..cb0c9e884f 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl ; +opengl.gl multiline assocs ; IN: opengl HELP: gl-color @@ -241,8 +241,19 @@ HELP: delete-gl-program { $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; HELP: with-gl-program -{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } } -{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ; +{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } } +{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack for the associated quotation.\n\nExample:" } +{ $code <" +! From bunny.cel-shaded +: (draw-cel-shaded-bunny) ( geom program -- ) + { + { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } + { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } + { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } + { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } + { "shininess" [ 100.0 glUniform1f ] } + } [ bunny-geom ] with-gl-program ; +"> } ; HELP: gl-version { $values { "version" "The version string from the OpenGL implementation" } } @@ -284,15 +295,19 @@ HELP: has-gl-extensions? { $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } { $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; +HELP: has-gl-version-or-extensions? +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + HELP: require-gl-extensions { $values { "extensions" "A sequence of extension name strings" } } { $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; HELP: require-gl-version-or-extensions { $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } -{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version, or a set of equivalent extensions." } ; +{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; -{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? gl-version glsl-version gl-extensions } related-words +{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words ARTICLE: "gl-utilities" "OpenGL utility words" "In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel." diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index d26c2c7685..071f85fe12 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types continuations kernel libc math macros namespaces math.vectors math.constants math.functions math.parser opengl.gl opengl.glu combinators arrays sequences -splitting words byte-arrays assocs ; +splitting words byte-arrays assocs combinators.lib ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -382,9 +382,23 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ; 2dup detach-gl-program-shader delete-gl-shader ] each delete-gl-program-only ; -: with-gl-program ( program quot -- ) +: (with-gl-program) ( program quot -- ) swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline +: (with-gl-program-uniforms) ( uniforms -- quot ) + [ [ swap , \ glGetUniformLocation , % ] [ ] make ] + { } assoc>map ; +: (make-with-gl-program) ( uniforms quot -- q ) + [ + \ dup , + [ swap (with-gl-program-uniforms) , \ call-with , % ] + [ ] make , + \ (with-gl-program) , + ] [ ] make ; + +MACRO: with-gl-program ( uniforms quot -- ) + (make-with-gl-program) ; + PREDICATE: integer gl-program (gl-program?) ; : ( vertex-shader-source fragment-shader-source -- program ) From 7ad7a89a2bb47412252d4bcb47c9b4b7e31e3df2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Feb 2008 23:27:27 -0600 Subject: [PATCH 108/317] move >Upper and >Upper-dashes to unicode.case --- extra/strings/lib/lib.factor | 8 -------- extra/unicode/case/case.factor | 11 ++++++++++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor index 719881b768..d0a34c8d28 100644 --- a/extra/strings/lib/lib.factor +++ b/extra/strings/lib/lib.factor @@ -4,11 +4,3 @@ IN: strings.lib ! : char>digit ( c -- i ) 48 - ; ! : string>digits ( s -- seq ) [ char>digit ] { } map-as ; - -! : >Upper ( str -- str ) -! dup empty? [ -! unclip ch>upper 1string swap append -! ] unless ; - -! : >Upper-dashes ( str -- str ) -! "-" split [ >Upper ] map "-" join ; diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index ee9e2a0381..f244192a32 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -1,6 +1,6 @@ USING: kernel unicode.data sequences sequences.next namespaces assocs.lib unicode.normalize math unicode.categories combinators -assocs ; +assocs strings splitting ; IN: unicode.case : ch>lower ( ch -- lower ) simple-lower at-default ; @@ -110,3 +110,12 @@ SYMBOL: locale ! Just casing locale, or overall? dup >title = ; : case-fold? ( string -- ? ) dup >case-fold = ; + + +: >Upper ( str -- str ) + dup empty? [ + unclip ch>upper 1string swap append + ] unless ; + +: >Upper-dashes ( str -- str ) + "-" split [ >Upper ] map "-" join ; From 7954bc33bfec8694e0d619b59c07215b98548a70 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Feb 2008 23:27:44 -0600 Subject: [PATCH 109/317] fix server responders --- extra/http/server/responders/responders.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index a507a95a14..6df52997e1 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors vector-hash strings.lib ; +strings io.server vectors assocs.lib unicode.case ; IN: http.server.responders @@ -10,11 +10,11 @@ IN: http.server.responders SYMBOL: vhosts SYMBOL: responders -: >header ( value key -- vector-hash ) - VH{ } clone [ set-at ] keep ; +: >header ( value key -- multi-hash ) + H{ } clone [ insert-at ] keep ; : print-header ( alist -- ) - [ swap >Upper-dashes write ": " write print ] vector-hash-each nl ; + [ swap >Upper-dashes write ": " write print ] multi-assoc-each nl ; : response ( msg -- ) "HTTP/1.0 " write print ; @@ -23,7 +23,7 @@ SYMBOL: responders : error-head ( error -- ) dup log-error response - VH{ { "Content-Type" "text/html" } } print-header nl ; + H{ { "Content-Type" V{ "text/html" } } } print-header nl ; : httpd-error ( error -- ) #! This must be run from handle-request @@ -94,7 +94,7 @@ SYMBOL: max-post-request } member? ] assoc-subset [ ": " swap 3append log-message - ] vector-hash-each ; + ] multi-assoc-each ; : prepare-url ( url -- url ) #! This is executed in the with-request namespace. From 2c1bad2254b67b11b4780e537a832580dcdd1660 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Feb 2008 23:28:33 -0600 Subject: [PATCH 110/317] improve the db protocol and update sqlite to use it --- extra/db/db.factor | 58 ++++++++++++++------------- extra/db/postgresql/postgresql.factor | 47 ++++++++++++---------- extra/db/sqlite/sqlite-tests.factor | 41 +++++++++++-------- extra/db/sqlite/sqlite.factor | 49 ++++++++++++---------- 4 files changed, 108 insertions(+), 87 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 597ac1f0f3..813ce901ff 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -12,30 +12,20 @@ C: db ( handle -- obj ) GENERIC: db-open ( db -- ) GENERIC: db-close ( db -- ) -TUPLE: statement sql params handle bound? n max ; +TUPLE: statement sql params handle bound? ; TUPLE: simple-statement ; -TUPLE: bound-statement ; TUPLE: prepared-statement ; -TUPLE: prepared-bound-statement ; HOOK: db ( str -- statement ) -HOOK: db ( str obj -- statement ) HOOK: db ( str -- statement ) -HOOK: db ( str obj -- statement ) - -! TUPLE: result sql params handle n max ; - -GENERIC: #rows ( statement -- n ) -GENERIC: #columns ( statement -- n ) -GENERIC# row-column 1 ( statement n -- obj ) -GENERIC: advance-row ( statement -- ? ) GENERIC: prepare-statement ( statement -- ) -GENERIC: reset-statement ( statement -- ) GENERIC: bind-statement* ( obj statement -- ) GENERIC: rebind-statement ( obj statement -- ) +GENERIC: execute-statement ( statement -- ) + : bind-statement ( obj statement -- ) 2dup dup statement-bound? [ rebind-statement @@ -45,7 +35,24 @@ GENERIC: rebind-statement ( obj statement -- ) tuck set-statement-params t swap set-statement-bound? ; -: sql-row ( statement -- seq ) +TUPLE: result-set sql params handle n max ; + +GENERIC: query-results ( query -- result-set ) + +GENERIC: #rows ( result-set -- n ) +GENERIC: #columns ( result-set -- n ) +GENERIC# row-column 1 ( result-set n -- obj ) +GENERIC: advance-row ( result-set -- ? ) + +: ( query handle tuple -- result-set ) + >r >r { statement-sql statement-params } get-slots r> + { + set-result-set-sql + set-result-set-params + set-result-set-handle + } result-set construct r> construct-delegate ; + +: sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; : query-each ( statement quot -- ) @@ -64,23 +71,20 @@ GENERIC: rebind-statement ( obj statement -- ) [ db swap with-variable ] curry with-disposal ] with-scope ; -: do-statement ( statement -- ) - [ advance-row drop ] with-disposal ; +: do-query ( query -- result-set ) + query-results [ [ sql-row ] query-map ] with-disposal ; -: do-query ( query -- rows ) - [ [ sql-row ] query-map ] with-disposal ; +: do-bound-query ( obj query -- rows ) + [ bind-statement ] keep do-query ; -: do-simple-query ( sql -- rows ) - do-query ; +: do-bound-command ( obj query -- rows ) + [ bind-statement ] keep execute-statement ; -: do-bound-query ( sql obj -- rows ) - do-query ; +: sql-query ( sql -- rows ) + [ do-query ] with-disposal ; -: do-simple-command ( sql -- ) - do-statement ; - -: do-bound-command ( sql obj -- ) - do-statement ; +: sql-command ( sql -- ) + [ execute-statement ] with-disposal ; SYMBOL: in-transaction HOOK: begin-transaction db ( -- ) diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index cd2c34682e..2ea1b3a1dc 100644 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -38,32 +38,41 @@ M: postgresql-db dispose ( db -- ) : with-postgresql ( host ust pass db quot -- ) >r r> with-disposal ; -M: postgresql-statement #rows ( statement -- n ) + +M: postgresql-result-set #rows ( statement -- n ) statement-handle PQntuples ; -M: postgresql-statement #columns ( statement -- n ) +M: postgresql-result-set #columns ( statement -- n ) statement-handle PQnfields ; -M: postgresql-statement row-column ( statement n -- obj ) +M: postgresql-result-set row-column ( statement n -- obj ) >r dup statement-handle swap statement-n r> PQgetvalue ; -: init-statement ( statement -- ) - dup statement-max [ - dup do-postgresql-statement over set-statement-handle - dup #rows over set-statement-max - -1 over set-statement-n + +: init-result-set ( result-set -- ) + dup result-set-max [ + dup do-postgresql-statement over set-result-set-handle + dup #rows over set-result-set-max + -1 over set-result-set-n ] unless drop ; -: increment-n ( statement -- n ) - dup statement-n 1+ dup rot set-statement-n ; +: increment-n ( result-set -- n ) + dup result-set-n 1+ dup rot set-result-set-n ; + +M: postgresql-result-set advance-row ( result-set -- ? ) + dup init-result-set + dup increment-n swap result-set-max >= ; -M: postgresql-statement advance-row ( statement -- ? ) - dup init-statement - dup increment-n swap statement-max >= ; M: postgresql-statement dispose ( query -- ) dup statement-handle PQclear - 0 0 rot { set-statement-n set-statement-max } set-slots ; + f swap set-statement-handle ; + +M: postgresql-result-set dispose ( result-set -- ) + dup result-set-handle PQclear + 0 0 f roll { + set-statement-n set-statement-max set-statement-handle + } set-slots ; M: postgresql-statement prepare-statement ( statement -- ) [ @@ -76,12 +85,6 @@ M: postgresql-db ( sql -- statement ) { set-statement-sql } statement construct ; -M: postgresql-db ( sql array -- statement ) - { set-statement-sql set-statement-params } statement construct - ; - M: postgresql-db ( sql -- statement ) - ; - -M: postgresql-db ( sql seq -- statement ) - ; + { set-statement-sql } statement construct + ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index 79e967de24..ef1bbfc262 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -26,20 +26,27 @@ IN: temporary { "John" "America" } { "Jane" "New Zealand" } } -] [ test.db [ "select * from person" do-simple-query ] with-sqlite ] unit-test +] [ + "extra/db/sqlite/test.db" resource-path [ + "select * from person" sql-query + ] with-sqlite +] unit-test [ { { "John" "America" } } ] [ - test.db [ + "extra/db/sqlite/test.db" resource-path [ "select * from person where name = :name and country = :country" - { { ":name" "Jane" } { ":country" "New Zealand" } } - dup [ sql-row ] query-map + [ + { { ":name" "Jane" } { ":country" "New Zealand" } } + over do-bound-query - { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless - { { ":name" "John" } { ":country" "America" } } over bind-statement + { { "Jane" "New Zealand" } } = + [ "test fails" throw ] unless - dup [ sql-row ] query-map swap dispose + { { ":name" "John" } { ":country" "America" } } + swap do-bound-query + ] with-disposal ] with-sqlite ] unit-test @@ -48,13 +55,13 @@ IN: temporary { "1" "John" "America" } { "2" "Jane" "New Zealand" } } -] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test [ ] [ "extra/db/sqlite/test.db" resource-path [ "insert into person(name, country) values('Jimmy', 'Canada')" - do-simple-command + sql-command ] with-sqlite ] unit-test @@ -64,13 +71,13 @@ IN: temporary { "2" "Jane" "New Zealand" } { "3" "Jimmy" "Canada" } } -] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test +] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test [ "extra/db/sqlite/test.db" resource-path [ [ - "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command - "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command "oops" throw ] with-transaction ] with-sqlite @@ -78,7 +85,7 @@ IN: temporary [ 3 ] [ "extra/db/sqlite/test.db" resource-path [ - "select * from person" do-simple-query length + "select * from person" sql-query length ] with-sqlite ] unit-test @@ -86,14 +93,16 @@ IN: temporary ] [ "extra/db/sqlite/test.db" resource-path [ [ - "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command - "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command ] with-transaction ] with-sqlite ] unit-test [ 5 ] [ "extra/db/sqlite/test.db" resource-path [ - "select * from person" do-simple-query length + "select * from person" sql-query length ] with-sqlite ] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index c5964ed599..8352d2e11f 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db db.sql hashtables -io.files kernel math math.parser namespaces prettyprint sequences -strings sqlite.lib tuples alien.c-types continuations -db.sqlite.lib db.sqlite.ffi ; +USING: alien arrays assocs classes compiler db db.sql +hashtables io.files kernel math math.parser namespaces +prettyprint sequences strings tuples alien.c-types +continuations db.sqlite.lib db.sqlite.ffi ; IN: db.sqlite TUPLE: sqlite-db path ; @@ -24,47 +24,52 @@ M: sqlite-db dispose ( obj -- ) TUPLE: sqlite-statement ; C: sqlite-statement +TUPLE: sqlite-result-set ; +: ( query -- sqlite-result-set ) + dup statement-handle sqlite-result-set ; + M: sqlite-db ( str -- obj ) ; -M: sqlite-db ( str -- obj ) - ; - M: sqlite-db ( str -- obj ) db get db-handle over sqlite-prepare { set-statement-sql set-statement-handle } statement construct [ set-delegate ] keep ; -M: sqlite-db ( str assoc -- obj ) - swap tuck bind-statement ; - M: sqlite-statement dispose ( statement -- ) statement-handle sqlite-finalize ; +M: sqlite-result-set dispose ( result-set -- ) + f swap set-result-set-handle ; + M: sqlite-statement bind-statement* ( assoc statement -- ) statement-handle swap sqlite-bind-assoc ; M: sqlite-statement rebind-statement ( assoc statement -- ) - dup reset-statement + dup statement-handle sqlite-reset statement-handle swap sqlite-bind-assoc ; -M: sqlite-statement #columns ( statement -- n ) - statement-handle sqlite-#columns ; +M: sqlite-statement execute-statement ( statement -- ) + statement-handle sqlite-next drop ; -M: sqlite-statement row-column ( statement n -- obj ) - >r statement-handle r> sqlite-column ; +M: sqlite-result-set #columns ( result-set -- n ) + result-set-handle sqlite-#columns ; -M: sqlite-statement advance-row ( statement -- ? ) - statement-handle sqlite-next ; +M: sqlite-result-set row-column ( result-set n -- obj ) + >r result-set-handle r> sqlite-column ; + +M: sqlite-result-set advance-row ( result-set -- handle ? ) + result-set-handle sqlite-next ; + +M: sqlite-statement query-results ( query -- result-set ) + dup statement-handle sqlite-result-set ; -M: sqlite-statement reset-statement ( statement -- ) - statement-handle sqlite-reset ; M: sqlite-db begin-transaction ( -- ) - "BEGIN" do-simple-command ; + "BEGIN" sql-command ; M: sqlite-db commit-transaction ( -- ) - "COMMIT" do-simple-command ; + "COMMIT" sql-command ; M: sqlite-db rollback-transaction ( -- ) - "ROLLBACK" do-simple-command ; + "ROLLBACK" sql-command ; From 55cfd30543091c74889b1c8a0ae9a3838377f783 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 2 Feb 2008 23:46:56 -0600 Subject: [PATCH 111/317] remove strings.lib from automata --- extra/automata/automata.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index 732033fb75..cd799d477e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser random arrays hashtables assocs sequences - vars strings.lib ; + vars ; IN: automata @@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ; ! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ; -! : stop-loop ( -- ) f >loop-flag ; \ No newline at end of file +! : stop-loop ( -- ) f >loop-flag ; From 1b03538caa28f37c4e56986c9e22eae9fcf4d966 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 Feb 2008 00:14:27 -0600 Subject: [PATCH 112/317] fix compile errors in sqlite --- extra/db/db.factor | 2 +- extra/db/sqlite/ffi/ffi.factor | 1 - extra/db/sqlite/lib/lib.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 813ce901ff..81d79eb695 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -77,7 +77,7 @@ GENERIC: advance-row ( result-set -- ? ) : do-bound-query ( obj query -- rows ) [ bind-statement ] keep do-query ; -: do-bound-command ( obj query -- rows ) +: do-bound-command ( obj query -- ) [ bind-statement ] keep execute-statement ; : sql-query ( sql -- rows ) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index 77a86a8a2d..609c597b35 100644 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -109,7 +109,6 @@ TYPEDEF: void sqlite3_stmt LIBRARY: sqlite FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ; -FUNCTION: int sqlite3_open_v2 ( char* filename, void* ppDb, int flags, char* zVfs ) ; FUNCTION: int sqlite3_close ( sqlite3* pDb ) ; FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ; FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 99cd9c1b9f..4e4f2ca508 100644 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -80,7 +80,7 @@ TUPLE: sqlite-error n message ; sqlite-step ] if ; -: sqlite-next ( prepared -- ) +: sqlite-next ( prepared -- ? ) sqlite3_step step-complete? ; : sqlite-each ( statement quot -- ) From 303cb0edc2efaedfab5d8e38cf7ab18a5a975d65 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 3 Feb 2008 03:48:08 -0600 Subject: [PATCH 113/317] Fix missing math.bitfields --- extra/x11/windows/windows.factor | 16 +--------------- extra/x11/xlib/xlib.factor | 22 +++++++++++----------- 2 files changed, 12 insertions(+), 26 deletions(-) diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor index b3220d44bd..f9158c2956 100755 --- a/extra/x11/windows/windows.factor +++ b/extra/x11/windows/windows.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.c-types hashtables kernel math math.vectors +USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields namespaces sequences x11.xlib x11.constants x11.glx ; IN: x11.windows @@ -12,7 +12,6 @@ IN: x11.windows XCreateColormap ; : event-mask ( -- n ) -<<<<<<< HEAD:extra/x11/windows/windows.factor { ExposureMask StructureNotifyMask @@ -26,19 +25,6 @@ IN: x11.windows LeaveWindowMask PropertyChangeMask } flags ; -======= - ExposureMask - StructureNotifyMask bitor - KeyPressMask bitor - KeyReleaseMask bitor - ButtonPressMask bitor - ButtonReleaseMask bitor - PointerMotionMask bitor - FocusChangeMask bitor - EnterWindowMask bitor - LeaveWindowMask bitor - PropertyChangeMask bitor ; ->>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor index 230b24c6d0..70006c9f64 100755 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -12,7 +12,7 @@ ! and note the section. USING: kernel arrays alien alien.c-types alien.syntax -math words sequences namespaces continuations ; +math math.bitfields words sequences namespaces continuations ; IN: x11.xlib LIBRARY: xlib @@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow ( ! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property -: USPosition 1 0 shift ; inline -: USSize 1 1 shift ; inline -: PPosition 1 2 shift ; inline -: PSize 1 3 shift ; inline -: PMinSize 1 4 shift ; inline -: PMaxSize 1 5 shift ; inline -: PResizeInc 1 6 shift ; inline -: PAspect 1 7 shift ; inline -: PBaseSize 1 8 shift ; inline -: PWinGravity 1 9 shift ; inline +: USPosition 1 0 shift ; inline +: USSize 1 1 shift ; inline +: PPosition 1 2 shift ; inline +: PSize 1 3 shift ; inline +: PMinSize 1 4 shift ; inline +: PMaxSize 1 5 shift ; inline +: PResizeInc 1 6 shift ; inline +: PAspect 1 7 shift ; inline +: PBaseSize 1 8 shift ; inline +: PWinGravity 1 9 shift ; inline : PAllHints { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable From 7a5d48cadb7c67c0859cd71879a68b7c58e355c7 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 3 Feb 2008 03:48:29 -0600 Subject: [PATCH 114/317] shuffle: add nrev --- extra/shuffle/shuffle.factor | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index f9f8b030a8..f139a4864e 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ; : 4drop ( a b c d -- ) 3drop drop ; inline : tuckd ( x y z -- z x y z ) 2 ntuck ; inline + +MACRO: nrev ( n -- quot ) + [ 1+ ] map + reverse + [ [ -nrot ] curry ] map concat ; From 8cfc644893a61e4cd807da2dea6a6019f7c175de Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 3 Feb 2008 03:48:58 -0600 Subject: [PATCH 115/317] sequences.lib: indices --- extra/sequences/lib/lib.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d784726754..65b0d1beb0 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -140,3 +140,13 @@ PRIVATE> : ?second ( seq -- second/f ) 1 swap ?nth ; inline : ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! List the positions of obj in seq + +: indices ( seq obj -- seq ) + >r dup length swap r> + [ = [ ] [ drop f ] if ] curry + 2map + [ ] subset ; From 1de4896c248f6f95767c4d75df3bd7ffc3130c32 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 3 Feb 2008 03:49:19 -0600 Subject: [PATCH 116/317] Add partial-apply --- extra/partial-apply/partial-apply.factor | 26 ++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 extra/partial-apply/partial-apply.factor diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor new file mode 100644 index 0000000000..0340e53025 --- /dev/null +++ b/extra/partial-apply/partial-apply.factor @@ -0,0 +1,26 @@ + +USING: kernel sequences quotations math parser + shuffle combinators.cleave combinators.lib sequences.lib ; + +IN: partial-apply + +! Basic conceptual implementation. Todo: get it to compile. + +: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ; + +SYMBOL: _ + +SYMBOL: ~ + +: blank-positions ( quot -- seq ) + [ length 2 - ] [ _ indices ] bi [ - ] map-with ; + +: partial-apply ( pattern -- quot ) + [ blank-positions length nrev ] + [ peek 1quotation ] + [ blank-positions ] + tri + [ apply-n ] each ; + +: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing + From c60338df7e82a1ac8ae1df3f7fd35470a48cdc86 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 Feb 2008 10:24:28 -0800 Subject: [PATCH 117/317] Fix bug in TextMate bundle when using the see or help commands on the first word on a line --- extra/bunny/model/model.factor | 1 - misc/Factor.tmbundle/Support/lib/tm_factor.rb | 2 +- 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index a19adcb782..e3df6bb26c 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -111,4 +111,3 @@ M: bunny-buffers dispose "1.5" { "GL_ARB_vertex_buffer_object" } has-gl-version-or-extensions? [ ] [ ] if ; - diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb index 54272e5e36..2775a12ae9 100644 --- a/misc/Factor.tmbundle/Support/lib/tm_factor.rb +++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb @@ -33,6 +33,6 @@ def doc_using_statements(document) end def line_current_word(line, point) - left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1 + left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length line[left..right] end From 1dbd54293c7775ebf866c9d415603b8d15a17eaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:19:07 -0600 Subject: [PATCH 118/317] Clean up generic words a little bit --- core/definitions/definitions-tests.factor | 2 +- core/generic/generic-docs.factor | 4 ++-- core/generic/generic.factor | 14 +++++--------- core/generic/math/math.factor | 4 ++-- core/slots/slots.factor | 2 +- core/syntax/syntax.factor | 2 +- 6 files changed, 12 insertions(+), 16 deletions(-) mode change 100644 => 100755 core/generic/math/math.factor diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 13172c0ada..a4cb4de902 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -11,7 +11,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + [ ] object \ generic-1 define-method ] with-compilation-unit [ ] [ diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9dfc40a869..f1cdae1c91 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax generic.math generic.standard words classes definitions kernel alien combinators sequences -math ; +math quotations ; IN: generic ARTICLE: "method-order" "Method precedence" @@ -154,7 +154,7 @@ HELP: with-methods $low-level-note ; HELP: define-method -{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } } +{ $values { "method" quotation } { "class" class } { "generic" generic } } { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; HELP: implementors diff --git a/core/generic/generic.factor b/core/generic/generic.factor index bde5fd31af..c75dd41d74 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -39,11 +39,6 @@ TUPLE: method loc def ; : ( def -- method ) { set-method-def } \ method construct ; -M: f method-def ; -M: f method-loc ; -M: quotation method-def ; -M: quotation method-loc drop f ; - : method ( class generic -- method/f ) "methods" word-prop at ; @@ -55,7 +50,7 @@ PREDICATE: pair method-spec : sort-methods ( assoc -- newassoc ) [ keys sort-classes ] keep - [ dupd at method-def 2array ] curry map ; + [ dupd at method-def ] curry { } map>assoc ; : methods ( word -- assoc ) "methods" word-prop sort-methods ; @@ -72,18 +67,19 @@ TUPLE: check-method class generic ; inline : define-method ( method class generic -- ) - >r bootstrap-word r> check-method + >r >r r> bootstrap-word r> check-method [ set-at ] with-methods ; ! Definition protocol M: method-spec where - dup first2 method method-loc [ ] [ second where ] ?if ; + dup first2 method [ method-loc ] [ second where ] ?if ; M: method-spec set-where first2 method set-method-loc ; M: method-spec definer drop \ M: \ ; ; -M: method-spec definition first2 method method-def ; +M: method-spec definition + first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) check-method [ delete-at ] with-methods ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor old mode 100644 new mode 100755 index 912ece3a30..d5079c5dfb --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -39,8 +39,8 @@ TUPLE: no-math-method left right generic ; \ no-math-method construct-boa throw ; : applicable-method ( generic class -- quot ) - over method method-def - [ ] [ [ no-math-method ] curry [ ] like ] ?if ; + over method + [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ; : object-method ( generic -- quot ) object bootstrap-word applicable-method ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index cd523b05c1..40f0dd3da1 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - over define-simple-generic -rot define-method ; + over define-simple-generic -rot define-method ; : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 006f1a225f..67799b92ea 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -126,7 +126,7 @@ IN: bootstrap.syntax f set-word location >r scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep + [ parse-definition -rot define-method ] 2keep 2array r> remember-definition ] define-syntax From d92361286da46186e4dd961dd03dde288e0b38c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:23:14 -0600 Subject: [PATCH 119/317] Add kill-process and flesh out inotify --- extra/io/launcher/launcher-docs.factor | 11 +++++++++++ extra/io/launcher/launcher.factor | 5 +++++ extra/io/unix/launcher/launcher.factor | 6 +++++- extra/io/unix/linux/linux.factor | 15 ++++++++++----- extra/io/windows/launcher/launcher.factor | 8 ++++++-- extra/unix/unix.factor | 7 ++++--- extra/windows/kernel32/kernel32.factor | 2 +- 7 files changed, 42 insertions(+), 12 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 072cfcf959..c30516a83f 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: kill-process +{ $values { "process" process } } +{ $description "Kills a running process. Does nothing if the process has already exited." } ; + +HELP: kill-process* +{ $values { "handle" "a process handle" } } +{ $contract "Kills a running process." } +{ $notes "User code should call " { $link kill-process } " intead." } ; + HELP: process { $class-description "A class representing an active or finished process." $nl @@ -166,6 +175,8 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +"Stopping processes:" +{ $subsection kill-process } "Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9fb24fb51a..09a77fe985 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +HOOK: kill-process* io-backend ( handle -- ) + +: kill-process ( process -- ) + process-handle [ kill-process* ] when* ; + HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0135b55a7e..030583dbe8 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser ) : setup-redirection ( -- ) +stdin+ get read-flags 0 redirect +stdout+ get write-flags 1 redirect - +stderr+ get write-flags 2 redirect ; + +stderr+ get dup +stdout+ get eq? + [ 1 2 dup2 ] [ write-flags 2 redirect ] if ; : spawn-process ( -- ) [ @@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid ) [ spawn-process ] [ ] with-fork ] with-descriptor ; +M: unix-io kill-process* ( pid -- ) + SIGTERM kill io-error ; + : open-pipe ( -- pair ) 2 "int" dup pipe zero? [ 2 c-int-array> ] [ drop f ] if ; diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 01d6159e45..9751cefe91 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -21,8 +21,11 @@ TUPLE: linux-monitor path wd callback ; TUPLE: inotify watches ; -: wd>path ( wd -- path ) - inotify get-global inotify-watches at linux-monitor-path ; +: watches ( -- assoc ) inotify get-global inotify-watches ; + +: wd>monitor ( wd -- monitor ) watches at ; + +: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; : ( -- port ) H{ } clone @@ -31,8 +34,6 @@ TUPLE: inotify watches ; : inotify-fd inotify get-global port-handle ; -: watches inotify get-global inotify-watches ; - : (add-watch) ( path mask -- wd ) inotify-fd -rot inotify_add_watch dup io-error ; @@ -105,9 +106,13 @@ M: linux-monitor dispose ( monitor -- ) inotify-event-len "inotify-event" heap-size + swap >r + r> ; +: wd>queue ( wd -- queue ) + inotify-event-wd wd>monitor monitor-queue ; + : parse-file-notifications ( i buffer -- ) 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ parse-file-notify changed-file + 2dup inotify-event@ dup inotify-event-wd wd>queue + [ parse-file-notify changed-file ] bind next-event parse-file-notifications ] if ; diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ec53d9152c..ad84be0825 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -48,10 +48,10 @@ TUPLE: CreateProcess-args } get-slots CreateProcess win32-error=0/f ; : escape-argument ( str -- newstr ) - [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; + CHAR: \s over member? [ "\"" swap "\"" 3append ] when ; : join-arguments ( args -- cmd-line ) - " " join ; + [ escape-argument ] map " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ @@ -162,6 +162,10 @@ M: windows-io run-process* ( desc -- handle ) ] with-descriptor ] with-destructors ; +M: windows-io kill-process* ( handle -- ) + PROCESS_INFORMATION-hProcess + 255 TerminateProcess win32-error=0/f ; + : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f5c484568e..bcfbb3a214 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -168,9 +168,10 @@ FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! wait and waitpid -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +FUNCTION: int kill ( pid_t pid, int sig ) ; ! Flags for waitpid diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 77c7666bfd..b0c2d85598 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -1453,7 +1453,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ; FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ; ! FUNCTION: SystemTimeToTzSpecificLocalTime ! FUNCTION: TerminateJobObject -! FUNCTION: TerminateProcess +FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ; ! FUNCTION: TerminateThread ! FUNCTION: TermsrvAppInstallMode ! FUNCTION: Thread32First From 9d0d371efc1159aa26f5350a305108968aad4a87 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:47:44 -0600 Subject: [PATCH 120/317] Minor fix for Windows +stderr+ = +stdout+ --- extra/io/windows/launcher/launcher.factor | 13 ++++++++++++- extra/windows/kernel32/kernel32.factor | 14 +++++++++++++- 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ad84be0825..3d0c2feac1 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -118,11 +118,22 @@ TUPLE: CreateProcess-args : inherited-stderr ( args -- handle ) drop STD_ERROR_HANDLE GetStdHandle ; +: duplicate-handle ( handle -- handle ) + GetCurrentProcess + swap + GetCurrentProcess + f [ + 0 + TRUE + DUPLICATE_SAME_ACCESS + DuplicateHandle win32-error=0/f + ] keep *void* ; + : redirect-stderr ( args -- handle ) +stderr+ get dup +stdout+ eq? [ drop - CreateProcess-args-lpStartupInfo + CreateProcess-args-lpStartupInfo duplicate-handle STARTUPINFO-hStdOutput ] [ GENERIC_WRITE CREATE_ALWAYS redirect diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index b0c2d85598..45bd6bfae9 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ; ! FUNCTION: DosPathToSessionPathA ! FUNCTION: DosPathToSessionPathW ! FUNCTION: DuplicateConsoleHandle -! FUNCTION: DuplicateHandle + +FUNCTION: BOOL DuplicateHandle ( + HANDLE hSourceProcessHandle, + HANDLE hSourceHandle, + HANDLE hTargetProcessHandle, + LPHANDLE lpTargetHandle, + DWORD dwDesiredAccess, + BOOL bInheritHandle, + DWORD dwOptions ) ; + +: DUPLICATE_CLOSE_SOURCE 1 ; +: DUPLICATE_SAME_ACCESS 2 ; + ! FUNCTION: EncodePointer ! FUNCTION: EncodeSystemPointer ! FUNCTION: EndUpdateResourceA From 62bbb0597ee1f9fd621f5eb6b34aa7af4f60e67c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 14:51:35 -0600 Subject: [PATCH 121/317] Fix dodgy memory management --- vm/os-genunix.c | 3 ++- vm/utilities.c | 7 ------- vm/utilities.h | 1 - 3 files changed, 2 insertions(+), 9 deletions(-) mode change 100644 => 100755 vm/os-genunix.c mode change 100644 => 100755 vm/utilities.c mode change 100644 => 100755 vm/utilities.h diff --git a/vm/os-genunix.c b/vm/os-genunix.c old mode 100644 new mode 100755 index 92598eec41..a0bd3e05ae --- a/vm/os-genunix.c +++ b/vm/os-genunix.c @@ -21,7 +21,8 @@ const char *default_image_path(void) if(!path) return "factor.image"; - char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1); + char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1); + memcpy(new_path,path,strlen(path) + 1); strcat(new_path,SUFFIX); return new_path; } diff --git a/vm/utilities.c b/vm/utilities.c old mode 100644 new mode 100755 index 60a4ecb268..ebc8e87977 --- a/vm/utilities.c +++ b/vm/utilities.c @@ -8,13 +8,6 @@ void *safe_malloc(size_t size) return ptr; } -void *safe_realloc(const void *ptr, size_t size) -{ - void *new_ptr = realloc((void *)ptr,size); - if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0); - return new_ptr; -} - F_CHAR *safe_strdup(const F_CHAR *str) { F_CHAR *ptr = STRDUP(str); diff --git a/vm/utilities.h b/vm/utilities.h old mode 100644 new mode 100755 index 483e395345..89a8ba57a3 --- a/vm/utilities.h +++ b/vm/utilities.h @@ -1,3 +1,2 @@ void *safe_malloc(size_t size); -void *safe_realloc(const void *ptr, size_t size); F_CHAR *safe_strdup(const F_CHAR *str); From bb1e06dd8d812db71bb802b0faa9d5fae70b0571 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 3 Feb 2008 15:06:31 -0600 Subject: [PATCH 122/317] add copyright notices update postgresql for new db protocol make unit tests pass --- extra/db/db.factor | 4 + extra/db/postgresql/ffi/ffi.factor | 4 +- extra/db/postgresql/lib/lib.factor | 60 +++------ extra/db/postgresql/postgresql-tests.factor | 128 ++++++++++++++------ extra/db/postgresql/postgresql.factor | 57 +++++---- extra/db/sqlite/lib/lib.factor | 22 +--- extra/db/sqlite/sqlite-tests.factor | 18 +-- extra/db/sqlite/sqlite.factor | 1 - 8 files changed, 161 insertions(+), 133 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 81d79eb695..b765924cd6 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -44,6 +44,10 @@ GENERIC: #columns ( result-set -- n ) GENERIC# row-column 1 ( result-set n -- obj ) GENERIC: advance-row ( result-set -- ? ) +: init-result-set ( result-set -- ) + dup #rows over set-result-set-max + -1 swap set-result-set-n ; + : ( query handle tuple -- result-set ) >r >r { statement-sql statement-params } get-slots r> { diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 368e2fbe77..dbaa70c625 100644 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -1,9 +1,7 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. - ! adapted from libpq-fe.h version 7.4.7 -! tested on debian linux with postgresql 7.4.7 -! Updated to 8.1 +! tested on debian linux with postgresql 8.1 USING: alien alien.syntax combinators system ; IN: db.postgresql.ffi diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor index 4b362f9931..a940a42ae4 100644 --- a/extra/db/postgresql/lib/lib.factor +++ b/extra/db/postgresql/lib/lib.factor @@ -1,13 +1,9 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: arrays continuations db io kernel math namespaces -quotations sequences db.postgresql.ffi ; +quotations sequences db.postgresql.ffi alien alien.c-types ; IN: db.postgresql.lib -SYMBOL: query-res - -: connect-postgres ( host port pgopts pgtty db user pass -- conn ) - PQsetdbLogin - dup PQstatus zero? [ "couldn't connect to database" throw ] unless ; - : postgresql-result-error-message ( res -- str/f ) dup zero? [ drop f @@ -28,45 +24,21 @@ SYMBOL: query-res PQresultStatus PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ; +: connect-postgres ( host port pgopts pgtty db user pass -- conn ) + PQsetdbLogin + dup PQstatus zero? [ postgresql-error-message throw ] unless ; + : do-postgresql-statement ( statement -- res ) db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [ dup postgresql-result-error-message swap PQclear throw ] unless ; -! : do-command ( str -- ) - ! 1quotation \ (do-command) add db get swap call ; - -! : prepare ( str quot word -- conn quot ) - ! rot 1quotation swap append swap append db get swap ; - -! : do-query ( str quot -- ) - ! [ (do-query) query-res set ] prepare catch - ! [ rethrow ] [ query-res get PQclear ] if* ; - -! : result>seq ( -- seq ) - ! query-res get [ PQnfields ] keep PQntuples - ! [ swap [ query-res get -rot PQgetvalue ] with map ] with map ; -! -! : print-table ( seq -- ) - ! [ [ write bl ] each "\n" write ] each ; - - - -! select * from animal where name = 'Simba' -! select * from animal where name = $1 - -! : (do-query) ( PGconn query -- PGresult* ) - ! ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK - ! ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK - ! PQexec dup postgresql-result-ok? [ - ! dup postgresql-error-message swap PQclear throw - ! ] unless ; - -! : (do-command) ( PGconn query -- PGresult* ) - ! [ (do-query) ] catch - ! [ - ! swap - ! "non-fatal error: " print - ! "\tQuery: " write "'" write write "'" print - ! "\t" write print - ! ] when* drop ; +: do-postgresql-bound-statement ( statement -- res ) + >r db get db-handle r> + [ statement-sql ] keep + [ statement-params length f ] keep + statement-params [ malloc-char-string ] map >c-void*-array + f f 0 PQexecParams + dup postgresql-result-ok? [ + dup postgresql-result-error-message swap PQclear throw + ] unless ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor index 438a80e2d8..c5a5155d12 100644 --- a/extra/db/postgresql/postgresql-tests.factor +++ b/extra/db/postgresql/postgresql-tests.factor @@ -2,53 +2,109 @@ ! Set username and password in the 'connect' word. USING: kernel db.postgresql alien continuations io prettyprint -sequences namespaces tools.test ; +sequences namespaces tools.test db ; IN: temporary -: test-connection ( host port pgopts pgtty db user pass -- bool ) - [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ; +IN: scratchpad +: test-db ( -- postgresql-db ) + "localhost" "postgres" "" "factor-test" ; +IN: temporary -[ ] [ "localhost" "" "" "" "factor-test" "postgres" "" test-connection ] unit-test +[ ] [ test-db [ ] with-db ] unit-test -[ ] [ "localhost" "postgres" "" "factor-test" [ ] with-db ] unit-test +[ ] [ + test-db [ + [ "drop table person;" sql-command ] catch drop + "create table person (name varchar(30), country varchar(30));" + sql-command -! just a basic demo + "insert into person values('John', 'America');" sql-command + "insert into person values('Jane', 'New Zealand');" sql-command + ] with-db +] unit-test -"localhost" "postgres" "" "factor-test" [ - [ ] [ "drop table animal" do-command ] unit-test +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + } +] [ + test-db [ + "select * from person" sql-query + ] with-db +] unit-test - [ ] [ "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command ] unit-test - - [ ] [ "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" - do-command ] unit-test +[ + { { "John" "America" } } +] [ + test-db [ + "select * from person where name = $1 and country = $2" + [ + { "Jane" "New Zealand" } + over do-bound-query - [ ] [ "select * from animal where name = 'Mufasa'" [ ] do-query ] unit-test - [ ] [ "select * from animal where name = 'Mufasa'" [ - result>seq length 1 = [ - "...there can only be one Mufasa..." throw - ] unless - ] do-query - ] unit-test + { { "Jane" "New Zealand" } } = + [ "test fails" throw ] unless - [ ] [ "insert into animal (species, name, age) values ('lion', 'Simba', 1)" - do-command ] unit-test + { "John" "America" } + swap do-bound-query + ] with-disposal + ] with-db +] unit-test - [ ] [ - "select * from animal" +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + } +] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + +[ +] [ + test-db [ + "insert into person(name, country) values('Jimmy', 'Canada')" + sql-command + ] with-db +] unit-test + +[ + { + { "John" "America" } + { "Jane" "New Zealand" } + { "Jimmy" "Canada" } + } +] [ test-db [ "select * from person" sql-query ] with-db ] unit-test + +[ + test-db [ [ - "Animal table:" print - result>seq print-table - ] do-query - ] unit-test + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "insert into person(name, country) values('Jose', 'Mexico')" sql-command + "oops" throw + ] with-transaction + ] with-db +] unit-test-fails - ! intentional errors - ! [ "select asdf from animal" - ! [ ] do-query ] catch [ "caught: " write print ] when* - ! "select asdf from animal" [ ] do-query - ! "aofijweafew" do-command -] with-db +[ 3 ] [ + test-db [ + "select * from person" sql-query length + ] with-db +] unit-test +[ +] [ + test-db [ + [ + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + "insert into person(name, country) values('Jose', 'Mexico')" + sql-command + ] with-transaction + ] with-db +] unit-test -"localhost" "postgres" "" "factor-test" [ - [ ] [ "drop table animal" do-command ] unit-test -] with-db +[ 5 ] [ + test-db [ + "select * from person" sql-query length + ] with-db +] unit-test diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index 2ea1b3a1dc..df778cc80d 100644 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -1,8 +1,5 @@ -! Copyright (C) 2007 Doug Coleman. +! Copyright (C) 2007, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -! adapted from libpq-fe.h version 7.4.7 -! tested on debian linux with postgresql 7.4.7 - USING: arrays assocs alien alien.syntax continuations io kernel math namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi ; @@ -10,6 +7,7 @@ IN: db.postgresql TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-statement ; +TUPLE: postgresql-result-set ; : ( statement -- postgresql-statement ) postgresql-statement construct-delegate ; @@ -38,31 +36,39 @@ M: postgresql-db dispose ( db -- ) : with-postgresql ( host ust pass db quot -- ) >r r> with-disposal ; +M: postgresql-statement bind-statement* ( seq statement -- ) + set-statement-params ; -M: postgresql-result-set #rows ( statement -- n ) - statement-handle PQntuples ; +M: postgresql-statement rebind-statement ( seq statement -- ) + bind-statement* ; -M: postgresql-result-set #columns ( statement -- n ) - statement-handle PQnfields ; +M: postgresql-result-set #rows ( result-set -- n ) + result-set-handle PQntuples ; -M: postgresql-result-set row-column ( statement n -- obj ) - >r dup statement-handle swap statement-n r> PQgetvalue ; +M: postgresql-result-set #columns ( result-set -- n ) + result-set-handle PQnfields ; +M: postgresql-result-set row-column ( result-set n -- obj ) + >r dup result-set-handle swap result-set-n r> PQgetvalue ; -: init-result-set ( result-set -- ) - dup result-set-max [ - dup do-postgresql-statement over set-result-set-handle - dup #rows over set-result-set-max - -1 over set-result-set-n - ] unless drop ; +M: postgresql-statement execute-statement ( statement -- ) + query-results dispose ; : increment-n ( result-set -- n ) dup result-set-n 1+ dup rot set-result-set-n ; -M: postgresql-result-set advance-row ( result-set -- ? ) - dup init-result-set - dup increment-n swap result-set-max >= ; +M: postgresql-statement query-results ( query -- result-set ) + dup statement-params [ + over [ bind-statement ] keep + do-postgresql-bound-statement + ] [ + dup do-postgresql-statement + ] if* + postgresql-result-set + dup init-result-set ; +M: postgresql-result-set advance-row ( result-set -- ? ) + dup increment-n swap result-set-max >= ; M: postgresql-statement dispose ( query -- ) dup statement-handle PQclear @@ -71,14 +77,14 @@ M: postgresql-statement dispose ( query -- ) M: postgresql-result-set dispose ( result-set -- ) dup result-set-handle PQclear 0 0 f roll { - set-statement-n set-statement-max set-statement-handle + set-result-set-n set-result-set-max set-result-set-handle } set-slots ; M: postgresql-statement prepare-statement ( statement -- ) [ >r db get db-handle "" r> dup statement-sql swap statement-params - dup assoc-size swap PQprepare postgresql-error + length f PQprepare postgresql-error ] keep set-statement-handle ; M: postgresql-db ( sql -- statement ) @@ -88,3 +94,12 @@ M: postgresql-db ( sql -- statement ) M: postgresql-db ( sql -- statement ) { set-statement-sql } statement construct ; + +M: postgresql-db begin-transaction ( -- ) + "BEGIN" sql-command ; + +M: postgresql-db commit-transaction ( -- ) + "COMMIT" sql-command ; + +M: postgresql-db rollback-transaction ( -- ) + "ROLLBACK" sql-command ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index 4e4f2ca508..e5f8425d92 100644 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types assocs kernel math math.parser sequences db.sqlite.ffi ; IN: db.sqlite.lib @@ -65,7 +67,6 @@ TUPLE: sqlite-error n message ; ! SQLITE_BLOB 4 ! SQLITE_NULL 5 - : step-complete? ( step-result -- bool ) dup SQLITE_ROW = [ drop f @@ -82,22 +83,3 @@ TUPLE: sqlite-error n message ; : sqlite-next ( prepared -- ? ) sqlite3_step step-complete? ; - -: sqlite-each ( statement quot -- ) - over sqlite3_step step-complete? [ - 2drop - ] [ - [ call ] 2keep sqlite-each - ] if ; inline - -DEFER: (sqlite-map) - -: (sqlite-map) ( statement quot seq -- ) - pick sqlite3_step step-complete? [ - 2nip - ] [ - >r 2dup call r> swap add (sqlite-map) - ] if ; - -: sqlite-map ( statement quot -- seq ) - { } (sqlite-map) ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index ef1bbfc262..f64b8d1104 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -5,12 +5,14 @@ IN: temporary ! "sqlite3 -init test.txt test.db" +IN: scratchpad : test.db "extra/db/sqlite/test.db" resource-path ; +IN: temporary : (create-db) ( -- str ) [ "sqlite3 -init " % - "extra/db/sqlite/test.txt" resource-path % + test.db % " " % test.db % ] "" make ; @@ -27,7 +29,7 @@ IN: temporary { "Jane" "New Zealand" } } ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ "select * from person" sql-query ] with-sqlite ] unit-test @@ -35,7 +37,7 @@ IN: temporary [ { { "John" "America" } } ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ "select * from person where name = :name and country = :country" [ { { ":name" "Jane" } { ":country" "New Zealand" } } @@ -59,7 +61,7 @@ IN: temporary [ ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command ] with-sqlite @@ -74,7 +76,7 @@ IN: temporary ] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ [ "insert into person(name, country) values('Jose', 'Mexico')" sql-command "insert into person(name, country) values('Jose', 'Mexico')" sql-command @@ -84,14 +86,14 @@ IN: temporary ] unit-test-fails [ 3 ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ "select * from person" sql-query length ] with-sqlite ] unit-test [ ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ [ "insert into person(name, country) values('Jose', 'Mexico')" sql-command @@ -102,7 +104,7 @@ IN: temporary ] unit-test [ 5 ] [ - "extra/db/sqlite/test.db" resource-path [ + test.db [ "select * from person" sql-query length ] with-sqlite ] unit-test diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 8352d2e11f..49462dcc50 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -64,7 +64,6 @@ M: sqlite-result-set advance-row ( result-set -- handle ? ) M: sqlite-statement query-results ( query -- result-set ) dup statement-handle sqlite-result-set ; - M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; From bae79b80e32cc2658dbd7c0f804f5c9ae0f2ec95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 15:14:48 -0600 Subject: [PATCH 123/317] Undo handle duplication --- extra/io/windows/launcher/launcher.factor | 14 +------------- 1 file changed, 1 insertion(+), 13 deletions(-) diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index 3d0c2feac1..f3f78fbb88 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -118,23 +118,11 @@ TUPLE: CreateProcess-args : inherited-stderr ( args -- handle ) drop STD_ERROR_HANDLE GetStdHandle ; -: duplicate-handle ( handle -- handle ) - GetCurrentProcess - swap - GetCurrentProcess - f [ - 0 - TRUE - DUPLICATE_SAME_ACCESS - DuplicateHandle win32-error=0/f - ] keep *void* ; - : redirect-stderr ( args -- handle ) +stderr+ get dup +stdout+ eq? [ drop - CreateProcess-args-lpStartupInfo duplicate-handle - STARTUPINFO-hStdOutput + CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput ] [ GENERIC_WRITE CREATE_ALWAYS redirect swap inherited-stderr ?closed From 4a0bb3b03278b0e4348875d4778c2ca6a82cf6d8 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 16:15:03 -0500 Subject: [PATCH 124/317] Solution to Project Euler problem 41 --- extra/project-euler/041/041.factor | 40 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 42 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/041/041.factor diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor new file mode 100644 index 0000000000..60017f39a1 --- /dev/null +++ b/extra/project-euler/041/041.factor @@ -0,0 +1,40 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.combinatorics math.parser math.primes sequences ; +IN: project-euler.041 + +! http://projecteuler.net/index.php?section=problems&id=41 + +! DESCRIPTION +! ----------- + +! We shall say that an n-digit number is pandigital if it makes use of all the +! digits 1 to n exactly once. For example, 2143 is a 4-digit pandigital and is +! also prime. + +! What is the largest n-digit pandigital prime that exists? + + +! SOLUTION +! -------- + +! Check 7-digit pandigitals because if the sum of the digits in any number add +! up to a multiple of three, then it is a multiple of three and can't be prime. +! I assumed there would be a 7-digit answer, but technically a higher 4-digit +! pandigital than the one given in the description was also possible. + +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 = 45 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 = 36 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28 *** not divisible by 3 *** +! 1 + 2 + 3 + 4 + 5 + 6 = 21 +! 1 + 2 + 3 + 4 + 5 = 15 +! 1 + 2 + 3 + 4 = 10 *** not divisible by 3 *** + +: euler041 ( -- answer ) + { 7 6 5 4 3 2 1 } all-permutations + [ 10 swap digits>integer ] map [ prime? ] find nip ; + +! [ euler041 ] 100 ave-time +! 107 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler041 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d89453eb14..3433fe7154 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.048 project-euler.067 project-euler.075 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.048 project-euler.067 project-euler.075 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 15:55:59 -0600 Subject: [PATCH 125/317] Fix Unix launcher --- extra/io/unix/launcher/launcher.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 030583dbe8..b44ac80159 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -57,8 +57,8 @@ MEMO: 'arguments' ( -- parser ) : setup-redirection ( -- ) +stdin+ get read-flags 0 redirect +stdout+ get write-flags 1 redirect - +stderr+ get dup +stdout+ get eq? - [ 1 2 dup2 ] [ write-flags 2 redirect ] if ; + +stderr+ get dup +stdout+ eq? + [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ; : spawn-process ( -- ) [ From 793c3ceb1f627d578fa510f272786cb3e10cc70f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 16:06:57 -0600 Subject: [PATCH 126/317] byte-length for bit-arrays --- core/alien/c-types/c-types.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 8ab703eb7e..1f0f6b121e 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays float-arrays arrays generator.registers assocs -kernel kernel.private libc math namespaces parser sequences -strings words assocs splitting math.parser cpu.architecture -alien alien.accessors quotations system compiler.units ; +USING: bit-arrays byte-arrays float-arrays arrays +generator.registers assocs kernel kernel.private libc math +namespaces parser sequences strings words assocs splitting +math.parser cpu.architecture alien alien.accessors quotations +system compiler.units ; IN: alien.c-types TUPLE: c-type @@ -109,10 +110,12 @@ M: c-type stack-size c-type-size ; GENERIC: byte-length ( seq -- n ) flushable -M: float-array byte-length length "double" heap-size * ; +M: bit-array byte-length length 7 + -3 shift ; M: byte-array byte-length length ; +M: float-array byte-length length "double" heap-size * ; + : c-getter ( name -- quot ) c-type c-type-getter [ [ "Cannot read struct fields with type" throw ] From d6185e224ad77ec30490086c101536bcdd4eed7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 16:13:57 -0600 Subject: [PATCH 127/317] Undo funny stuff --- extra/http/server/responders/responders.factor | 4 ++-- extra/unicode/case/case.factor | 9 --------- 2 files changed, 2 insertions(+), 11 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 6df52997e1..70503236f6 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib unicode.case ; +strings io.server vectors assocs.lib ; IN: http.server.responders @@ -14,7 +14,7 @@ SYMBOL: responders H{ } clone [ insert-at ] keep ; : print-header ( alist -- ) - [ swap >Upper-dashes write ": " write print ] multi-assoc-each nl ; + [ swap write ": " write print ] multi-assoc-each nl ; : response ( msg -- ) "HTTP/1.0 " write print ; diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index f244192a32..8129ec17f8 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -110,12 +110,3 @@ SYMBOL: locale ! Just casing locale, or overall? dup >title = ; : case-fold? ( string -- ? ) dup >case-fold = ; - - -: >Upper ( str -- str ) - dup empty? [ - unclip ch>upper 1string swap append - ] unless ; - -: >Upper-dashes ( str -- str ) - "-" split [ >Upper ] map "-" join ; From 170d8d8c51142f936a6ce6d2e39f9b0e9b965070 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 17:18:10 -0500 Subject: [PATCH 128/317] Fix common Project Euler word alpha-num --- extra/project-euler/022/022.factor | 10 +++------- extra/project-euler/common/common.factor | 6 +++++- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index e9b0b5fbcf..9c8866b736 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel math math.parser namespaces sequences sorting splitting - strings system vocabs ascii ; +USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -31,9 +30,6 @@ IN: project-euler.022 "extra/project-euler/022/names.txt" resource-path file-contents [ quotable? ] subset "," split ; -: alpha-value ( str -- n ) - [ string>digits sum ] keep length 9 * - ; - : name-scores ( seq -- seq ) dup length [ 1+ swap alpha-value * ] 2map ; @@ -43,9 +39,9 @@ PRIVATE> source-022 natural-sort name-scores sum ; ! [ euler022 ] 100 ave-time -! 59 ms run / 1 ms GC ave time - 100 trials +! 123 ms run / 4 ms GC ave time - 100 trials ! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 45 ms run / 1 ms GC ave time - 100 trials +! 93 ms run / 2 ms GC ave time - 100 trials MAIN: euler022 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 50adbe4953..99bb3169c4 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin math.matrices math.parser math.primes.factors math.ranges namespaces - sequences sorting ; + sequences sorting unicode.case ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -8,6 +8,7 @@ IN: project-euler.common ! Problems using each public word ! ------------------------------- +! alpha-value - #22, #42 ! cartesian-product - #4, #27, #29, #32, #33 ! collect-consecutive - #8, #11 ! log10 - #25, #134 @@ -52,6 +53,9 @@ IN: project-euler.common PRIVATE> +: alpha-value ( str -- n ) + >lower [ CHAR: a - 1+ ] sigma ; + : cartesian-product ( seq1 seq2 -- seq1xseq2 ) swap [ swap [ 2array ] map-with ] map-with concat ; From e7722c02b75252c9ba8456c1390c0db6b2d98860 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 17:28:57 -0600 Subject: [PATCH 129/317] Add unit test for float alignment --- core/compiler/test/alien.factor | 10 ++++++++++ vm/ffi_test.c | 5 +++++ vm/ffi_test.h | 4 ++++ 3 files changed, 19 insertions(+) mode change 100644 => 100755 vm/ffi_test.c mode change 100644 => 100755 vm/ffi_test.h diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index acb9a4a4fa..9416fd1415 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ; 3 ffi_test_35 ] unit-test +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + ! Test callbacks : callback-1 "void" { } "cdecl" [ ] alien-callback ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c old mode 100644 new mode 100755 index f6e70fd6ac..9cec5ccbad --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -245,3 +245,8 @@ double ffi_test_35(struct test_struct_11 x, int y) { return (x.x + x.y) * y; } + +double ffi_test_36(struct test_struct_12 x) +{ + return x.x; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h old mode 100644 new mode 100755 index 27e402b74f..aac5d32f93 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -57,3 +57,7 @@ struct test_struct_10 { float x; int y; }; DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y); struct test_struct_11 { int x; int y; }; DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); + +struct test_struct_12 { int a; double x; }; + +DLLEXPORT double ffi_test_36(struct test_struct_12 x); From c64fe3d07bfe6f91d22dcc586a81a289a82c255f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 18:42:45 -0500 Subject: [PATCH 130/317] Solution to Project Euler problem 42 --- extra/project-euler/012/012.factor | 3 - extra/project-euler/022/022.factor | 3 - extra/project-euler/042/042.factor | 74 ++++++++++++++++++++++++ extra/project-euler/042/words.txt | 1 + extra/project-euler/067/067.factor | 3 - extra/project-euler/common/common.factor | 4 ++ extra/project-euler/project-euler.factor | 5 +- 7 files changed, 82 insertions(+), 11 deletions(-) create mode 100644 extra/project-euler/042/042.factor create mode 100644 extra/project-euler/042/words.txt diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index 3d59549e69..583bad8f72 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -33,9 +33,6 @@ IN: project-euler.012 ! SOLUTION ! -------- -: nth-triangle ( n -- n ) - dup 1+ * 2 / ; - : euler012 ( -- answer ) 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 9c8866b736..5bd1797272 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -41,7 +41,4 @@ PRIVATE> ! [ euler022 ] 100 ave-time ! 123 ms run / 4 ms GC ave time - 100 trials -! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 93 ms run / 2 ms GC ave time - 100 trials - MAIN: euler022 diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor new file mode 100644 index 0000000000..3d5f271374 --- /dev/null +++ b/extra/project-euler/042/042.factor @@ -0,0 +1,74 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: ascii combinators.lib io.files kernel math namespaces + project-euler.common sequences splitting ; +IN: project-euler.042 + +! http://projecteuler.net/index.php?section=problems&id=42 + +! DESCRIPTION +! ----------- + +! The nth term of the sequence of triangle numbers is given by, +! tn = n * (n + 1) / 2; so the first ten triangle numbers are: + +! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ... + +! By converting each letter in a word to a number corresponding to its +! alphabetical position and adding these values we form a word value. For +! example, the word value for SKY is 19 + 11 + 25 = 55 = t10. If the word value +! is a triangle number then we shall call the word a triangle word. + +! Using words.txt (right click and 'Save Link/Target As...'), a 16K text file +! containing nearly two-thousand common English words, how many are triangle +! words? + + +! SOLUTION +! -------- + + [ + dup nth-triangle , 1+ (triangle-upto) + ] [ + 2drop + ] if ; + +: triangle-upto ( n -- seq ) + [ 1 (triangle-upto) ] { } make ; + +PRIVATE> + +: euler042 ( -- answer ) + source-042 [ alpha-value ] map dup supremum + triangle-upto [ member? ] curry count ; + +! [ euler042 ] 100 ave-time +! 27 ms run / 1 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use the inverse function of n * (n + 1) / 2 and test if the result is an integer + + + +: euler042a ( -- answer ) + source-042 [ alpha-value ] map [ triangle? ] count ; + +! [ euler042a ] 100 ave-time +! 25 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler042a diff --git a/extra/project-euler/042/words.txt b/extra/project-euler/042/words.txt new file mode 100644 index 0000000000..7177624d41 --- /dev/null +++ b/extra/project-euler/042/words.txt @@ -0,0 +1 @@ +"A","ABILITY","ABLE","ABOUT","ABOVE","ABSENCE","ABSOLUTELY","ACADEMIC","ACCEPT","ACCESS","ACCIDENT","ACCOMPANY","ACCORDING","ACCOUNT","ACHIEVE","ACHIEVEMENT","ACID","ACQUIRE","ACROSS","ACT","ACTION","ACTIVE","ACTIVITY","ACTUAL","ACTUALLY","ADD","ADDITION","ADDITIONAL","ADDRESS","ADMINISTRATION","ADMIT","ADOPT","ADULT","ADVANCE","ADVANTAGE","ADVICE","ADVISE","AFFAIR","AFFECT","AFFORD","AFRAID","AFTER","AFTERNOON","AFTERWARDS","AGAIN","AGAINST","AGE","AGENCY","AGENT","AGO","AGREE","AGREEMENT","AHEAD","AID","AIM","AIR","AIRCRAFT","ALL","ALLOW","ALMOST","ALONE","ALONG","ALREADY","ALRIGHT","ALSO","ALTERNATIVE","ALTHOUGH","ALWAYS","AMONG","AMONGST","AMOUNT","AN","ANALYSIS","ANCIENT","AND","ANIMAL","ANNOUNCE","ANNUAL","ANOTHER","ANSWER","ANY","ANYBODY","ANYONE","ANYTHING","ANYWAY","APART","APPARENT","APPARENTLY","APPEAL","APPEAR","APPEARANCE","APPLICATION","APPLY","APPOINT","APPOINTMENT","APPROACH","APPROPRIATE","APPROVE","AREA","ARGUE","ARGUMENT","ARISE","ARM","ARMY","AROUND","ARRANGE","ARRANGEMENT","ARRIVE","ART","ARTICLE","ARTIST","AS","ASK","ASPECT","ASSEMBLY","ASSESS","ASSESSMENT","ASSET","ASSOCIATE","ASSOCIATION","ASSUME","ASSUMPTION","AT","ATMOSPHERE","ATTACH","ATTACK","ATTEMPT","ATTEND","ATTENTION","ATTITUDE","ATTRACT","ATTRACTIVE","AUDIENCE","AUTHOR","AUTHORITY","AVAILABLE","AVERAGE","AVOID","AWARD","AWARE","AWAY","AYE","BABY","BACK","BACKGROUND","BAD","BAG","BALANCE","BALL","BAND","BANK","BAR","BASE","BASIC","BASIS","BATTLE","BE","BEAR","BEAT","BEAUTIFUL","BECAUSE","BECOME","BED","BEDROOM","BEFORE","BEGIN","BEGINNING","BEHAVIOUR","BEHIND","BELIEF","BELIEVE","BELONG","BELOW","BENEATH","BENEFIT","BESIDE","BEST","BETTER","BETWEEN","BEYOND","BIG","BILL","BIND","BIRD","BIRTH","BIT","BLACK","BLOCK","BLOOD","BLOODY","BLOW","BLUE","BOARD","BOAT","BODY","BONE","BOOK","BORDER","BOTH","BOTTLE","BOTTOM","BOX","BOY","BRAIN","BRANCH","BREAK","BREATH","BRIDGE","BRIEF","BRIGHT","BRING","BROAD","BROTHER","BUDGET","BUILD","BUILDING","BURN","BUS","BUSINESS","BUSY","BUT","BUY","BY","CABINET","CALL","CAMPAIGN","CAN","CANDIDATE","CAPABLE","CAPACITY","CAPITAL","CAR","CARD","CARE","CAREER","CAREFUL","CAREFULLY","CARRY","CASE","CASH","CAT","CATCH","CATEGORY","CAUSE","CELL","CENTRAL","CENTRE","CENTURY","CERTAIN","CERTAINLY","CHAIN","CHAIR","CHAIRMAN","CHALLENGE","CHANCE","CHANGE","CHANNEL","CHAPTER","CHARACTER","CHARACTERISTIC","CHARGE","CHEAP","CHECK","CHEMICAL","CHIEF","CHILD","CHOICE","CHOOSE","CHURCH","CIRCLE","CIRCUMSTANCE","CITIZEN","CITY","CIVIL","CLAIM","CLASS","CLEAN","CLEAR","CLEARLY","CLIENT","CLIMB","CLOSE","CLOSELY","CLOTHES","CLUB","COAL","CODE","COFFEE","COLD","COLLEAGUE","COLLECT","COLLECTION","COLLEGE","COLOUR","COMBINATION","COMBINE","COME","COMMENT","COMMERCIAL","COMMISSION","COMMIT","COMMITMENT","COMMITTEE","COMMON","COMMUNICATION","COMMUNITY","COMPANY","COMPARE","COMPARISON","COMPETITION","COMPLETE","COMPLETELY","COMPLEX","COMPONENT","COMPUTER","CONCENTRATE","CONCENTRATION","CONCEPT","CONCERN","CONCERNED","CONCLUDE","CONCLUSION","CONDITION","CONDUCT","CONFERENCE","CONFIDENCE","CONFIRM","CONFLICT","CONGRESS","CONNECT","CONNECTION","CONSEQUENCE","CONSERVATIVE","CONSIDER","CONSIDERABLE","CONSIDERATION","CONSIST","CONSTANT","CONSTRUCTION","CONSUMER","CONTACT","CONTAIN","CONTENT","CONTEXT","CONTINUE","CONTRACT","CONTRAST","CONTRIBUTE","CONTRIBUTION","CONTROL","CONVENTION","CONVERSATION","COPY","CORNER","CORPORATE","CORRECT","COS","COST","COULD","COUNCIL","COUNT","COUNTRY","COUNTY","COUPLE","COURSE","COURT","COVER","CREATE","CREATION","CREDIT","CRIME","CRIMINAL","CRISIS","CRITERION","CRITICAL","CRITICISM","CROSS","CROWD","CRY","CULTURAL","CULTURE","CUP","CURRENT","CURRENTLY","CURRICULUM","CUSTOMER","CUT","DAMAGE","DANGER","DANGEROUS","DARK","DATA","DATE","DAUGHTER","DAY","DEAD","DEAL","DEATH","DEBATE","DEBT","DECADE","DECIDE","DECISION","DECLARE","DEEP","DEFENCE","DEFENDANT","DEFINE","DEFINITION","DEGREE","DELIVER","DEMAND","DEMOCRATIC","DEMONSTRATE","DENY","DEPARTMENT","DEPEND","DEPUTY","DERIVE","DESCRIBE","DESCRIPTION","DESIGN","DESIRE","DESK","DESPITE","DESTROY","DETAIL","DETAILED","DETERMINE","DEVELOP","DEVELOPMENT","DEVICE","DIE","DIFFERENCE","DIFFERENT","DIFFICULT","DIFFICULTY","DINNER","DIRECT","DIRECTION","DIRECTLY","DIRECTOR","DISAPPEAR","DISCIPLINE","DISCOVER","DISCUSS","DISCUSSION","DISEASE","DISPLAY","DISTANCE","DISTINCTION","DISTRIBUTION","DISTRICT","DIVIDE","DIVISION","DO","DOCTOR","DOCUMENT","DOG","DOMESTIC","DOOR","DOUBLE","DOUBT","DOWN","DRAW","DRAWING","DREAM","DRESS","DRINK","DRIVE","DRIVER","DROP","DRUG","DRY","DUE","DURING","DUTY","EACH","EAR","EARLY","EARN","EARTH","EASILY","EAST","EASY","EAT","ECONOMIC","ECONOMY","EDGE","EDITOR","EDUCATION","EDUCATIONAL","EFFECT","EFFECTIVE","EFFECTIVELY","EFFORT","EGG","EITHER","ELDERLY","ELECTION","ELEMENT","ELSE","ELSEWHERE","EMERGE","EMPHASIS","EMPLOY","EMPLOYEE","EMPLOYER","EMPLOYMENT","EMPTY","ENABLE","ENCOURAGE","END","ENEMY","ENERGY","ENGINE","ENGINEERING","ENJOY","ENOUGH","ENSURE","ENTER","ENTERPRISE","ENTIRE","ENTIRELY","ENTITLE","ENTRY","ENVIRONMENT","ENVIRONMENTAL","EQUAL","EQUALLY","EQUIPMENT","ERROR","ESCAPE","ESPECIALLY","ESSENTIAL","ESTABLISH","ESTABLISHMENT","ESTATE","ESTIMATE","EVEN","EVENING","EVENT","EVENTUALLY","EVER","EVERY","EVERYBODY","EVERYONE","EVERYTHING","EVIDENCE","EXACTLY","EXAMINATION","EXAMINE","EXAMPLE","EXCELLENT","EXCEPT","EXCHANGE","EXECUTIVE","EXERCISE","EXHIBITION","EXIST","EXISTENCE","EXISTING","EXPECT","EXPECTATION","EXPENDITURE","EXPENSE","EXPENSIVE","EXPERIENCE","EXPERIMENT","EXPERT","EXPLAIN","EXPLANATION","EXPLORE","EXPRESS","EXPRESSION","EXTEND","EXTENT","EXTERNAL","EXTRA","EXTREMELY","EYE","FACE","FACILITY","FACT","FACTOR","FACTORY","FAIL","FAILURE","FAIR","FAIRLY","FAITH","FALL","FAMILIAR","FAMILY","FAMOUS","FAR","FARM","FARMER","FASHION","FAST","FATHER","FAVOUR","FEAR","FEATURE","FEE","FEEL","FEELING","FEMALE","FEW","FIELD","FIGHT","FIGURE","FILE","FILL","FILM","FINAL","FINALLY","FINANCE","FINANCIAL","FIND","FINDING","FINE","FINGER","FINISH","FIRE","FIRM","FIRST","FISH","FIT","FIX","FLAT","FLIGHT","FLOOR","FLOW","FLOWER","FLY","FOCUS","FOLLOW","FOLLOWING","FOOD","FOOT","FOOTBALL","FOR","FORCE","FOREIGN","FOREST","FORGET","FORM","FORMAL","FORMER","FORWARD","FOUNDATION","FREE","FREEDOM","FREQUENTLY","FRESH","FRIEND","FROM","FRONT","FRUIT","FUEL","FULL","FULLY","FUNCTION","FUND","FUNNY","FURTHER","FUTURE","GAIN","GAME","GARDEN","GAS","GATE","GATHER","GENERAL","GENERALLY","GENERATE","GENERATION","GENTLEMAN","GET","GIRL","GIVE","GLASS","GO","GOAL","GOD","GOLD","GOOD","GOVERNMENT","GRANT","GREAT","GREEN","GREY","GROUND","GROUP","GROW","GROWING","GROWTH","GUEST","GUIDE","GUN","HAIR","HALF","HALL","HAND","HANDLE","HANG","HAPPEN","HAPPY","HARD","HARDLY","HATE","HAVE","HE","HEAD","HEALTH","HEAR","HEART","HEAT","HEAVY","HELL","HELP","HENCE","HER","HERE","HERSELF","HIDE","HIGH","HIGHLY","HILL","HIM","HIMSELF","HIS","HISTORICAL","HISTORY","HIT","HOLD","HOLE","HOLIDAY","HOME","HOPE","HORSE","HOSPITAL","HOT","HOTEL","HOUR","HOUSE","HOUSEHOLD","HOUSING","HOW","HOWEVER","HUGE","HUMAN","HURT","HUSBAND","I","IDEA","IDENTIFY","IF","IGNORE","ILLUSTRATE","IMAGE","IMAGINE","IMMEDIATE","IMMEDIATELY","IMPACT","IMPLICATION","IMPLY","IMPORTANCE","IMPORTANT","IMPOSE","IMPOSSIBLE","IMPRESSION","IMPROVE","IMPROVEMENT","IN","INCIDENT","INCLUDE","INCLUDING","INCOME","INCREASE","INCREASED","INCREASINGLY","INDEED","INDEPENDENT","INDEX","INDICATE","INDIVIDUAL","INDUSTRIAL","INDUSTRY","INFLUENCE","INFORM","INFORMATION","INITIAL","INITIATIVE","INJURY","INSIDE","INSIST","INSTANCE","INSTEAD","INSTITUTE","INSTITUTION","INSTRUCTION","INSTRUMENT","INSURANCE","INTEND","INTENTION","INTEREST","INTERESTED","INTERESTING","INTERNAL","INTERNATIONAL","INTERPRETATION","INTERVIEW","INTO","INTRODUCE","INTRODUCTION","INVESTIGATE","INVESTIGATION","INVESTMENT","INVITE","INVOLVE","IRON","IS","ISLAND","ISSUE","IT","ITEM","ITS","ITSELF","JOB","JOIN","JOINT","JOURNEY","JUDGE","JUMP","JUST","JUSTICE","KEEP","KEY","KID","KILL","KIND","KING","KITCHEN","KNEE","KNOW","KNOWLEDGE","LABOUR","LACK","LADY","LAND","LANGUAGE","LARGE","LARGELY","LAST","LATE","LATER","LATTER","LAUGH","LAUNCH","LAW","LAWYER","LAY","LEAD","LEADER","LEADERSHIP","LEADING","LEAF","LEAGUE","LEAN","LEARN","LEAST","LEAVE","LEFT","LEG","LEGAL","LEGISLATION","LENGTH","LESS","LET","LETTER","LEVEL","LIABILITY","LIBERAL","LIBRARY","LIE","LIFE","LIFT","LIGHT","LIKE","LIKELY","LIMIT","LIMITED","LINE","LINK","LIP","LIST","LISTEN","LITERATURE","LITTLE","LIVE","LIVING","LOAN","LOCAL","LOCATION","LONG","LOOK","LORD","LOSE","LOSS","LOT","LOVE","LOVELY","LOW","LUNCH","MACHINE","MAGAZINE","MAIN","MAINLY","MAINTAIN","MAJOR","MAJORITY","MAKE","MALE","MAN","MANAGE","MANAGEMENT","MANAGER","MANNER","MANY","MAP","MARK","MARKET","MARRIAGE","MARRIED","MARRY","MASS","MASTER","MATCH","MATERIAL","MATTER","MAY","MAYBE","ME","MEAL","MEAN","MEANING","MEANS","MEANWHILE","MEASURE","MECHANISM","MEDIA","MEDICAL","MEET","MEETING","MEMBER","MEMBERSHIP","MEMORY","MENTAL","MENTION","MERELY","MESSAGE","METAL","METHOD","MIDDLE","MIGHT","MILE","MILITARY","MILK","MIND","MINE","MINISTER","MINISTRY","MINUTE","MISS","MISTAKE","MODEL","MODERN","MODULE","MOMENT","MONEY","MONTH","MORE","MORNING","MOST","MOTHER","MOTION","MOTOR","MOUNTAIN","MOUTH","MOVE","MOVEMENT","MUCH","MURDER","MUSEUM","MUSIC","MUST","MY","MYSELF","NAME","NARROW","NATION","NATIONAL","NATURAL","NATURE","NEAR","NEARLY","NECESSARILY","NECESSARY","NECK","NEED","NEGOTIATION","NEIGHBOUR","NEITHER","NETWORK","NEVER","NEVERTHELESS","NEW","NEWS","NEWSPAPER","NEXT","NICE","NIGHT","NO","NOBODY","NOD","NOISE","NONE","NOR","NORMAL","NORMALLY","NORTH","NORTHERN","NOSE","NOT","NOTE","NOTHING","NOTICE","NOTION","NOW","NUCLEAR","NUMBER","NURSE","OBJECT","OBJECTIVE","OBSERVATION","OBSERVE","OBTAIN","OBVIOUS","OBVIOUSLY","OCCASION","OCCUR","ODD","OF","OFF","OFFENCE","OFFER","OFFICE","OFFICER","OFFICIAL","OFTEN","OIL","OKAY","OLD","ON","ONCE","ONE","ONLY","ONTO","OPEN","OPERATE","OPERATION","OPINION","OPPORTUNITY","OPPOSITION","OPTION","OR","ORDER","ORDINARY","ORGANISATION","ORGANISE","ORGANIZATION","ORIGIN","ORIGINAL","OTHER","OTHERWISE","OUGHT","OUR","OURSELVES","OUT","OUTCOME","OUTPUT","OUTSIDE","OVER","OVERALL","OWN","OWNER","PACKAGE","PAGE","PAIN","PAINT","PAINTING","PAIR","PANEL","PAPER","PARENT","PARK","PARLIAMENT","PART","PARTICULAR","PARTICULARLY","PARTLY","PARTNER","PARTY","PASS","PASSAGE","PAST","PATH","PATIENT","PATTERN","PAY","PAYMENT","PEACE","PENSION","PEOPLE","PER","PERCENT","PERFECT","PERFORM","PERFORMANCE","PERHAPS","PERIOD","PERMANENT","PERSON","PERSONAL","PERSUADE","PHASE","PHONE","PHOTOGRAPH","PHYSICAL","PICK","PICTURE","PIECE","PLACE","PLAN","PLANNING","PLANT","PLASTIC","PLATE","PLAY","PLAYER","PLEASE","PLEASURE","PLENTY","PLUS","POCKET","POINT","POLICE","POLICY","POLITICAL","POLITICS","POOL","POOR","POPULAR","POPULATION","POSITION","POSITIVE","POSSIBILITY","POSSIBLE","POSSIBLY","POST","POTENTIAL","POUND","POWER","POWERFUL","PRACTICAL","PRACTICE","PREFER","PREPARE","PRESENCE","PRESENT","PRESIDENT","PRESS","PRESSURE","PRETTY","PREVENT","PREVIOUS","PREVIOUSLY","PRICE","PRIMARY","PRIME","PRINCIPLE","PRIORITY","PRISON","PRISONER","PRIVATE","PROBABLY","PROBLEM","PROCEDURE","PROCESS","PRODUCE","PRODUCT","PRODUCTION","PROFESSIONAL","PROFIT","PROGRAM","PROGRAMME","PROGRESS","PROJECT","PROMISE","PROMOTE","PROPER","PROPERLY","PROPERTY","PROPORTION","PROPOSE","PROPOSAL","PROSPECT","PROTECT","PROTECTION","PROVE","PROVIDE","PROVIDED","PROVISION","PUB","PUBLIC","PUBLICATION","PUBLISH","PULL","PUPIL","PURPOSE","PUSH","PUT","QUALITY","QUARTER","QUESTION","QUICK","QUICKLY","QUIET","QUITE","RACE","RADIO","RAILWAY","RAIN","RAISE","RANGE","RAPIDLY","RARE","RATE","RATHER","REACH","REACTION","READ","READER","READING","READY","REAL","REALISE","REALITY","REALIZE","REALLY","REASON","REASONABLE","RECALL","RECEIVE","RECENT","RECENTLY","RECOGNISE","RECOGNITION","RECOGNIZE","RECOMMEND","RECORD","RECOVER","RED","REDUCE","REDUCTION","REFER","REFERENCE","REFLECT","REFORM","REFUSE","REGARD","REGION","REGIONAL","REGULAR","REGULATION","REJECT","RELATE","RELATION","RELATIONSHIP","RELATIVE","RELATIVELY","RELEASE","RELEVANT","RELIEF","RELIGION","RELIGIOUS","RELY","REMAIN","REMEMBER","REMIND","REMOVE","REPEAT","REPLACE","REPLY","REPORT","REPRESENT","REPRESENTATION","REPRESENTATIVE","REQUEST","REQUIRE","REQUIREMENT","RESEARCH","RESOURCE","RESPECT","RESPOND","RESPONSE","RESPONSIBILITY","RESPONSIBLE","REST","RESTAURANT","RESULT","RETAIN","RETURN","REVEAL","REVENUE","REVIEW","REVOLUTION","RICH","RIDE","RIGHT","RING","RISE","RISK","RIVER","ROAD","ROCK","ROLE","ROLL","ROOF","ROOM","ROUND","ROUTE","ROW","ROYAL","RULE","RUN","RURAL","SAFE","SAFETY","SALE","SAME","SAMPLE","SATISFY","SAVE","SAY","SCALE","SCENE","SCHEME","SCHOOL","SCIENCE","SCIENTIFIC","SCIENTIST","SCORE","SCREEN","SEA","SEARCH","SEASON","SEAT","SECOND","SECONDARY","SECRETARY","SECTION","SECTOR","SECURE","SECURITY","SEE","SEEK","SEEM","SELECT","SELECTION","SELL","SEND","SENIOR","SENSE","SENTENCE","SEPARATE","SEQUENCE","SERIES","SERIOUS","SERIOUSLY","SERVANT","SERVE","SERVICE","SESSION","SET","SETTLE","SETTLEMENT","SEVERAL","SEVERE","SEX","SEXUAL","SHAKE","SHALL","SHAPE","SHARE","SHE","SHEET","SHIP","SHOE","SHOOT","SHOP","SHORT","SHOT","SHOULD","SHOULDER","SHOUT","SHOW","SHUT","SIDE","SIGHT","SIGN","SIGNAL","SIGNIFICANCE","SIGNIFICANT","SILENCE","SIMILAR","SIMPLE","SIMPLY","SINCE","SING","SINGLE","SIR","SISTER","SIT","SITE","SITUATION","SIZE","SKILL","SKIN","SKY","SLEEP","SLIGHTLY","SLIP","SLOW","SLOWLY","SMALL","SMILE","SO","SOCIAL","SOCIETY","SOFT","SOFTWARE","SOIL","SOLDIER","SOLICITOR","SOLUTION","SOME","SOMEBODY","SOMEONE","SOMETHING","SOMETIMES","SOMEWHAT","SOMEWHERE","SON","SONG","SOON","SORRY","SORT","SOUND","SOURCE","SOUTH","SOUTHERN","SPACE","SPEAK","SPEAKER","SPECIAL","SPECIES","SPECIFIC","SPEECH","SPEED","SPEND","SPIRIT","SPORT","SPOT","SPREAD","SPRING","STAFF","STAGE","STAND","STANDARD","STAR","START","STATE","STATEMENT","STATION","STATUS","STAY","STEAL","STEP","STICK","STILL","STOCK","STONE","STOP","STORE","STORY","STRAIGHT","STRANGE","STRATEGY","STREET","STRENGTH","STRIKE","STRONG","STRONGLY","STRUCTURE","STUDENT","STUDIO","STUDY","STUFF","STYLE","SUBJECT","SUBSTANTIAL","SUCCEED","SUCCESS","SUCCESSFUL","SUCH","SUDDENLY","SUFFER","SUFFICIENT","SUGGEST","SUGGESTION","SUITABLE","SUM","SUMMER","SUN","SUPPLY","SUPPORT","SUPPOSE","SURE","SURELY","SURFACE","SURPRISE","SURROUND","SURVEY","SURVIVE","SWITCH","SYSTEM","TABLE","TAKE","TALK","TALL","TAPE","TARGET","TASK","TAX","TEA","TEACH","TEACHER","TEACHING","TEAM","TEAR","TECHNICAL","TECHNIQUE","TECHNOLOGY","TELEPHONE","TELEVISION","TELL","TEMPERATURE","TEND","TERM","TERMS","TERRIBLE","TEST","TEXT","THAN","THANK","THANKS","THAT","THE","THEATRE","THEIR","THEM","THEME","THEMSELVES","THEN","THEORY","THERE","THEREFORE","THESE","THEY","THIN","THING","THINK","THIS","THOSE","THOUGH","THOUGHT","THREAT","THREATEN","THROUGH","THROUGHOUT","THROW","THUS","TICKET","TIME","TINY","TITLE","TO","TODAY","TOGETHER","TOMORROW","TONE","TONIGHT","TOO","TOOL","TOOTH","TOP","TOTAL","TOTALLY","TOUCH","TOUR","TOWARDS","TOWN","TRACK","TRADE","TRADITION","TRADITIONAL","TRAFFIC","TRAIN","TRAINING","TRANSFER","TRANSPORT","TRAVEL","TREAT","TREATMENT","TREATY","TREE","TREND","TRIAL","TRIP","TROOP","TROUBLE","TRUE","TRUST","TRUTH","TRY","TURN","TWICE","TYPE","TYPICAL","UNABLE","UNDER","UNDERSTAND","UNDERSTANDING","UNDERTAKE","UNEMPLOYMENT","UNFORTUNATELY","UNION","UNIT","UNITED","UNIVERSITY","UNLESS","UNLIKELY","UNTIL","UP","UPON","UPPER","URBAN","US","USE","USED","USEFUL","USER","USUAL","USUALLY","VALUE","VARIATION","VARIETY","VARIOUS","VARY","VAST","VEHICLE","VERSION","VERY","VIA","VICTIM","VICTORY","VIDEO","VIEW","VILLAGE","VIOLENCE","VISION","VISIT","VISITOR","VITAL","VOICE","VOLUME","VOTE","WAGE","WAIT","WALK","WALL","WANT","WAR","WARM","WARN","WASH","WATCH","WATER","WAVE","WAY","WE","WEAK","WEAPON","WEAR","WEATHER","WEEK","WEEKEND","WEIGHT","WELCOME","WELFARE","WELL","WEST","WESTERN","WHAT","WHATEVER","WHEN","WHERE","WHEREAS","WHETHER","WHICH","WHILE","WHILST","WHITE","WHO","WHOLE","WHOM","WHOSE","WHY","WIDE","WIDELY","WIFE","WILD","WILL","WIN","WIND","WINDOW","WINE","WING","WINNER","WINTER","WISH","WITH","WITHDRAW","WITHIN","WITHOUT","WOMAN","WONDER","WONDERFUL","WOOD","WORD","WORK","WORKER","WORKING","WORKS","WORLD","WORRY","WORTH","WOULD","WRITE","WRITER","WRITING","WRONG","YARD","YEAH","YEAR","YES","YESTERDAY","YET","YOU","YOUNG","YOUR","YOURSELF","YOUTH" \ No newline at end of file diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 5df516f2f4..f206f59472 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -58,7 +58,4 @@ PRIVATE> ! [ euler067a ] 100 ave-time ! 14 ms run / 0 ms GC ave time - 100 trials -! source-067 [ max-path ] curry 100 ave-time -! 3 ms run / 0 ms GC ave time - 100 trials - MAIN: euler067a diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 99bb3169c4..0910cbcb7b 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -13,6 +13,7 @@ IN: project-euler.common ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 +! nth-triangle - #12, #42 ! number>digits - #16, #20, #30, #34 ! pandigital? - #32, #38 ! propagate-all - #18, #67 @@ -77,6 +78,9 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; +: nth-triangle ( n -- n ) + dup 1+ * 2 / ; + : pandigital? ( n -- ? ) number>string natural-sort "123456789" = ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 3433fe7154..226c47b0a3 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.048 project-euler.067 project-euler.075 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.067 + project-euler.075 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 15:59:47 -0800 Subject: [PATCH 131/317] Take the fattening opengl vocab and hack it up into smaller, mouth-sized morsels --- core/alien/c-types/c-types.factor | 3 + extra/bunny/authors.txt | 1 + extra/bunny/cel-shaded/cel-shaded.factor | 3 +- extra/bunny/model/model.factor | 3 +- extra/bunny/outlined/outlined.factor | 3 +- extra/bunny/tags.txt | 1 + extra/opengl/authors.txt | 1 + extra/opengl/capabilities/authors.txt | 1 + .../capabilities/capabilities-docs.factor | 59 +++++ extra/opengl/capabilities/capabilities.factor | 67 +++++ extra/opengl/capabilities/summary.txt | 1 + extra/opengl/capabilities/tags.txt | 2 + extra/opengl/framebuffers/authors.txt | 1 + .../framebuffers/framebuffer-docs.factor | 35 +++ extra/opengl/framebuffers/framebuffers.factor | 43 ++++ extra/opengl/framebuffers/summary.txt | 1 + extra/opengl/framebuffers/tags.txt | 2 + extra/opengl/opengl-docs.factor | 202 +-------------- extra/opengl/opengl.factor | 241 +----------------- extra/opengl/shaders/authors.txt | 1 + extra/opengl/shaders/shaders-docs.factor | 112 ++++++++ extra/opengl/shaders/shaders.factor | 134 ++++++++++ extra/opengl/shaders/summary.txt | 1 + extra/opengl/shaders/tags.txt | 3 + 24 files changed, 487 insertions(+), 434 deletions(-) create mode 100644 extra/opengl/capabilities/authors.txt create mode 100644 extra/opengl/capabilities/capabilities-docs.factor create mode 100644 extra/opengl/capabilities/capabilities.factor create mode 100644 extra/opengl/capabilities/summary.txt create mode 100644 extra/opengl/capabilities/tags.txt create mode 100644 extra/opengl/framebuffers/authors.txt create mode 100644 extra/opengl/framebuffers/framebuffer-docs.factor create mode 100644 extra/opengl/framebuffers/framebuffers.factor create mode 100644 extra/opengl/framebuffers/summary.txt create mode 100644 extra/opengl/framebuffers/tags.txt create mode 100644 extra/opengl/shaders/authors.txt create mode 100644 extra/opengl/shaders/shaders-docs.factor create mode 100644 extra/opengl/shaders/shaders.factor create mode 100644 extra/opengl/shaders/summary.txt create mode 100644 extra/opengl/shaders/tags.txt diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 8ab703eb7e..9bbd24351c 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -211,6 +211,9 @@ M: long-long-type box-return ( type -- ) over [ tuck 0 ] over c-setter append swap >r >r constructor-word r> r> add* define-inline ; +: c-bool> ( int -- ? ) + zero? not ; + : >c-array ( seq type word -- ) >r >r dup length dup r> dup -roll r> [ execute ] 2curry 2each ; inline diff --git a/extra/bunny/authors.txt b/extra/bunny/authors.txt index 1901f27a24..580f882c8d 100644 --- a/extra/bunny/authors.txt +++ b/extra/bunny/authors.txt @@ -1 +1,2 @@ Slava Pestov +Joe Groff diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor index fc42ca971e..37343a23fb 100644 --- a/extra/bunny/cel-shaded/cel-shaded.factor +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -1,5 +1,6 @@ USING: arrays bunny.model combinators.lib continuations -kernel multiline opengl opengl.gl sequences ; +kernel multiline opengl opengl.shaders opengl.capabilities +opengl.gl sequences ; IN: bunny.cel-shaded STRING: vertex-shader-source diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index e3df6bb26c..f2c93eac3e 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -1,6 +1,7 @@ USING: alien alien.c-types arrays sequences math math.vectors math.matrices math.parser io io.files kernel opengl -opengl.gl opengl.glu shuffle http.client vectors splitting +opengl.gl opengl.glu opengl.capabilities shuffle http.client +vectors splitting tools.time system combinators combinators.lib combinators.cleave float-arrays continuations namespaces ; IN: bunny.model diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor index 9de341561c..d7064ebdde 100644 --- a/extra/bunny/outlined/outlined.factor +++ b/extra/bunny/outlined/outlined.factor @@ -1,6 +1,7 @@ USING: arrays bunny.model bunny.cel-shaded combinators.lib continuations kernel math multiline -opengl opengl.gl sequences ui.gadgets ; +opengl opengl.shaders opengl.framebuffers opengl.gl +opengl.capabilities sequences ui.gadgets ; IN: bunny.outlined STRING: outlined-pass1-fragment-shader-main-source diff --git a/extra/bunny/tags.txt b/extra/bunny/tags.txt index cb5fc203e1..339115d3c7 100644 --- a/extra/bunny/tags.txt +++ b/extra/bunny/tags.txt @@ -1 +1,2 @@ demos +opengl diff --git a/extra/opengl/authors.txt b/extra/opengl/authors.txt index e1907c6d91..55ac3c728e 100644 --- a/extra/opengl/authors.txt +++ b/extra/opengl/authors.txt @@ -1,2 +1,3 @@ Slava Pestov Eduardo Cavazos +Joe Groff diff --git a/extra/opengl/capabilities/authors.txt b/extra/opengl/capabilities/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/capabilities/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor new file mode 100644 index 0000000000..e73b7a3f0b --- /dev/null +++ b/extra/opengl/capabilities/capabilities-docs.factor @@ -0,0 +1,59 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.capabilities + +HELP: gl-version +{ $values { "version" "The version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: gl-vendor-version +{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-gl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-gl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: glsl-version +{ $values { "version" "The GLSL version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: glsl-vendor-version +{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-glsl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-glsl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: gl-extensions +{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } +{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; + +HELP: has-gl-extensions? +{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } +{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; + +HELP: has-gl-version-or-extensions? +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +HELP: require-gl-extensions +{ $values { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; + +HELP: require-gl-version-or-extensions +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words + +ABOUT: "gl-utilities" diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor new file mode 100644 index 0000000000..d9eb6fd679 --- /dev/null +++ b/extra/opengl/capabilities/capabilities.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences splitting opengl.gl +continuations math.parser math arrays ; +IN: opengl.capabilities + +: (require-gl) ( thing require-quot make-error-quot -- ) + >r dupd call + [ r> 2drop ] + [ r> " " make throw ] + if ; inline + +: gl-extensions ( -- seq ) + GL_EXTENSIONS glGetString " " split ; +: has-gl-extensions? ( extensions -- ? ) + gl-extensions swap [ over member? ] all? nip ; +: (make-gl-extensions-error) ( required-extensions -- ) + gl-extensions swap seq-diff + "Required OpenGL extensions not supported:\n" % + [ " " % % "\n" % ] each ; +: require-gl-extensions ( extensions -- ) + [ has-gl-extensions? ] + [ (make-gl-extensions-error) ] + (require-gl) ; + +: version-seq ( version-string -- version-seq ) + "." split [ string>number ] map ; + +: version<=> ( version1 version2 -- n ) + swap version-seq swap version-seq <=> ; + +: (gl-version) ( -- version vendor ) + GL_VERSION glGetString " " split1 ; +: gl-version ( -- version ) + (gl-version) drop ; +: gl-vendor-version ( -- version ) + (gl-version) nip ; +: has-gl-version? ( version -- ? ) + gl-version version<=> 0 <= ; +: (make-gl-version-error) ( required-version -- ) + "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; +: require-gl-version ( version -- ) + [ has-gl-version? ] + [ (make-gl-version-error) ] + (require-gl) ; + +: (glsl-version) ( -- version vendor ) + GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; +: glsl-version ( -- version ) + (glsl-version) drop ; +: glsl-vendor-version ( -- version ) + (glsl-version) nip ; +: has-glsl-version? ( version -- ? ) + glsl-version version<=> 0 <= ; +: require-glsl-version ( version -- ) + [ has-glsl-version? ] + [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] + (require-gl) ; + +: has-gl-version-or-extensions? ( version extensions -- ? ) + has-gl-extensions? swap has-gl-version? or ; + +: require-gl-version-or-extensions ( version extensions -- ) + 2array [ first2 has-gl-version-or-extensions? ] [ + dup first (make-gl-version-error) "\n" % + second (make-gl-extensions-error) "\n" % + ] (require-gl) ; diff --git a/extra/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt new file mode 100644 index 0000000000..d31b63b8d4 --- /dev/null +++ b/extra/opengl/capabilities/summary.txt @@ -0,0 +1 @@ +Testing for OpenGL versions and extensions \ No newline at end of file diff --git a/extra/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/capabilities/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/framebuffers/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffer-docs.factor b/extra/opengl/framebuffers/framebuffer-docs.factor new file mode 100644 index 0000000000..c5507dcce1 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffer-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.framebuffers + +HELP: gen-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; + +HELP: gen-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; + +HELP: delete-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; + +HELP: delete-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; + +{ gen-framebuffer delete-framebuffer } related-words +{ gen-renderbuffer delete-renderbuffer } related-words + +HELP: framebuffer-incomplete? +{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; + +HELP: check-framebuffer +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; + +HELP: with-framebuffer +{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; + +ABOUT: "gl-utilities" \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor new file mode 100644 index 0000000000..346789e1c5 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffers.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl opengl.gl combinators continuations kernel +alien.c-types ; +IN: opengl.framebuffers + +: gen-framebuffer ( -- id ) + [ glGenFramebuffersEXT ] (gen-gl-object) ; +: gen-renderbuffer ( -- id ) + [ glGenRenderbuffersEXT ] (gen-gl-object) ; + +: delete-framebuffer ( id -- ) + [ glDeleteFramebuffersEXT ] (delete-gl-object) ; +: delete-renderbuffer ( id -- ) + [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; + +: framebuffer-incomplete? ( -- status/f ) + GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT + dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; + +: framebuffer-error ( status -- * ) + { + { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } + { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } + { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + [ drop gl-error "unknown framebuffer error" ] + } case throw ; + +: check-framebuffer ( -- ) + framebuffer-incomplete? [ framebuffer-error ] when* ; + +: with-framebuffer ( id quot -- ) + GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline + +: framebuffer-attachment ( attachment -- id ) + GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT + 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/extra/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt new file mode 100644 index 0000000000..3ef713ac13 --- /dev/null +++ b/extra/opengl/framebuffers/summary.txt @@ -0,0 +1 @@ +Rendering to offscreen textures using the GL_EXT_framebuffer_object extension \ No newline at end of file diff --git a/extra/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/framebuffers/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index cb0c9e884f..97120237ec 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl multiline assocs ; +opengl.gl multiline assocs vocabs.loader sequences ; IN: opengl HELP: gl-color @@ -57,14 +57,6 @@ HELP: gen-texture { $values { "id" integer } } { $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ; -HELP: gen-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; - -HELP: gen-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; - HELP: gen-gl-buffer { $values { "id" integer } } { $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ; @@ -73,34 +65,13 @@ HELP: delete-texture { $values { "id" integer } } { $description "Wrapper for " { $link glDeleteTextures } " to handle the common case of deleting a single texture ID." } ; -HELP: delete-framebuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; - -HELP: delete-renderbuffer -{ $values { "id" integer } } -{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; - HELP: delete-gl-buffer { $values { "id" integer } } { $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ; { gen-texture delete-texture } related-words -{ gen-framebuffer delete-framebuffer } related-words -{ gen-renderbuffer delete-renderbuffer } related-words { gen-gl-buffer delete-gl-buffer } related-words -HELP: framebuffer-incomplete? -{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; - -HELP: check-framebuffer -{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; - -HELP: with-framebuffer -{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } -{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; - HELP: bind-texture-unit { $values { "id" "The id of a texture object." } { "target" "The texture target (e.g., " { $snippet "GL_TEXTURE_2D" } ")" } { "unit" "The texture unit to bind (e.g., " { $snippet "GL_TEXTURE0" } ")" } } { $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ; @@ -148,175 +119,9 @@ HELP: with-translation { $values { "loc" "a pair of integers" } { "quot" quotation } } { $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ; -HELP: gl-shader -{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" - { $list - { { $link } " - Compile GLSL code into a shader object" } - { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" } - { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" } - { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" } - { { $link delete-gl-shader } " - Invalidate a shader object" } - } - "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ; - -HELP: vertex-shader -{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:" - { $list - { { $link } " - Compile GLSL code into a vertex shader object "} - } -} ; - -HELP: fragment-shader -{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:" - { $list - { { $link } " - Compile GLSL code into a fragment shader object "} - } -} ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } } -{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } } -{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; - -HELP: -{ $values { "source" "The GLSL source code to compile" } } -{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; - -HELP: gl-shader-ok? -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; - -HELP: check-gl-shader -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ; - -HELP: delete-gl-shader -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; - -HELP: gl-shader-info-log -{ $values { "shader" "A " { $link gl-shader } " object" } } -{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; - -HELP: gl-program -{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:" - { $list - { { $link } ", " { $link } " - Link a set of shaders into a GLSL program" } - { { $link gl-program-ok? } " - Check whether a program object linked successfully" } - { { $link check-gl-program } " - Throw an error unless a program object linked successfully" } - { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" } - { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" } - { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" } - { { $link with-gl-program } " - Use a program object" } - } -} ; - -HELP: -{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } } -{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; - -HELP: -{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } } -{ $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; - -{ } related-words - -HELP: gl-program-ok? -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; - -HELP: check-gl-program -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; - -HELP: gl-program-info-log -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; - -HELP: delete-gl-program -{ $values { "program" "A " { $link gl-program } " object" } } -{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; - -HELP: with-gl-program -{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } } -{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack for the associated quotation.\n\nExample:" } -{ $code <" -! From bunny.cel-shaded -: (draw-cel-shaded-bunny) ( geom program -- ) - { - { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } - { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } - { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } - { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } - { "shininess" [ 100.0 glUniform1f ] } - } [ bunny-geom ] with-gl-program ; -"> } ; - -HELP: gl-version -{ $values { "version" "The version string from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; - -HELP: gl-vendor-version -{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; - -HELP: has-gl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } -{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; - -HELP: require-gl-version -{ $values { "version" "A version string" } } -{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; - -HELP: glsl-version -{ $values { "version" "The GLSL version string from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; - -HELP: glsl-vendor-version -{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } -{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; - -HELP: has-glsl-version? -{ $values { "version" "A version string" } { "?" "A boolean value" } } -{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; - -HELP: require-glsl-version -{ $values { "version" "A version string" } } -{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; - -HELP: gl-extensions -{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } -{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; - -HELP: has-gl-extensions? -{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } -{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; - -HELP: has-gl-version-or-extensions? -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } -{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; - -HELP: require-gl-extensions -{ $values { "extensions" "A sequence of extension name strings" } } -{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; - -HELP: require-gl-version-or-extensions -{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } -{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; - -{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words - ARTICLE: "gl-utilities" "OpenGL utility words" "In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel." $nl -"Checking implementation capabilities:" -{ $subsection require-gl-version } -{ $subsection require-gl-extensions } -{ $subsection require-glsl-version } -{ $subsection require-gl-version-or-extensions } "Wrappers:" { $subsection gl-color } { $subsection gl-vertex } @@ -329,8 +134,6 @@ $nl { $subsection do-attribs } { $subsection do-matrix } { $subsection with-translation } -{ $subsection with-framebuffer } -{ $subsection with-gl-program } { $subsection make-dlist } "Rendering geometric shapes:" { $subsection gl-line } @@ -339,9 +142,6 @@ $nl { $subsection gl-fill-poly } { $subsection gl-poly } { $subsection gl-gradient } -"Compiling, linking, and using GLSL programs:" -{ $subsection gl-shader } -{ $subsection gl-program } ; ABOUT: "gl-utilities" diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 071f85fe12..5afb6ef070 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -33,11 +33,19 @@ IN: opengl : do-enabled-client-state ( what quot -- ) over glEnableClientState dip glDisableClientState ; inline -: all-enabled ( seq quot -- ) +: words>values ( word/value-seq -- value-seq ) + [ dup word? [ execute ] [ ] if ] map ; + +: (all-enabled) ( seq quot -- ) over [ glEnable ] each dip [ glDisable ] each ; inline -: all-enabled-client-state ( seq quot -- ) +: (all-enabled-client-state) ( seq quot -- ) over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline +MACRO: all-enabled ( seq quot -- ) + >r words>values r> [ (all-enabled) ] 2curry ; +MACRO: all-enabled-client-state ( seq quot -- ) + >r words>values r> [ (all-enabled-client-state) ] 2curry ; + : do-matrix ( mode quot -- ) swap [ glMatrixMode glPushMatrix call ] keep glMatrixMode glPopMatrix ; inline @@ -106,10 +114,6 @@ IN: opengl >r 1 0 r> keep *uint ; inline : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ; -: gen-framebuffer ( -- id ) - [ glGenFramebuffersEXT ] (gen-gl-object) ; -: gen-renderbuffer ( -- id ) - [ glGenRenderbuffersEXT ] (gen-gl-object) ; : gen-gl-buffer ( -- id ) [ glGenBuffers ] (gen-gl-object) ; @@ -117,10 +121,6 @@ IN: opengl >r 1 swap r> call ; inline : delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ; -: delete-framebuffer ( id -- ) - [ glDeleteFramebuffersEXT ] (delete-gl-object) ; -: delete-renderbuffer ( id -- ) - [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; : delete-gl-buffer ( id -- ) [ glDeleteBuffers ] (delete-gl-object) ; @@ -141,40 +141,14 @@ IN: opengl : buffer-offset ( int -- alien ) ; inline -: framebuffer-incomplete? ( -- status/f ) - GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT - dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; - -: framebuffer-error ( status -- * ) - { { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } - { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } - { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } - { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } - [ drop gl-error "unknown framebuffer error" ] } case throw ; - -: check-framebuffer ( -- ) - framebuffer-incomplete? [ framebuffer-error ] when* ; - -: with-framebuffer ( id quot -- ) - GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT - [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline - : bind-texture-unit ( id target unit -- ) glActiveTexture swap glBindTexture gl-error ; -: framebuffer-attachment ( attachment -- id ) - GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT - 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; - : (set-draw-buffers) ( buffers -- ) dup length swap >c-uint-array glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) - [ dup word? [ execute ] [ ] if ] map [ (set-draw-buffers) ] curry ; + words>values [ (set-draw-buffers) ] curry ; : do-attribs ( bits quot -- ) swap glPushAttrib call glPopAttrib ; inline @@ -274,196 +248,3 @@ TUPLE: sprite loc dim dim2 dlist texture ; glLoadIdentity GL_MODELVIEW glMatrixMode glLoadIdentity ; - -! Shaders - -: c-true? ( int -- ? ) zero? not ; inline - -: with-gl-shader-source-ptr ( string quot -- ) - swap string>char-alien malloc-byte-array [ - swap call - ] keep free ; inline - -: ( source kind -- shader ) - glCreateShader dup rot - [ 1 swap f glShaderSource ] with-gl-shader-source-ptr - [ glCompileShader ] keep - gl-error ; - -: (gl-shader?) ( object -- ? ) - dup integer? [ glIsShader c-true? ] [ drop f ] if ; - -: gl-shader-get-int ( shader enum -- value ) - 0 [ glGetShaderiv ] keep *int ; - -: gl-shader-ok? ( shader -- ? ) - GL_COMPILE_STATUS gl-shader-get-int c-true? ; - -: ( source -- vertex-shader ) - GL_VERTEX_SHADER ; inline - -: (vertex-shader?) ( object -- ? ) - dup (gl-shader?) - [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] - [ drop f ] if ; - -: ( source -- fragment-shader ) - GL_FRAGMENT_SHADER ; inline - -: (fragment-shader?) ( object -- ? ) - dup (gl-shader?) - [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] - [ drop f ] if ; - -: gl-shader-info-log-length ( shader -- log-length ) - GL_INFO_LOG_LENGTH gl-shader-get-int ; inline - -: gl-shader-info-log ( shader -- log ) - dup gl-shader-info-log-length dup [ - [ 0 swap glGetShaderInfoLog ] keep - alien>char-string - ] with-malloc ; - -: check-gl-shader ( shader -- shader* ) - dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; - -: delete-gl-shader ( shader -- ) glDeleteShader ; inline - -PREDICATE: integer gl-shader (gl-shader?) ; -PREDICATE: gl-shader vertex-shader (vertex-shader?) ; -PREDICATE: gl-shader fragment-shader (fragment-shader?) ; - -! Programs - -: ( shaders -- program ) - glCreateProgram swap - [ dupd glAttachShader ] each - [ glLinkProgram ] keep - gl-error ; - -: (gl-program?) ( object -- ? ) - dup integer? [ glIsProgram c-true? ] [ drop f ] if ; - -: gl-program-get-int ( program enum -- value ) - 0 [ glGetProgramiv ] keep *int ; - -: gl-program-ok? ( program -- ? ) - GL_LINK_STATUS gl-program-get-int c-true? ; - -: gl-program-info-log-length ( program -- log-length ) - GL_INFO_LOG_LENGTH gl-program-get-int ; inline - -: gl-program-info-log ( program -- log ) - dup gl-program-info-log-length dup [ - [ 0 swap glGetProgramInfoLog ] keep - alien>char-string - ] with-malloc ; - -: check-gl-program ( program -- program* ) - dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; - -: gl-program-shaders-length ( program -- shaders-length ) - GL_ATTACHED_SHADERS gl-program-get-int ; inline - -: gl-program-shaders ( program -- shaders ) - dup gl-program-shaders-length [ - dup "GLuint" - [ 0 swap glGetAttachedShaders ] keep - ] keep c-uint-array> ; - -: delete-gl-program-only ( program -- ) - glDeleteProgram ; inline - -: detach-gl-program-shader ( program shader -- ) - glDetachShader ; inline - -: delete-gl-program ( program -- ) - dup gl-program-shaders [ - 2dup detach-gl-program-shader delete-gl-shader - ] each delete-gl-program-only ; - -: (with-gl-program) ( program quot -- ) - swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline - -: (with-gl-program-uniforms) ( uniforms -- quot ) - [ [ swap , \ glGetUniformLocation , % ] [ ] make ] - { } assoc>map ; -: (make-with-gl-program) ( uniforms quot -- q ) - [ - \ dup , - [ swap (with-gl-program-uniforms) , \ call-with , % ] - [ ] make , - \ (with-gl-program) , - ] [ ] make ; - -MACRO: with-gl-program ( uniforms quot -- ) - (make-with-gl-program) ; - -PREDICATE: integer gl-program (gl-program?) ; - -: ( vertex-shader-source fragment-shader-source -- program ) - >r check-gl-shader - r> check-gl-shader - 2array check-gl-program ; - -: (require-gl) ( thing require-quot make-error-quot -- ) - >r dupd call - [ r> 2drop ] - [ r> " " make throw ] - if ; inline - -: gl-extensions ( -- seq ) - GL_EXTENSIONS glGetString " " split ; -: has-gl-extensions? ( extensions -- ? ) - gl-extensions swap [ over member? ] all? nip ; -: (make-gl-extensions-error) ( required-extensions -- ) - gl-extensions swap seq-diff - "Required OpenGL extensions not supported:\n" % - [ " " % % "\n" % ] each ; -: require-gl-extensions ( extensions -- ) - [ has-gl-extensions? ] - [ (make-gl-extensions-error) ] - (require-gl) ; - -: version-seq ( version-string -- version-seq ) - "." split [ string>number ] map ; - -: version<=> ( version1 version2 -- n ) - swap version-seq swap version-seq <=> ; - -: (gl-version) ( -- version vendor ) - GL_VERSION glGetString " " split1 ; -: gl-version ( -- version ) - (gl-version) drop ; -: gl-vendor-version ( -- version ) - (gl-version) nip ; -: has-gl-version? ( version -- ? ) - gl-version version<=> 0 <= ; -: (make-gl-version-error) ( required-version -- ) - "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; -: require-gl-version ( version -- ) - [ has-gl-version? ] - [ (make-gl-version-error) ] - (require-gl) ; - -: (glsl-version) ( -- version vendor ) - GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; -: glsl-version ( -- version ) - (glsl-version) drop ; -: glsl-vendor-version ( -- version ) - (glsl-version) nip ; -: has-glsl-version? ( version -- ? ) - glsl-version version<=> 0 <= ; -: require-glsl-version ( version -- ) - [ has-glsl-version? ] - [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] - (require-gl) ; - -: has-gl-version-or-extensions? ( version extensions -- ? ) - has-gl-extensions? swap has-gl-version? or ; - -: require-gl-version-or-extensions ( version extensions -- ) - 2array [ first2 has-gl-version-or-extensions? ] [ - dup first (make-gl-version-error) "\n" % - second (make-gl-extensions-error) "\n" % - ] (require-gl) ; diff --git a/extra/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/shaders/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor new file mode 100644 index 0000000000..e065367323 --- /dev/null +++ b/extra/opengl/shaders/shaders-docs.factor @@ -0,0 +1,112 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.shaders + +HELP: gl-shader +{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } " - Compile GLSL code into a shader object" } + { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" } + { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" } + { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" } + { { $link delete-gl-shader } " - Invalidate a shader object" } + } + "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ; + +HELP: vertex-shader +{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a vertex shader object "} + } +} ; + +HELP: fragment-shader +{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:" + { $list + { { $link } " - Compile GLSL code into a fragment shader object "} + } +} ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } } +{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } } +{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER " } "." } ; + +HELP: +{ $values { "source" "The GLSL source code to compile" } } +{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER " } "." } ; + +HELP: gl-shader-ok? +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ; + +HELP: check-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ; + +HELP: delete-gl-shader +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ; + +HELP: gl-shader-info-log +{ $values { "shader" "A " { $link gl-shader } " object" } } +{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ; + +HELP: gl-program +{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } ", " { $link } " - Link a set of shaders into a GLSL program" } + { { $link gl-program-ok? } " - Check whether a program object linked successfully" } + { { $link check-gl-program } " - Throw an error unless a program object linked successfully" } + { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" } + { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" } + { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" } + { { $link with-gl-program } " - Use a program object" } + } +} ; + +HELP: +{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } } +{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ; + +HELP: +{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } } +{ $description "Wrapper for " { $link } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ; + +{ } related-words + +HELP: gl-program-ok? +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; + +HELP: check-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; + +HELP: gl-program-info-log +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; + +HELP: delete-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; + +HELP: with-gl-program +{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } } +{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" } +{ $code <" +! From bunny.cel-shaded +: (draw-cel-shaded-bunny) ( geom program -- ) + { + { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } + { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } + { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } + { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } + { "shininess" [ 100.0 glUniform1f ] } + } [ bunny-geom ] with-gl-program ; +"> } ; + +ABOUT: "gl-utilities" diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor new file mode 100644 index 0000000000..0ff708d6d4 --- /dev/null +++ b/extra/opengl/shaders/shaders.factor @@ -0,0 +1,134 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel opengl.gl alien.c-types continuations namespaces +assocs alien libc opengl math sequences combinators.lib +macros arrays ; +IN: opengl.shaders + +: with-gl-shader-source-ptr ( string quot -- ) + swap string>char-alien malloc-byte-array [ + swap call + ] keep free ; inline + +: ( source kind -- shader ) + glCreateShader dup rot + [ 1 swap f glShaderSource ] with-gl-shader-source-ptr + [ glCompileShader ] keep + gl-error ; + +: (gl-shader?) ( object -- ? ) + dup integer? [ glIsShader c-bool> ] [ drop f ] if ; + +: gl-shader-get-int ( shader enum -- value ) + 0 [ glGetShaderiv ] keep *int ; + +: gl-shader-ok? ( shader -- ? ) + GL_COMPILE_STATUS gl-shader-get-int c-bool> ; + +: ( source -- vertex-shader ) + GL_VERTEX_SHADER ; inline + +: (vertex-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] + [ drop f ] if ; + +: ( source -- fragment-shader ) + GL_FRAGMENT_SHADER ; inline + +: (fragment-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ] + [ drop f ] if ; + +: gl-shader-info-log-length ( shader -- log-length ) + GL_INFO_LOG_LENGTH gl-shader-get-int ; inline + +: gl-shader-info-log ( shader -- log ) + dup gl-shader-info-log-length dup [ + [ 0 swap glGetShaderInfoLog ] keep + alien>char-string + ] with-malloc ; + +: check-gl-shader ( shader -- shader* ) + dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ; + +: delete-gl-shader ( shader -- ) glDeleteShader ; inline + +PREDICATE: integer gl-shader (gl-shader?) ; +PREDICATE: gl-shader vertex-shader (vertex-shader?) ; +PREDICATE: gl-shader fragment-shader (fragment-shader?) ; + +! Programs + +: ( shaders -- program ) + glCreateProgram swap + [ dupd glAttachShader ] each + [ glLinkProgram ] keep + gl-error ; + +: (gl-program?) ( object -- ? ) + dup integer? [ glIsProgram c-bool> ] [ drop f ] if ; + +: gl-program-get-int ( program enum -- value ) + 0 [ glGetProgramiv ] keep *int ; + +: gl-program-ok? ( program -- ? ) + GL_LINK_STATUS gl-program-get-int c-bool> ; + +: gl-program-info-log-length ( program -- log-length ) + GL_INFO_LOG_LENGTH gl-program-get-int ; inline + +: gl-program-info-log ( program -- log ) + dup gl-program-info-log-length dup [ + [ 0 swap glGetProgramInfoLog ] keep + alien>char-string + ] with-malloc ; + +: check-gl-program ( program -- program* ) + dup gl-program-ok? [ dup gl-program-info-log throw ] unless ; + +: gl-program-shaders-length ( program -- shaders-length ) + GL_ATTACHED_SHADERS gl-program-get-int ; inline + +: gl-program-shaders ( program -- shaders ) + dup gl-program-shaders-length [ + dup "GLuint" + [ 0 swap glGetAttachedShaders ] keep + ] keep c-uint-array> ; + +: delete-gl-program-only ( program -- ) + glDeleteProgram ; inline + +: detach-gl-program-shader ( program shader -- ) + glDetachShader ; inline + +: delete-gl-program ( program -- ) + dup gl-program-shaders [ + 2dup detach-gl-program-shader delete-gl-shader + ] each delete-gl-program-only ; + +: (with-gl-program) ( program quot -- ) + swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline + +: (with-gl-program-uniforms) ( uniforms -- quot ) + [ [ swap , \ glGetUniformLocation , % ] [ ] make ] + { } assoc>map ; +: (make-with-gl-program) ( uniforms quot -- q ) + [ + \ dup , + [ swap (with-gl-program-uniforms) , \ call-with , % ] + [ ] make , + \ (with-gl-program) , + ] [ ] make ; + +MACRO: with-gl-program ( uniforms quot -- ) + (make-with-gl-program) ; + +PREDICATE: integer gl-program (gl-program?) ; + +: ( vertex-shader-source fragment-shader-source -- program ) + >r check-gl-shader + r> check-gl-shader + 2array check-gl-program ; + diff --git a/extra/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt new file mode 100644 index 0000000000..c55f76668f --- /dev/null +++ b/extra/opengl/shaders/summary.txt @@ -0,0 +1 @@ +OpenGL Shading Language (GLSL) support \ No newline at end of file diff --git a/extra/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt new file mode 100644 index 0000000000..ce0345edc9 --- /dev/null +++ b/extra/opengl/shaders/tags.txt @@ -0,0 +1,3 @@ +opengl +glsl +bindings \ No newline at end of file From 3bc9790b740dd8d989b9b9146f01d472418c4116 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 3 Feb 2008 16:19:05 -0800 Subject: [PATCH 132/317] Adjust the bunny position to be better centered --- extra/bunny/bunny.factor | 2 +- extra/bunny/model/model.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 38f8e32fb6..7cf6132925 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -52,7 +52,7 @@ M: bunny-gadget draw-gadget* ( gadget -- ) GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear dup demo-gadget-set-matrices GL_MODELVIEW glMatrixMode - 0.0 -0.12 0.0 glTranslatef + 0.02 -0.105 0.0 glTranslatef { bunny-gadget-geom bunny-gadget-draw } get-slots draw-bunny ; diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor index f2c93eac3e..b238bd8b99 100644 --- a/extra/bunny/model/model.factor +++ b/extra/bunny/model/model.factor @@ -92,7 +92,7 @@ M: bunny-buffers bunny-geom bunny-buffers-array bunny-buffers-element-array } get-slots [ - GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [ + { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [ GL_DOUBLE 0 0 buffer-offset glNormalPointer dup bunny-buffers-nv "double" heap-size * buffer-offset 3 GL_DOUBLE 0 roll glVertexPointer From d0e5b238e2c056500e4bab055b404eac04ad7a52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 3 Feb 2008 20:36:04 -0600 Subject: [PATCH 133/317] Use new feature --- extra/tools/deploy/backend/backend.factor | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index f2bd03475f..d768b6a334 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -16,8 +16,11 @@ IN: tools.deploy.backend : copy-lines ( stream -- ) [ (copy-lines) ] with-disposal ; -: run-with-output ( descriptor -- ) - +: run-with-output ( arguments -- ) + [ + +arguments+ set + +stdout+ +stderr+ set + ] H{ } make-assoc dup duplex-stream-out dispose copy-lines ; From e36bddd91c8929a238ed0b9679e49d9cb83ad584 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 22:11:31 -0500 Subject: [PATCH 134/317] Solution to Project Euler problem 52 --- extra/project-euler/052/052.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +-- 2 files changed, 53 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/052/052.factor diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor new file mode 100644 index 0000000000..3f6487fb3e --- /dev/null +++ b/extra/project-euler/052/052.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math project-euler.common sequences sorting ; +IN: project-euler.052 + +! http://projecteuler.net/index.php?section=problems&id=52 + +! DESCRIPTION +! ----------- + +! It can be seen that the number, 125874, and its double, 251748, contain +! exactly the same digits, but in a different order. + +! Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, +! contain the same digits. + + +! SOLUTION +! -------- + +! Analysis shows the number must be odd, divisible by 3, and larger than 123456 + +digits natural-sort ] map all-equal? ; + +: candidate? ( n -- ? ) + { [ dup odd? ] [ dup 3 mod zero? ] } && nip ; + +: next-all-same ( x n -- n ) + dup candidate? [ + 2dup swap map-nx all-same-digits? + [ nip ] [ 1+ next-all-same ] if + ] [ + 1+ next-all-same + ] if ; + +PRIVATE> + +: euler052 ( -- answer ) + 6 123456 next-all-same ; + +! [ euler052 ] 100 ave-time +! 403 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler052 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 226c47b0a3..2f8a3184bb 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.067 - project-euler.075 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.052 + project-euler.067 project-euler.075 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:40:47 -0500 Subject: [PATCH 135/317] Solution to Project Euler problem 97 --- extra/project-euler/097/097.factor | 31 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 33 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/097/097.factor diff --git a/extra/project-euler/097/097.factor b/extra/project-euler/097/097.factor new file mode 100644 index 0000000000..50e7af563d --- /dev/null +++ b/extra/project-euler/097/097.factor @@ -0,0 +1,31 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.functions ; +IN: project-euler.097 + +! http://projecteuler.net/index.php?section=problems&id=97 + +! DESCRIPTION +! ----------- + +! The first known prime found to exceed one million digits was discovered in +! 1999, and is a Mersenne prime of the form 2^6972593 − 1; it contains exactly +! 2,098,960 digits. Subsequently other Mersenne primes, of the form 2p − 1, +! have been found which contain more digits. + +! However, in 2004 there was found a massive non-Mersenne prime which contains +! 2,357,207 digits: 28433 * 2^7830457 + 1. + +! Find the last ten digits of this prime number. + + +! SOLUTION +! -------- + +: euler097 ( -- answer ) + 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ; + +! [ euler097 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler097 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 2f8a3184bb..0be0b456ad 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,8 +13,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.067 project-euler.075 project-euler.097 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:49:31 -0500 Subject: [PATCH 136/317] Add missing dependency for Project Euler 42 --- extra/project-euler/042/042.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index 3d5f271374..95b3062e95 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii combinators.lib io.files kernel math namespaces +USING: ascii combinators.lib io.files kernel math math.functions namespaces project-euler.common sequences splitting ; IN: project-euler.042 From e2c20d23a4856580e1d8eabf2b57a8d6b5d78d0d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:06:11 -0600 Subject: [PATCH 137/317] add missing use fix dll path on windows --- extra/ogg/theora/theora.factor | 2 +- extra/ogg/vorbis/vorbis.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 0d9748a6f3..48b61b41a3 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,7 +6,7 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "libtheora.dll" ] } + { [ win32? ] [ "theora.dll" ] } { [ macosx? ] [ "libtheora.0.dylib" ] } { [ unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 26e917ebf4..170d0ea6ef 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel system combinators alien alien.syntax ; +USING: kernel system combinators alien alien.syntax ogg ; IN: ogg.vorbis << From bc3bf6b2b4ede72aa4332dd3f7b98cd85f836756 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:45:53 -0600 Subject: [PATCH 138/317] make factor compile on win64 --- Makefile | 6 +++++- vm/Config.windows.nt.x86.32 | 1 + vm/Config.windows.nt.x86.64 | 6 ++++-- vm/os-windows-nt.32.h | 2 ++ vm/os-windows-nt.64.h | 2 ++ vm/os-windows-nt.c | 10 +++++----- vm/platform.h | 9 +++++++-- 7 files changed, 26 insertions(+), 10 deletions(-) create mode 100644 vm/os-windows-nt.32.h create mode 100644 vm/os-windows-nt.64.h diff --git a/Makefile b/Makefile index aad7fe90eb..bd1bf16c74 100755 --- a/Makefile +++ b/Makefile @@ -65,6 +65,7 @@ default: @echo "solaris-x86-64" @echo "windows-ce-arm" @echo "windows-nt-x86-32" + @echo "windows-nt-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -125,6 +126,9 @@ solaris-x86-64: windows-nt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 +windows-nt-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + windows-ce-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -151,7 +155,7 @@ clean: rm -f factor*.dll libfactor*.* vm/resources.o: - windres vm/factor.rs vm/resources.o + $(WINDRES) vm/factor.rs vm/resources.o .c.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32 index 9a020a7bc1..603a7200ae 100644 --- a/vm/Config.windows.nt.x86.32 +++ b/vm/Config.windows.nt.x86.32 @@ -1,3 +1,4 @@ WINDRES=windres include vm/Config.windows.nt include vm/Config.x86.32 +#error "lolllll" diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 1c30e64096..6d3865c2f4 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,4 +1,6 @@ -CC=/k/target/bin/x86_64-pc-mingw32-gcc +#WIN64_PATH=/k/MinGW/win64/bin +WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 +CC=$(WIN64_PATH)-gcc.exe +WINDRES=$(WIN64_PATH)-windres.exe include vm/Config.windows.nt include vm/Config.x86.64 -WINDRES = /k/target/bin/windres diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.h new file mode 100644 index 0000000000..9b10671ba0 --- /dev/null +++ b/vm/os-windows-nt.32.h @@ -0,0 +1,2 @@ +#define ESP Esp +#define EIP Eip diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.h new file mode 100644 index 0000000000..1f61c2335f --- /dev/null +++ b/vm/os-windows-nt.64.h @@ -0,0 +1,2 @@ +#define ESP Rsp +#define EIP Rip diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..3995b6a35a 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -57,26 +57,26 @@ long exception_handler(PEXCEPTION_POINTERS pe) PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void *)c->Esp; + if(in_code_heap_p(c->EIP)) + signal_callstack_top = (void *)c->ESP; else signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->Eip = (CELL)memory_signal_handler_impl; + c->EIP = (CELL)memory_signal_handler_impl; } else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) { signal_number = ERROR_DIVIDE_BY_ZERO; - c->Eip = (CELL)divide_by_zero_signal_handler_impl; + c->EIP = (CELL)divide_by_zero_signal_handler_impl; } else { signal_number = 11; - c->Eip = (CELL)misc_signal_handler_impl; + c->EIP = (CELL)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; diff --git a/vm/platform.h b/vm/platform.h index b0641176bc..66f22bbf96 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -1,11 +1,11 @@ #if defined(__arm__) #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 #elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) #define FACTOR_PPC -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 #else #error "Unsupported architecture" #endif @@ -18,6 +18,11 @@ #endif #include "os-windows.h" + #if defined(FACTOR_AMD64) + #include "os-windows-nt.64.h" + #elif defined(FACTOR_X86) + #include "os-windows-nt.32.h" + #endif #else #include "os-unix.h" From 46e02fa30d45f23fe98aed2ff4233fa0eba26415 Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 4 Feb 2008 11:50:02 -0600 Subject: [PATCH 139/317] Linux inotify works --- extra/io/monitor/monitor.factor | 4 ++-- extra/io/unix/linux/linux.factor | 27 +++++++++++----------- extra/io/windows/nt/monitor/monitor.factor | 7 +++--- 3 files changed, 20 insertions(+), 18 deletions(-) diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 11d1b6ecf9..1d8499b392 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -17,7 +17,7 @@ TUPLE: monitor queue closed? ; set-monitor-queue } monitor construct ; -HOOK: fill-queue io-backend ( monitor -- assoc ) +HOOK: fill-queue io-backend ( monitor -- ) : changed-file ( changed path -- ) namespace [ append ] change-at ; @@ -32,7 +32,7 @@ HOOK: io-backend ( path recursive? -- monitor ) : next-change ( monitor -- path changed ) dup check-monitor dup monitor-queue dup assoc-empty? [ - drop dup fill-queue over set-monitor-queue next-change + drop dup fill-queue next-change ] [ nip dequeue-change ] if ; SYMBOL: +add-file+ diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9751cefe91..1707ac9546 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -54,21 +54,22 @@ TUPLE: inotify watches ; M: linux-io ( path recursive? -- monitor ) drop IN_CHANGE_EVENTS add-watch ; -: notify-callback ( assoc monitor -- ) - linux-monitor-callback dup - [ schedule-thread-with ] [ 2drop ] if ; +: notify-callback ( monitor -- ) + dup linux-monitor-callback + f rot set-linux-monitor-callback + [ schedule-thread ] when* ; -M: linux-io fill-queue ( monitor -- assoc ) +M: linux-io fill-queue ( monitor -- ) dup linux-monitor-callback [ "Cannot wait for changes on the same file from multiple threads" throw ] when - [ swap set-linux-monitor-callback stop ] callcc1 - swap check-monitor ; + [ swap set-linux-monitor-callback stop ] callcc0 + check-monitor ; M: linux-monitor dispose ( monitor -- ) dup check-monitor t over set-monitor-closed? - H{ } over notify-callback + dup notify-callback remove-watch ; : ?flag ( n mask symbol -- n ) @@ -106,13 +107,13 @@ M: linux-monitor dispose ( monitor -- ) inotify-event-len "inotify-event" heap-size + swap >r + r> ; -: wd>queue ( wd -- queue ) - inotify-event-wd wd>monitor monitor-queue ; - : parse-file-notifications ( i buffer -- ) 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ dup inotify-event-wd wd>queue - [ parse-file-notify changed-file ] bind + 2dup inotify-event@ dup inotify-event-wd wd>monitor [ + monitor-queue [ + parse-file-notify changed-file + ] bind + ] keep notify-callback next-event parse-file-notifications ] if ; @@ -135,7 +136,7 @@ M: inotify-task do-io-task ( task -- ) io-task-port read-notifications f ; M: linux-io init-io ( -- ) - mx set-global ; ! init-inotify ; + dup mx set-global init-inotify ; T{ linux-io } set-io-backend diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index f2cc4ef92a..d418dff270 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -78,6 +78,7 @@ M: windows-nt-io ( path recursive? -- monitor ) dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 3drop ] [ swap (changed-files) ] if ; -M: windows-nt-io fill-queue ( monitor -- assoc ) - dup win32-monitor-path over buffer-ptr rot read-changes - [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ; +M: windows-nt-io fill-queue ( monitor -- ) + dup win32-monitor-path over buffer-ptr pick read-changes + [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc + swap set-monitor-queue ; From f2af000ed040468ed6377ad526c461fbff66b6af Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 4 Feb 2008 11:50:20 -0600 Subject: [PATCH 140/317] refresh-all fix, new show word for debugging --- core/io/crc32/crc32-docs.factor | 10 +++++----- core/io/crc32/crc32.factor | 2 -- core/io/streams/c/c.factor | 7 +++++++ core/source-files/source-files.factor | 2 +- extra/tools/deploy/shaker/shaker.factor | 5 ----- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor index 020f2668b0..3855c77cd8 100644 --- a/core/io/crc32/crc32-docs.factor +++ b/core/io/crc32/crc32-docs.factor @@ -2,16 +2,16 @@ USING: help.markup help.syntax math ; IN: io.crc32 HELP: crc32 -{ $values { "seq" "a sequence" } { "n" integer } } +{ $values { "seq" "a sequence of bytes" } { "n" integer } } { $description "Computes the CRC32 checksum of a sequence of bytes." } ; -HELP: file-crc32 -{ $values { "path" "a pathname string" } { "n" integer } } -{ $description "Computes the CRC32 checksum of a file's contents." } ; +HELP: lines-crc32 +{ $values { "lines" "a sequence of strings" } { "n" integer } } +{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ; ARTICLE: "io.crc32" "CRC32 checksum calculation" "The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data." { $subsection crc32 } -{ $subsection file-crc32 } ; +{ $subsection lines-crc32 } ; ABOUT: "io.crc32" diff --git a/core/io/crc32/crc32.factor b/core/io/crc32/crc32.factor index b83943df48..afe7e4bfb7 100755 --- a/core/io/crc32/crc32.factor +++ b/core/io/crc32/crc32.factor @@ -23,8 +23,6 @@ IN: io.crc32 : crc32 ( seq -- n ) >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ; -: file-crc32 ( path -- n ) file-contents crc32 ; - : lines-crc32 ( seq -- n ) HEX: ffffffff tuck [ [ (crc32) ] each CHAR: \n (crc32) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index b02c3367d4..288ab212d1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -74,3 +74,10 @@ M: object M: object "ab" fopen ; + +: show ( msg -- ) + #! A word which directly calls primitives. It is used to + #! print stuff from contexts where the I/O system would + #! otherwise not work (tools.deploy.shaker, the I/O + #! multiplexer thread). + "\r\n" append stdout-handle fwrite stdout-handle fflush ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 8bbf329491..c974145928 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -17,7 +17,7 @@ uses definitions ; : (source-modified?) ( path modified checksum -- ? ) pick file-modified rot [ 0 or ] 2apply > - [ swap file-crc32 number= not ] [ 2drop f ] if ; + [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ; : source-modified? ( path -- ? ) dup source-files get at [ diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index f2b951ad16..16507232ae 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -8,11 +8,6 @@ debugger io.streams.c io.streams.duplex io.files io.backend quotations words.private tools.deploy.config compiler.units ; IN: tools.deploy.shaker -: show ( msg -- ) - #! Use primitives directly so that we can print stuff even - #! after most of the image has been stripped away - "\r\n" append stdout-handle fwrite stdout-handle fflush ; - : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at From 53cb45c9ff3a53ea1cce2679e9a772ea94d3b24a Mon Sep 17 00:00:00 2001 From: sheeple Date: Mon, 4 Feb 2008 12:03:48 -0600 Subject: [PATCH 141/317] Fix TYPEDEF: issue --- extra/unix/linux/linux.factor | 4 +--- extra/unix/solaris/solaris.factor | 2 -- extra/unix/unix.factor | 4 +++- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor index d25ff71d65..0a3eb7ee5f 100644 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -1,10 +1,8 @@ -! Copyright (C) 2005 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix USING: alien.syntax ; -TYPEDEF: ulong off_t - ! Linux. : O_RDONLY HEX: 0000 ; inline diff --git a/extra/unix/solaris/solaris.factor b/extra/unix/solaris/solaris.factor index b4aa8285eb..2bca20c6b6 100644 --- a/extra/unix/solaris/solaris.factor +++ b/extra/unix/solaris/solaris.factor @@ -3,8 +3,6 @@ IN: unix USING: alien.syntax system kernel ; -TYPEDEF: ulong off_t - ! Solaris. : O_RDONLY HEX: 0000 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index bcfbb3a214..7c3467b052 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -19,11 +19,13 @@ TYPEDEF: uint time_t TYPEDEF: uint uid_t TYPEDEF: ulong size_t TYPEDEF: ulong u_long -TYPEDEF: ulonglong off_t TYPEDEF: ushort mode_t TYPEDEF: ushort nlink_t TYPEDEF: void* caddr_t +TYPEDEF: ulong off_t +TYPEDEF-IF: bsd? ulonglong off_t + C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 From 87d44252c59f0a7d967157b634f10dc83acce442 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 12:30:23 -0600 Subject: [PATCH 142/317] add more dlls to script --- misc/factor.sh | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 032b0b3184..02f4c4a542 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -233,6 +233,16 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/zlib1.dll check_ret wget + wget http://factorcode.org/dlls/OpenAL32.dll + check_ret wget + wget http://factorcode.org/dlls/alut.dll + check_ret wget + wget http://factorcode.org/dlls/ogg.dll + check_ret wget + wget http://factorcode.org/dlls/theora.dll + check_ret wget + wget http://factorcode.org/dlls/vorbis.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From a75afb18d71e6ffb2fdedf3787e6190e94b86ef2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 12:58:38 -0600 Subject: [PATCH 143/317] Fix GCC error --- vm/os-genunix.c | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/vm/os-genunix.c b/vm/os-genunix.c index a0bd3e05ae..f582483ce7 100755 --- a/vm/os-genunix.c +++ b/vm/os-genunix.c @@ -13,6 +13,7 @@ void init_signals(void) void early_init(void) { } #define SUFFIX ".image" +#define SUFFIX_LEN 6 const char *default_image_path(void) { @@ -21,8 +22,14 @@ const char *default_image_path(void) if(!path) return "factor.image"; - char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1); - memcpy(new_path,path,strlen(path) + 1); - strcat(new_path,SUFFIX); + /* We can't call strlen() here because with gcc 4.1.2 this + causes an internal compiler error. */ + int len = 0; + const char *iter = path; + while(*iter) { len++; iter++; } + + char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); + memcpy(new_path,path,len + 1); + memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); return new_path; } From 0311c0a842380aebcf53c026b4215529758637cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 13:07:34 -0600 Subject: [PATCH 144/317] Remove broken optimization --- vm/types.c | 11 +---------- 1 file changed, 1 insertion(+), 10 deletions(-) diff --git a/vm/types.c b/vm/types.c index 24b5e7ff07..11e92ec754 100755 --- a/vm/types.c +++ b/vm/types.c @@ -471,8 +471,6 @@ F_STRING* allot_string_internal(CELL capacity) string->hashcode = F; string->aux = F; - set_string_nth(string,capacity,0); - return string; } @@ -645,14 +643,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) } \ type *to_##type##_string(F_STRING *s, bool check) \ { \ - if(sizeof(type) == sizeof(char)) \ - { \ - if(check && !check_string(s,sizeof(type))) \ - general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - return (type*)(s + 1); \ - } \ - else \ - return (type*)(string_to_##type##_alien(s,check) + 1); \ + return (type*)(string_to_##type##_alien(s,check) + 1); \ } \ type *unbox_##type##_string(void) \ { \ From c9a7f35e9ccb21e4e08ece6182c110defdb6d490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:32:27 -0600 Subject: [PATCH 145/317] remove spurious db.sql --- extra/db/db.factor | 1 - extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index b765924cd6..1c287cd871 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -10,7 +10,6 @@ C: db ( handle -- obj ) ! HOOK: db-create db ( str -- ) ! HOOK: db-drop db ( str -- ) GENERIC: db-open ( db -- ) -GENERIC: db-close ( db -- ) TUPLE: statement sql params handle bound? ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index f64b8d1104..aa7168530b 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.launcher kernel namespaces -prettyprint tools.test db.sqlite db db.sql sequences +prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 49462dcc50..73b93d404b 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db db.sql +USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi ; From 4066e1ca6b68512726bf66a9a4526a222ce770fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:01 -0600 Subject: [PATCH 146/317] start mysql --- extra/db/mysql/ffi/ffi.factor | 25 ++++++++++ extra/db/mysql/lib/lib.factor | 94 +++++++++++++++++++++++++++++++++++ extra/db/mysql/mysql.factor | 15 ++++++ 3 files changed, 134 insertions(+) create mode 100644 extra/db/mysql/ffi/ffi.factor create mode 100644 extra/db/mysql/lib/lib.factor create mode 100644 extra/db/mysql/mysql.factor diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor new file mode 100644 index 0000000000..845381a23c --- /dev/null +++ b/extra/db/mysql/ffi/ffi.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: alien alien.syntax combinators kernel system ; +IN: db.mysql.ffi + +<< "mysql" { + { [ win32? ] [ "libmySQL.dll" "stdcall" ] } + { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } +} cond add-library >> + +LIBRARY: mysql + +FUNCTION: void* mysql_init ( void* mysql ) ; +FUNCTION: char* mysql_error ( void* mysql ) ; +FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; +FUNCTION: void mysql_close ( void* sock ) ; +FUNCTION: int mysql_query ( void* mysql, char* q ) ; +FUNCTION: void* mysql_use_result ( void* mysql ) ; +FUNCTION: void mysql_free_result ( void* result ) ; +FUNCTION: char** mysql_fetch_row ( void* result ) ; +FUNCTION: int mysql_num_fields ( void* result ) ; +FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor new file mode 100644 index 0000000000..7d5c2d55dc --- /dev/null +++ b/extra/db/mysql/lib/lib.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: kernel alien io prettyprint sequences +namespaces arrays math db.mysql.ffi system ; +IN: db.mysql.lib + +SYMBOL: my-conn + +TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; + +: new-mysql ( -- conn ) + f mysql_init ; + +: mysql-error-string ( mysql-connection -- str ) + mysql-db-handle mysql_error ; + +: mysql-error ( mysql -- ) + mysql-error-string throw ; + +: mysql-connect ( mysql-connection -- ) + init-mysql swap + [ set-mysql-connection-mysqlconn ] 2keep + [ mysql-connection-host ] keep + [ mysql-connection-user ] keep + [ mysql-connection-password ] keep + [ mysql-connection-db ] keep + [ mysql-connection-port f 0 mysql_real_connect ] keep + [ set-mysql-connection-handle ] keep + dup mysql-connection-handle + [ connect-error-msg throw ] unless ; + +! ========================================================= +! Low level mysql utility definitions +! ========================================================= + +: (mysql-query) ( mysql-connection query -- ret ) + >r mysql-connection-mysqlconn r> mysql_query ; + +: (mysql-result) ( mysql-connection -- ret ) + [ mysql-connection-mysqlconn mysql_use_result ] keep + [ set-mysql-connection-resulthandle ] keep ; + +: (mysql-affected-rows) ( mysql-connection -- n ) + mysql-connection-mysqlconn mysql_affected_rows ; + +: (mysql-free-result) ( mysql-connection -- ) + mysql-connection-resulthandle drop ; + +: (mysql-row) ( mysql-connection -- row ) + mysql-connection-resulthandle mysql_fetch_row ; + +: (mysql-num-cols) ( mysql-connection -- n ) + mysql-connection-resulthandle mysql_num_fields ; + +: mysql-char*-nth ( index object -- str ) + #! Utility based on 'char*-nth' to perform an additional sanity check on the value + #! extracted from the array of strings. + void*-nth [ alien>char-string ] [ "" ] if* ; + +: mysql-row>seq ( object n -- seq ) + [ swap mysql-char*-nth ] map-with ; + +: (mysql-result>seq) ( seq -- seq ) + my-conn get (mysql-row) dup [ + my-conn get (mysql-num-cols) mysql-row>seq + over push + (mysql-result>seq) + ] [ drop ] if + ! Perform needed cleanup on fetched results + my-conn get (mysql-free-result) ; + +! ========================================================= +! Public Word Definitions +! ========================================================= + + +: mysql-query ( query -- ret ) + >r my-conn get r> (mysql-query) drop + my-conn get (mysql-result) ; + +: mysql-command ( query -- n ) + mysql-query drop + my-conn get (mysql-affected-rows) ; + +: with-mysql ( host user password db port quot -- ) + [ + >r my-conn set + my-conn get mysql-connect drop r> + [ my-conn get mysql-close ] cleanup + ] with-scope ; inline diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor new file mode 100644 index 0000000000..8043bc2782 --- /dev/null +++ b/extra/db/mysql/mysql.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +USING: alien continuations io kernel prettyprint sequences +db ; +IN: db.mysql + +TUPLE: mysql-db handle host user password db port ; + +M: mysql-db db-open ( mysql-db -- ) + ; + +M: mysql-db dispose ( mysql-db -- ) + mysql-db-handle mysql_close ; + + From 13338b04f6f44499b700714bd07adc86ef666931 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:32 -0600 Subject: [PATCH 147/317] remove old mysql --- unmaintained/mysql/libmysql.factor | 35 ------ unmaintained/mysql/load.factor | 11 -- unmaintained/mysql/mysql.factor | 124 ------------------- unmaintained/mysql/test/create_database.sql | 17 --- unmaintained/mysql/test/mysql-example.factor | 57 --------- 5 files changed, 244 deletions(-) delete mode 100644 unmaintained/mysql/libmysql.factor delete mode 100644 unmaintained/mysql/load.factor delete mode 100644 unmaintained/mysql/mysql.factor delete mode 100644 unmaintained/mysql/test/create_database.sql delete mode 100644 unmaintained/mysql/test/mysql-example.factor diff --git a/unmaintained/mysql/libmysql.factor b/unmaintained/mysql/libmysql.factor deleted file mode 100644 index 064c7bffbc..0000000000 --- a/unmaintained/mysql/libmysql.factor +++ /dev/null @@ -1,35 +0,0 @@ -! See http://factorcode.org/license.txt -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/libmysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: alien kernel ; - -"mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } -} cond add-library - -LIBRARY: mysql - -! =============================================== -! mysql.c -! =============================================== - -FUNCTION: void* mysql_init ( void* mysql ) ; -FUNCTION: char* mysql_error ( void* mysql ) ; -FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; -FUNCTION: void mysql_close ( void* sock ) ; -FUNCTION: int mysql_query ( void* mysql, char* q ) ; -FUNCTION: void* mysql_use_result ( void* mysql ) ; -FUNCTION: void mysql_free_result ( void* result ) ; -FUNCTION: char** mysql_fetch_row ( void* result ) ; -FUNCTION: int mysql_num_fields ( void* result ) ; -FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; - diff --git a/unmaintained/mysql/load.factor b/unmaintained/mysql/load.factor deleted file mode 100644 index b3872d6259..0000000000 --- a/unmaintained/mysql/load.factor +++ /dev/null @@ -1,11 +0,0 @@ -! License: See http://factor.sf.net/license.txt for BSD license. -! Berlin Brown -! Date: 1/17/2007 -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a -PROVIDE: libs/mysql -{ +files+ { - "libmysql.factor" - "mysql.factor" -} } ; \ No newline at end of file diff --git a/unmaintained/mysql/mysql.factor b/unmaintained/mysql/mysql.factor deleted file mode 100644 index 22a6bc9248..0000000000 --- a/unmaintained/mysql/mysql.factor +++ /dev/null @@ -1,124 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/mysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: kernel alien errors io prettyprint - sequences namespaces arrays math tools generic ; - -SYMBOL: my-conn - -TUPLE: mysql-connection mysqlconn host user password db port handle resulthandle ; - -: init-mysql ( -- conn ) - f mysql_init ; - -C: mysql-connection ( host user password db port -- mysql-connection ) - [ set-mysql-connection-port ] keep - [ set-mysql-connection-db ] keep - [ set-mysql-connection-password ] keep - [ set-mysql-connection-user ] keep - [ set-mysql-connection-host ] keep ; - -: (mysql-error) ( mysql-connection -- str ) - mysql-connection-mysqlconn mysql_error ; - -: connect-error-msg ( mysql-connection -- s ) - mysql-connection-mysqlconn mysql_error - [ - "Couldn't connect to mysql database.\n" % - "Message: " % % - ] "" make ; - -: mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; - -! ========================================================= -! Low level mysql utility definitions -! ========================================================= - -: (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; - -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; - -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; - -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; - -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; - -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= - -: mysql-close ( mysql-connection -- ) - mysql-connection-mysqlconn mysql_close ; - -: mysql-print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; - -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; - -: mysql-error ( -- s ) - #! Get the last mysql error - my-conn get (mysql-error) ; - -: mysql-result>seq ( -- seq ) - V{ } clone (mysql-result>seq) ; - -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline - -: with-mysql-catch ( host user password db port quot -- ) - [ with-mysql ] catch [ "Caught: " write print ] when* ; - \ No newline at end of file diff --git a/unmaintained/mysql/test/create_database.sql b/unmaintained/mysql/test/create_database.sql deleted file mode 100644 index 00fd323046..0000000000 --- a/unmaintained/mysql/test/create_database.sql +++ /dev/null @@ -1,17 +0,0 @@ --- --- Create three databases (development / test / production) --- with prefix 'factordb_' -create database factordb_development; -create database factordb_test; -create database factordb_production; - -grant all on factordb_development.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; - -grant all on factordb_development.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'*' identified by 'mysqlfactor'; - --- End of the Script - diff --git a/unmaintained/mysql/test/mysql-example.factor b/unmaintained/mysql/test/mysql-example.factor deleted file mode 100644 index 2476153c8a..0000000000 --- a/unmaintained/mysql/test/mysql-example.factor +++ /dev/null @@ -1,57 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Simple test for mysql library -! libs/mysql/test/mysql-example.factor - -IN: mysql-example -REQUIRES: libs/mysql ; -USING: sequences mysql modules prettyprint kernel io math tools namespaces test ; - -"Testing..." print nl - -: get-drop-table ( -- s ) - "DROP TABLE if exists DISCUSSION_FORUM" ; - -: get-insert-table ( -- s ) - { - "INSERT INTO DISCUSSION_FORUM(category, full_name, email, title, main_url, keywords, message) " - "VALUES('none', 'John Doe', 'johndoe@test.com', 'The Message', NULL, NULL, 'Testing')" - } "" join ; - -: get-update-table ( -- s ) - "UPDATE DISCUSSION_FORUM set category = 'my-new-category'" ; - -: get-delete-table ( -- s ) - "DELETE FROM DISCUSSION_FORUM where id = 2" ; - -: get-create-table ( -- s ) - { - "create table DISCUSSION_FORUM(" - "id int(11) NOT NULL auto_increment," - "category varchar(128)," - "full_name varchar(128) NOT NULL," - "email varchar(128) NOT NULL," - "title varchar(255) NOT NULL," - "main_url varchar(255)," - "keywords varchar(255)," - "message text NOT NULL," - "created_on DATETIME NOT NULL DEFAULT '0000-00-0000:00:00'," - "PRIMARY KEY (id));" - } "" join ; - -[ "localhost" "factoruser" "mysqlfactor" "factordb_development" 0 [ - get-drop-table mysql-command drop - get-create-table mysql-command drop - get-update-table mysql-command drop - get-delete-table mysql-command drop - - ! Insert multiple records - 20 [ - get-insert-table mysql-command 2drop - ] each - - "select * from discussion_forum order by created_on" mysql-query drop - mysql-result>seq mysql-print-table - -] with-mysql ] time - -"Done" print \ No newline at end of file From eda2c710d450352314ebf9df616ebaa0e7d390dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:38:59 -0600 Subject: [PATCH 148/317] add dll to script --- misc/factor.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 02f4c4a542..fa8cdcd5b1 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -243,6 +243,8 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/vorbis.dll check_ret wget + wget http://factorcode.org/dlls/sqlite3.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From 354d85342e11f5465432e43662809fc5763d2af0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:57:22 -0600 Subject: [PATCH 149/317] remove dependency on sqlite3 binary --- extra/db/sqlite/sqlite-tests.factor | 45 +++++++++-------------------- 1 file changed, 13 insertions(+), 32 deletions(-) diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index aa7168530b..c6576dcd62 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,40 +3,26 @@ prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary -! "sqlite3 -init test.txt test.db" - -IN: scratchpad : test.db "extra/db/sqlite/test.db" resource-path ; -IN: temporary -: (create-db) ( -- str ) - [ - "sqlite3 -init " % - test.db % - " " % - test.db % - ] "" make ; +[ ] [ [ test.db delete-file ] catch drop ] unit-test -: create-db ( -- ) (create-db) run-process drop ; +[ ] [ + test.db [ + "create table person (name varchar(30), country varchar(30))" sql-command + "insert into person values('John', 'America')" sql-command + "insert into person values('Jane', 'New Zealand')" sql-command + ] with-sqlite +] unit-test -[ ] [ test.db delete-file ] unit-test -[ ] [ create-db ] unit-test - -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ +[ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query ] with-sqlite ] unit-test -[ - { { "John" "America" } } -] [ +[ { { "John" "America" } } ] [ test.db [ "select * from person where name = :name and country = :country" [ @@ -52,15 +38,10 @@ IN: temporary ] with-sqlite ] unit-test -[ - { - { "1" "John" "America" } - { "2" "Jane" "New Zealand" } - } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] +[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test -[ -] [ +[ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command From bc2ce8a77b3f2994bdb07623ea71e942ac77856e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 14:05:31 -0600 Subject: [PATCH 150/317] Space one byte per string --- core/bootstrap/image/image.factor | 2 +- vm/types.c | 4 ---- vm/types.h | 2 +- 3 files changed, 2 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e9ee569fd6..4995d0b572 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -248,7 +248,7 @@ M: wrapper ' emit-seq ; : pack-string ( string -- newstr ) - dup length 1+ bootstrap-cell align 0 pad-right ; + dup length bootstrap-cell align 0 pad-right ; : emit-string ( string -- ptr ) string type-number object tag-number [ diff --git a/vm/types.c b/vm/types.c index 11e92ec754..78e74535b8 100755 --- a/vm/types.c +++ b/vm/types.c @@ -463,10 +463,6 @@ F_STRING* allot_string_internal(CELL capacity) { F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); - /* strings are null-terminated in memory, even though they also - have a length field. The null termination allows us to add - the sizeof(F_STRING) to a Factor string to get a C-style - char* string for C library calls. */ string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; diff --git a/vm/types.h b/vm/types.h index e5003ea069..62b2e06dd0 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + size + 1; + return sizeof(F_STRING) + size; } DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) From dee25cda136cb01c3960946839e43f845e2ec0e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 16:20:07 -0600 Subject: [PATCH 151/317] New generic word implementation reduces compile time --- core/bootstrap/image/image.factor | 53 ++++----------- core/bootstrap/primitives.factor | 10 +-- core/bootstrap/stage1.factor | 1 + core/bootstrap/stage2.factor | 2 +- core/classes/classes.factor | 2 +- core/classes/union/union.factor | 29 ++++++-- core/compiler/compiler.factor | 2 +- core/effects/effects.factor | 16 +++-- core/generator/generator.factor | 10 ++- core/generic/generic-docs.factor | 6 +- core/generic/generic.factor | 77 ++++++++++++++-------- core/generic/math/math.factor | 9 ++- core/generic/standard/standard.factor | 53 +++++++++------ core/inference/backend/backend.factor | 10 ++- core/optimizer/backend/backend.factor | 10 ++- core/words/words.factor | 3 +- extra/benchmark/dispatch5/dispatch5.factor | 77 ++++++++++++++++++++++ extra/tools/crossref/crossref.factor | 3 +- 18 files changed, 254 insertions(+), 119 deletions(-) mode change 100644 => 100755 core/effects/effects.factor mode change 100644 => 100755 core/optimizer/backend/backend.factor create mode 100755 extra/benchmark/dispatch5/dispatch5.factor mode change 100644 => 100755 extra/tools/crossref/crossref.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e9ee569fd6..10715d2c5c 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,7 +203,14 @@ M: f ' ! Words +DEFER: emit-word + +: emit-generic ( generic -- ) + dup "default-method" word-prop method-word emit-word + "methods" word-prop [ nip method-word emit-word ] assoc-each ; + : emit-word ( word -- ) + dup generic? [ dup emit-generic ] when [ dup hashcode ' , dup word-name ' , @@ -224,7 +231,7 @@ M: f ' [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word [ ] [ word-name no-word ] ?if ; + dup target-word swap or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ; ] emit-object ; : emit-tuple ( obj -- pointer ) - objects get [ + [ [ tuple>array unclip transfer-word , % ] { } make tuple type-number dup emit-array - ] cache ; inline + ] + ! Hack + over class word-name "tombstone" = + [ objects get swap cache ] [ call ] if ; M: tuple ' emit-tuple ; M: tombstone ' delegate "((tombstone))" "((empty))" ? "hashtables.private" lookup - word-def first emit-tuple ; + word-def first objects get [ emit-tuple ] cache ; M: array ' array type-number object tag-number emit-array ; @@ -313,41 +323,6 @@ M: quotation ' ] emit-object ] cache ; -! Vectors and sbufs - -M: vector ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - vector ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -M: sbuf ' - dup length swap underlying ' - tuple type-number tuple tag-number [ - 4 emit-fixnum - sbuf ' emit - f ' emit - emit ! array ptr - emit-fixnum ! length - ] emit-object ; - -! Hashes - -M: hashtable ' - [ hash-array ' ] keep - tuple type-number tuple tag-number [ - 5 emit-fixnum - hashtable ' emit - f ' emit - dup hash-count emit-fixnum - hash-deleted emit-fixnum - emit ! array ptr - ] emit-object ; - ! Curries M: curry ' diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 545d904c9c..550aac71b0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -118,11 +118,11 @@ H{ } clone update-map set H{ } clone typemap set num-types get f builtins set -! These symbols are needed by the code that executes below -{ - { "object" "kernel" } - { "null" "kernel" } -} [ create drop ] assoc-each +! Forward definitions +"object" "kernel" create t "class" set-word-prop +"object" "kernel" create union-class "metaclass" set-word-prop + +"null" "kernel" create drop "fixnum" "math" create "fixnum?" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 8af1bfdec9..cc328e9760 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,6 +32,7 @@ vocabs.loader system ; "io.streams.c" require "vocabs.loader" require + "syntax" require "bootstrap.layouts" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5a5a8d1c67..7a0fab8a99 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -15,7 +15,7 @@ IN: bootstrap.stage2 vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" set-global - "math tools help compiler ui ui.tools io" "include" set-global + "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes.factor b/core/classes/classes.factor index a6a1db7045..151429bf69 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: classes USING: arrays definitions assocs kernel diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 0adbdc080d..332903d36b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -generic.standard namespaces arrays ; +generic.standard namespaces arrays math quotations ; IN: classes.union PREDICATE: class union-class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. +: small-union-predicate-quot ( members -- quot ) + dup empty? [ + drop [ drop f ] + ] [ + unclip first "predicate" word-prop swap + [ >r "predicate" word-prop [ dup ] swap append r> ] + assoc-map alist>quot + ] if ; + +: big-union-predicate-quot ( members -- quot ) + [ small-union-predicate-quot ] [ dup ] + class-hash-dispatch-quot ; + : union-predicate-quot ( members -- quot ) - 0 (dispatch#) [ - [ [ drop t ] ] { } map>assoc - object bootstrap-word [ drop f ] 2array add* - single-combination - ] with-variable ; + [ [ drop t ] ] { } map>assoc + dup length 4 <= [ + small-union-predicate-quot + ] [ + flatten-methods + big-union-predicate-quot + ] if ; : define-union-predicate ( class -- ) dup predicate-word diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 1e6d4f8a17..631c2e4f53 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - over word-vocabulary [ compiled-xref ] [ 2drop ] if ; + compiled-xref ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor old mode 100644 new mode 100755 index ee929507c8..10ebca6dea --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ; ] "" make ; : stack-effect ( word -- effect/f ) - dup symbol? [ - drop 0 1 - ] [ - { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip - ] if ; + { + { [ dup symbol? ] [ drop 0 1 ] } + { [ dup "parent-generic" word-prop ] [ + "parent-generic" word-prop stack-effect + ] } + { [ t ] [ + { "declared-effect" "inferred-effect" } + swap word-props [ at ] curry map [ ] find nip + ] } + } cond ; M: effect clone [ effect-in clone ] keep effect-out clone ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index de80872b73..3d66241bc3 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -154,9 +154,17 @@ M: #if generate-node ] generate-1 ] keep ; +: tail-dispatch? ( node -- ? ) + #! Is the dispatch a jump to a tail call to a word? + dup #call? swap node-successor #return? and ; + : dispatch-branches ( node -- ) node-children [ - compiling-word get dispatch-branch %dispatch-label + dup tail-dispatch? [ + node-param + ] [ + compiling-word get dispatch-branch + ] if %dispatch-label ] each ; M: #dispatch generate-node diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index f1cdae1c91..f4da9575e9 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -125,16 +125,12 @@ HELP: method { $description "Looks up a method definition." } { $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ; -{ method method-def method-loc define-method POSTPONE: M: } related-words +{ method define-method POSTPONE: M: } related-words HELP: { $values { "def" "a quotation" } { "method" "a new method definition" } } { $description "Creates a new "{ $link method } " instance." } ; -HELP: sort-methods -{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } } -{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; - HELP: methods { $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } } { $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index c75dd41d74..951813dbcd 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -5,12 +5,7 @@ definitions kernel.private classes classes.private quotations arrays vocabs ; IN: generic -PREDICATE: word generic "combination" word-prop >boolean ; - -M: generic definer drop f f ; - -M: generic definition drop f ; - +! Method combination protocol GENERIC: perform-combination ( word combination -- quot ) M: object perform-combination @@ -22,22 +17,22 @@ M: object perform-combination #! the method will throw an error. We don't want that. nip [ "Invalid method combination" throw ] curry [ ] like ; +GENERIC: method-prologue ( class combination -- quot ) + +M: object method-prologue 2drop [ ] ; + +GENERIC: make-default-method ( generic combination -- method ) + +PREDICATE: word generic "combination" word-prop >boolean ; + +M: generic definer drop f f ; + +M: generic definition drop f ; + : make-generic ( word -- ) dup dup "combination" word-prop perform-combination define ; -: init-methods ( word -- ) - dup "methods" word-prop - H{ } assoc-like - "methods" set-word-prop ; - -: define-generic ( word combination -- ) - dupd "combination" set-word-prop - dup init-methods make-generic ; - -TUPLE: method loc def ; - -: ( def -- method ) - { set-method-def } \ method construct ; +TUPLE: method word def specializer generic loc ; : method ( class generic -- method/f ) "methods" word-prop at ; @@ -48,12 +43,10 @@ PREDICATE: pair method-spec : order ( generic -- seq ) "methods" word-prop keys sort-classes ; -: sort-methods ( assoc -- newassoc ) - [ keys sort-classes ] keep - [ dupd at method-def ] curry { } map>assoc ; - : methods ( word -- assoc ) - "methods" word-prop sort-methods ; + "methods" word-prop + [ keys sort-classes ] keep + [ dupd at method-word ] curry { } map>assoc ; TUPLE: check-method class generic ; @@ -66,10 +59,31 @@ TUPLE: check-method class generic ; swap [ "methods" word-prop swap call ] keep make-generic ; inline -: define-method ( method class generic -- ) - >r >r r> bootstrap-word r> check-method +: method-word-name ( class word -- string ) + word-name "/" rot word-name 3append ; + +: make-method-def ( quot word combination -- quot ) + "combination" word-prop method-prologue swap append ; + +: ( quot class generic -- word ) + [ make-method-def ] 2keep + [ method-word-name f dup ] keep + "parent-generic" set-word-prop + dup rot define ; + +: ( quot class generic -- method ) + check-method + [ ] 3keep f \ method construct-boa ; + +: define-method ( quot class generic -- ) + >r bootstrap-word r> + [ ] 2keep [ set-at ] with-methods ; +: define-default-method ( generic combination -- ) + dupd make-default-method object bootstrap-word pick + "default-method" set-word-prop ; + ! Definition protocol M: method-spec where dup first2 method [ method-loc ] [ second where ] ?if ; @@ -105,3 +119,14 @@ M: class forget* ( class -- ) M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; + +: init-methods ( word -- ) + dup "methods" word-prop + H{ } assoc-like + "methods" set-word-prop ; + +: define-generic ( word combination -- ) + 2dup "combination" set-word-prop + dupd define-default-method + dup init-methods + make-generic ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index d5079c5dfb..8cf83b0ba7 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ; : no-math-method ( left right generic -- * ) \ no-math-method construct-boa throw ; +: default-math-method ( generic -- quot ) + [ no-math-method ] curry [ ] like ; + : applicable-method ( generic class -- quot ) over method - [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ; + [ method-word word-def ] + [ default-math-method ] ?if ; : object-method ( generic -- quot ) object bootstrap-word applicable-method ; @@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ; TUPLE: math-combination ; +M: math-combination make-default-method + drop default-math-method ; + M: math-combination perform-combination drop \ over [ diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 6cc7f7f3e8..94ac82a0e4 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ IN: generic.standard TUPLE: standard-combination # ; +M: standard-combination method-prologue + standard-combination-# object + swap add [ declare ] curry ; + C: standard-combination SYMBOL: (dispatch#) @@ -31,10 +35,10 @@ TUPLE: no-method object generic ; : no-method ( object generic -- * ) \ no-method construct-boa throw ; -: error-method ( word -- method ) +: error-method ( word -- quot ) picker swap [ no-method ] curry append ; -: empty-method ( word -- method ) +: empty-method ( word -- quot ) [ picker % [ delegate dup ] % unpicker over add , @@ -65,13 +69,15 @@ TUPLE: no-method object generic ; ] if ; : default-method ( word -- pair ) - empty-method object bootstrap-word swap 2array ; + "default-method" word-prop method-word + object bootstrap-word swap 2array ; : method-alist>quot ( alist base-class -- quot ) bootstrap-word swap simplify-alist class-predicates alist>quot ; : small-generic ( methods -- def ) + [ 1quotation ] assoc-map object method-alist>quot ; : hash-methods ( methods -- buckets ) @@ -83,9 +89,12 @@ TUPLE: no-method object generic ; ] if ] distribute-buckets ; +: class-hash-dispatch-quot ( methods quot picker -- quot ) + >r >r hash-methods r> map + hash-dispatch-quot r> [ class-hash ] rot 3append ; + : big-generic ( methods -- quot ) - hash-methods [ small-generic ] map - hash-dispatch-quot picker [ class-hash ] rot 3append ; + [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) type>class [ hi-tag bootstrap-word ] unless* ; @@ -100,7 +109,8 @@ TUPLE: no-method object generic ; : build-type-vtable ( alist-seq -- alist-seq ) dup length [ - vtable-class swap simplify-alist + vtable-class + swap [ word-def ] assoc-map simplify-alist class-predicates alist>quot ] 2map ; @@ -137,30 +147,35 @@ TUPLE: no-method object generic ; : standard-methods ( word -- alist ) dup methods swap default-method add* ; +M: standard-combination make-default-method + standard-combination-# (dispatch#) + [ empty-method ] with-variable ; + M: standard-combination perform-combination standard-combination-# (dispatch#) [ [ standard-methods ] keep "inline" word-prop [ small-generic ] [ single-combination ] if ] with-variable ; -: default-hook-method ( word -- pair ) - error-method object bootstrap-word swap 2array ; - -: hook-methods ( word -- methods ) - dup methods [ [ drop ] swap append ] assoc-map - swap default-hook-method add* ; - TUPLE: hook-combination var ; C: hook-combination -M: hook-combination perform-combination +M: hook-combination method-prologue + 2drop [ drop ] ; + +: with-hook ( combination quot -- quot' ) 0 (dispatch#) [ - [ - hook-combination-var [ get ] curry % - hook-methods single-combination % - ] [ ] make - ] with-variable ; + swap slip + hook-combination-var [ get ] curry + swap append + ] with-variable ; inline + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ standard-methods single-combination ] with-hook ; : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 121c555d29..34179bbf32 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -9,9 +9,13 @@ IN: inference.backend : recursive-label ( word -- label/f ) recursive-state get at ; +: inline? ( word -- ? ) + dup "parent-generic" word-prop + [ inline? ] [ "inline" word-prop ] ?if ; + : local-recursive-state ( -- assoc ) recursive-state get dup keys - [ dup word? [ "inline" word-prop ] when not ] find drop + [ dup word? [ inline? ] when not ] find drop [ head-slice ] when* ; : inline-recursive-label ( word -- label/f ) @@ -157,7 +161,7 @@ TUPLE: too-many-r> ; meta-d get push-all ; : if-inline ( word true false -- ) - >r >r dup "inline" word-prop r> r> if ; inline + >r >r dup inline? r> r> if ; inline : consume/produce ( effect node -- ) over effect-in over consume-values @@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ; #merge node, ; inline : make-call-node ( word effect -- ) - swap dup "inline" word-prop + swap dup inline? over dup recursive-label eq? not and [ meta-d get clone -rot recursive-label #call-label [ consume/produce ] keep diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor old mode 100644 new mode 100755 index 4843a9ff26..27b1b1e0ec --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,11 +245,19 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; +: flat-length ( seq -- n ) + [ + dup quotation? over array? or + [ flat-length ] [ drop 1 ] if + ] map sum ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep - method method-def + method method-word + dup word-def flat-length 5 >= + [ 1quotation ] [ word-def ] if ] [ 2drop t t ] if ; diff --git a/core/words/words.factor b/core/words/words.factor index 5dc89212a8..b4062d8f02 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,7 +154,8 @@ SYMBOL: changed-words } reset-props ; : reset-generic ( word -- ) - dup reset-word { "methods" "combination" } reset-props ; + dup reset-word + { "methods" "combination" "default-method" } reset-props ; : gensym ( -- word ) "G:" \ gensym counter number>string append f ; diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor new file mode 100755 index 0000000000..34df715f89 --- /dev/null +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -0,0 +1,77 @@ +USING: classes kernel sequences vocabs math ; +IN: benchmark.dispatch5 + +MIXIN: g + +TUPLE: x1 ; +INSTANCE: x1 g +TUPLE: x2 ; +INSTANCE: x2 g +TUPLE: x3 ; +INSTANCE: x3 g +TUPLE: x4 ; +INSTANCE: x4 g +TUPLE: x5 ; +INSTANCE: x5 g +TUPLE: x6 ; +INSTANCE: x6 g +TUPLE: x7 ; +INSTANCE: x7 g +TUPLE: x8 ; +INSTANCE: x8 g +TUPLE: x9 ; +INSTANCE: x9 g +TUPLE: x10 ; +INSTANCE: x10 g +TUPLE: x11 ; +INSTANCE: x11 g +TUPLE: x12 ; +INSTANCE: x12 g +TUPLE: x13 ; +INSTANCE: x13 g +TUPLE: x14 ; +INSTANCE: x14 g +TUPLE: x15 ; +INSTANCE: x15 g +TUPLE: x16 ; +INSTANCE: x16 g +TUPLE: x17 ; +INSTANCE: x17 g +TUPLE: x18 ; +INSTANCE: x18 g +TUPLE: x19 ; +INSTANCE: x19 g +TUPLE: x20 ; +INSTANCE: x20 g +TUPLE: x21 ; +INSTANCE: x21 g +TUPLE: x22 ; +INSTANCE: x22 g +TUPLE: x23 ; +INSTANCE: x23 g +TUPLE: x24 ; +INSTANCE: x24 g +TUPLE: x25 ; +INSTANCE: x25 g +TUPLE: x26 ; +INSTANCE: x26 g +TUPLE: x27 ; +INSTANCE: x27 g +TUPLE: x28 ; +INSTANCE: x28 g +TUPLE: x29 ; +INSTANCE: x29 g +TUPLE: x30 ; +INSTANCE: x30 g + +: my-classes ( -- seq ) + "benchmark.dispatch5" words [ tuple-class? ] subset ; + +: a-bunch-of-objects ( -- seq ) + my-classes [ construct-empty ] map ; + +: dispatch-benchmark ( -- ) + 1000000 a-bunch-of-objects + [ f [ g? or ] reduce drop ] curry times ; + +MAIN: dispatch-benchmark diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor old mode 100644 new mode 100755 index dfb421c8f8..663df61926 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -14,8 +14,7 @@ IN: tools.crossref : (method-usage) ( word generic -- methods ) tuck methods - [ second quot-uses key? ] with subset - 0 + [ second uses member? ] with subset keys swap [ 2array ] curry map ; : method-usage ( word seq -- methods ) From aff818a07d82a013eb5a9963eeb4397bb0deb3f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 16:40:14 -0600 Subject: [PATCH 152/317] add using --- extra/x/widgets/wm/frame/frame.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index 4e3b4e7c93..b75671fa3c 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,6 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect + math.bitfields x x.gc x.widgets x.widgets.button x.widgets.wm.child From 37bb75b19b1ce245e2522d4d6511b4e7e05dbc3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 16:50:15 -0600 Subject: [PATCH 153/317] Fix extra/delegate --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 4cd25baeb9..c0da9c51bc 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add spin define-method ; + pick add spin define-method ; : define-consult ( class group quot -- ) >r group-words r> From c0c08985c5c46c877ebefcceb034751e6143bd94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:10:49 -0600 Subject: [PATCH 154/317] make hardware-info load on windows --- extra/hardware-info/hardware-info.factor | 7 +++--- .../windows/backend/backend.factor | 6 ----- extra/hardware-info/windows/ce/ce.factor | 4 ++-- extra/hardware-info/windows/nt/nt.factor | 24 +++++++++---------- extra/hardware-info/windows/windows.factor | 7 +++--- 5 files changed, 21 insertions(+), 27 deletions(-) delete mode 100644 extra/hardware-info/windows/backend/backend.factor diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 0515646a5f..69b8678749 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,12 +1,13 @@ -USING: alien.syntax kernel math prettyprint system -combinators vocabs.loader hardware-info.backend ; +USING: alien.syntax kernel math prettyprint +combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : kb. ( x -- ) 10 2^ /f . ; : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< { +<< +{ { [ windows? ] [ "hardware-info.windows" ] } { [ linux? ] [ "hardware-info.linux" ] } { [ macosx? ] [ "hardware-info.macosx" ] } diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor deleted file mode 100644 index 516603c441..0000000000 --- a/extra/hardware-info/windows/backend/backend.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: hardware-info.windows.backend - -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; - diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 1592bad14c..8923d86b03 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,8 +2,8 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince ; -T{ wince } os set-global +TUPLE: wince-os ; +T{ wince-os } os set-global : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 827b32c2f2..8bdb75fe6a 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,16 +1,15 @@ -USING: alien alien.c-types hardware-info.windows.backend +USING: alien alien.c-types kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt -TUPLE: winnt ; - -T{ winnt } os set-global +TUPLE: winnt-os ; +T{ winnt-os } os set-global : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt cpus ( -- n ) +M: winnt-os cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -18,25 +17,25 @@ M: winnt cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt memory-load ( -- n ) +M: winnt-os memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt physical-mem ( -- n ) +M: winnt-os physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt available-mem ( -- n ) +M: winnt-os available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt total-page-file ( -- n ) +M: winnt-os total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt available-page-file ( -- n ) +M: winnt-os available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt total-virtual-mem ( -- n ) +M: winnt-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt available-virtual-mem ( -- n ) +M: winnt-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) @@ -54,4 +53,3 @@ M: winnt available-virtual-mem ( -- n ) ] [ [ alien>u16-string ] keep free ] if ; - diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 67d13fc50f..f3a1eb33f5 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -hardware-info.windows.backend -words combinators vocabs.loader hardware-info.backend ; +words combinators vocabs.loader hardware-info.backend +system ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) @@ -63,7 +63,8 @@ IN: hardware-info.windows : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; +<< { { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } -} cond [ require ] when* +} cond [ require ] when* >> From 5c21b08606848c3c776534fa9c7a8432bb2eb234 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:11:55 -0600 Subject: [PATCH 155/317] remove a line of comments --- extra/db/postgresql/ffi/ffi.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index dbaa70c625..23368164a1 100644 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -! adapted from libpq-fe.h version 7.4.7 ! tested on debian linux with postgresql 8.1 USING: alien alien.syntax combinators system ; From 123aabc730b17e49f8ba27804514f4159db1fe43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 17:33:59 -0600 Subject: [PATCH 156/317] Fix Mac Intel alignment issue --- core/cpu/x86/32/32.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index d3e33c46bd..4ed186d769 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,6 +261,10 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless +macosx? [ + cell "double" c-type set-c-type-align +] when + T{ x86-backend f 4 } compiler-backend set-global : sse2? "Intrinsic" throw ; From 1ae14bbacfcc5c4a58d904779d286a745979a750 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:53:04 -0600 Subject: [PATCH 157/317] skeletonize mysql --- extra/db/mysql/lib/lib.factor | 102 ++++++++++++++-------------------- extra/db/mysql/mysql.factor | 45 ++++++++++++++- 2 files changed, 87 insertions(+), 60 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 7d5c2d55dc..59d1b6ff3d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -14,81 +14,65 @@ TUPLE: mysql-result-set ; : new-mysql ( -- conn ) f mysql_init ; - -: mysql-error-string ( mysql-connection -- str ) - mysql-db-handle mysql_error ; : mysql-error ( mysql -- ) - mysql-error-string throw ; + [ mysql_error throw ] when* ; : mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; + new-mysql over set-mysql-db-handle + dup { + mysql-db-handle + mysql-db-host + mysql-db-user + mysql-db-password + mysql-db-db + mysql-db-port + } get-slots f 0 mysql_real_connect mysql-error ; ! ========================================================= ! Low level mysql utility definitions ! ========================================================= : (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; + >r mysql-db-handle r> mysql_query ; -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; +! : (mysql-result) ( mysql-connection -- ret ) + ! [ mysql-db-handle mysql_use_result ] keep + ! [ set-mysql-connection-resulthandle ] keep ; -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; +! : (mysql-affected-rows) ( mysql-connection -- n ) + ! mysql-connection-mysqlconn mysql_affected_rows ; -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; +! : (mysql-free-result) ( mysql-connection -- ) + ! mysql-connection-resulthandle drop ; -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; +! : (mysql-row) ( mysql-connection -- row ) + ! mysql-connection-resulthandle mysql_fetch_row ; + +! : (mysql-num-cols) ( mysql-connection -- n ) + ! mysql-connection-resulthandle mysql_num_fields ; -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= +! : mysql-char*-nth ( index object -- str ) + ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value + ! #! extracted from the array of strings. + ! void*-nth [ alien>char-string ] [ "" ] if* ; +! : mysql-row>seq ( object n -- seq ) + ! [ swap mysql-char*-nth ] map-with ; -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; +! : (mysql-result>seq) ( seq -- seq ) + ! my-conn get (mysql-row) dup [ + ! my-conn get (mysql-num-cols) mysql-row>seq + ! over push + ! (mysql-result>seq) + ! ] [ drop ] if + ! ! Perform needed cleanup on fetched results + ! my-conn get (mysql-free-result) ; -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; +! : mysql-query ( query -- ret ) + ! >r my-conn get r> (mysql-query) drop + ! my-conn get (mysql-result) ; -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline +! : mysql-command ( query -- n ) + ! mysql-query drop + ! my-conn get (mysql-affected-rows) ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 8043bc2782..941c25e1fa 100644 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for license. USING: alien continuations io kernel prettyprint sequences -db ; +db db.mysql.ffi ; IN: db.mysql TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) ; @@ -13,3 +15,44 @@ M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; +M: mysql-db ( str -- statement ) + ; + +M: mysql-db ( str -- statement ) + ; + +M: mysql-statement prepare-statement ( statement -- ) + ; + +M: mysql-statement bind-statement* ( statement -- ) + ; + +M: mysql-statement rebind-statement ( statement -- ) + ; + +M: mysql-statement execute-statement ( statement -- ) + ; + +M: mysql-statement query-results ( query -- result-set ) + ; + +M: mysql-result-set #rows ( result-set -- n ) + ; + +M: mysql-result-set #columns ( result-set -- n ) + ; + +M: mysql-result-set row-column ( result-set n -- obj ) + ; + +M: mysql-result-set advance-row ( result-set -- ? ) + ; + +M: mysql-db begin-transaction ( -- ) + ; + +M: mysql-db commit-transaction ( -- ) + ; + +M: mysql-db rollback-transaction ( -- ) + ; From 21183af0ceb70821d6de9b6c0dcc5b8f824522ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:56:00 -0600 Subject: [PATCH 158/317] remove sudo requirement --- misc/factor.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index fa8cdcd5b1..d1ef738cd9 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -45,7 +45,6 @@ check_gcc_version() { } check_installed_programs() { - ensure_program_installed sudo ensure_program_installed chmod ensure_program_installed uname ensure_program_installed git From e9b5a6b9d30a1ad21d46978731c4ffc202df8b43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:19 -0600 Subject: [PATCH 159/317] with-process-stream waits for process exit --- extra/io/launcher/launcher-docs.factor | 4 ++-- extra/io/launcher/launcher.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index c30516a83f..e372f7a41e 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -146,8 +146,8 @@ HELP: with-process-stream { $values { "desc" "a launch descriptor" } { "quot" quotation } - { "process" process } } -{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + { "status" "an exit code" } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ; HELP: wait-for-process { $values { "process" process } { "status" integer } } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 09a77fe985..9be90d28de 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -98,10 +98,10 @@ TUPLE: process-stream process ; { set-delegate set-process-stream-process } process-stream construct ; -: with-process-stream ( desc quot -- process ) +: with-process-stream ( desc quot -- status ) swap [ swap with-stream ] keep - process-stream-process ; inline + process-stream-process wait-for-process ; inline : notify-exit ( status process -- ) [ set-process-status ] keep From 2872bc9d306c553b1546a46983d660d36e6dcafd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:31 -0600 Subject: [PATCH 160/317] More method cleanups --- core/compiler/compiler.factor | 2 +- core/effects/effects.factor | 20 +++++++---------- core/generic/generic-docs.factor | 4 ---- core/generic/generic-tests.factor | 3 +++ core/generic/generic.factor | 32 +++++++++++++++------------ core/generic/standard/standard.factor | 2 +- core/inference/backend/backend.factor | 4 ++-- core/words/words.factor | 5 ++++- 8 files changed, 37 insertions(+), 35 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 631c2e4f53..2674734483 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - compiled-xref ; + over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 10ebca6dea..23e8daf122 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs combinators ; @@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ; ")" % ] "" make ; -: stack-effect ( word -- effect/f ) - { - { [ dup symbol? ] [ drop 0 1 ] } - { [ dup "parent-generic" word-prop ] [ - "parent-generic" word-prop stack-effect - ] } - { [ t ] [ - { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip - ] } - } cond ; +GENERIC: stack-effect ( word -- effect/f ) + +M: symbol stack-effect drop 0 1 ; + +M: word stack-effect + { "declared-effect" "inferred-effect" } + swap word-props [ at ] curry map [ ] find nip ; M: effect clone [ effect-in clone ] keep effect-out clone ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index f4da9575e9..631aa7e62d 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -107,10 +107,6 @@ HELP: make-generic { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." } $low-level-note ; -HELP: init-methods -{ $values { "word" word } } -{ $description "Prepare to define a generic word." } ; - HELP: define-generic { $values { "word" word } { "combination" "a method combination" } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index dc888ec30c..f0d5bf3063 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -176,6 +176,9 @@ M: f tag-and-f 4 ; ! define-class hashing issue TUPLE: debug-combination ; +M: debug-combination make-default-method + 2drop [ "Oops" throw ] when ; + M: debug-combination perform-combination drop order [ dup class-hashes ] { } map>assoc sort-keys diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 951813dbcd..78577eaed4 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words kernel sequences namespaces assocs hashtables definitions kernel.private classes classes.private -quotations arrays vocabs ; +quotations arrays vocabs effects ; IN: generic ! Method combination protocol @@ -65,15 +65,20 @@ TUPLE: check-method class generic ; : make-method-def ( quot word combination -- quot ) "combination" word-prop method-prologue swap append ; +PREDICATE: word method-body "method" word-prop >boolean ; + +M: method-body stack-effect + "method" word-prop method-generic stack-effect ; + : ( quot class generic -- word ) [ make-method-def ] 2keep - [ method-word-name f dup ] keep - "parent-generic" set-word-prop + method-word-name f dup rot define ; : ( quot class generic -- method ) check-method - [ ] 3keep f \ method construct-boa ; + [ ] 3keep f \ method construct-boa + dup method-word over "method" set-word-prop ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -120,13 +125,12 @@ M: class forget* ( class -- ) M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; -: init-methods ( word -- ) - dup "methods" word-prop - H{ } assoc-like - "methods" set-word-prop ; - : define-generic ( word combination -- ) - 2dup "combination" set-word-prop - dupd define-default-method - dup init-methods - make-generic ; + over "combination" word-prop over = [ + 2drop + ] [ + 2dup "combination" set-word-prop + over H{ } clone "methods" set-word-prop + dupd define-default-method + make-generic + ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 94ac82a0e4..d52208ccbf 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,7 @@ TUPLE: standard-combination # ; M: standard-combination method-prologue standard-combination-# object - swap add [ declare ] curry ; + swap add* [ declare ] curry ; C: standard-combination diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 34179bbf32..b839b047d6 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,8 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "parent-generic" word-prop - [ inline? ] [ "inline" word-prop ] ?if ; + dup "method" word-prop + [ method-generic inline? ] [ "inline" word-prop ] ?if ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/words/words.factor b/core/words/words.factor index b4062d8f02..93b1185335 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -116,13 +116,16 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; +: crossref? ( word -- ? ) + dup word-vocabulary swap "method" word-prop or ; + : define ( word def -- ) [ ] like over unxref over redefined over set-word-def dup changed-word - dup word-vocabulary [ dup xref ] when drop ; + dup crossref? [ dup xref ] when drop ; : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop From 77a2a2136a0d4837c6f00e66d784fce9bf8d8a97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:43:10 -0600 Subject: [PATCH 161/317] Better method usages work in progres --- core/generic/generic.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 78577eaed4..2100f49423 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -134,3 +134,13 @@ M: assoc update-methods ( assoc -- ) dupd define-default-method make-generic ] if ; + +: subwords ( generic -- seq ) + dup "methods" word-prop values + swap "default-method" word-prop add + [ method-word ] map ; + +: xref-generics ( -- ) + all-words + [ generic? ] subset + [ subwords [ xref ] each ] each ; From 3433adefbe9e8397e5a0f84b4275b50d4da100f0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:58:07 -0600 Subject: [PATCH 162/317] Fix wait-for-pid --- extra/unix/process/process.factor | 2 +- extra/unix/unix.factor | 36 +++++++++++++++++++------------ 2 files changed, 23 insertions(+), 15 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index fb4271ea23..8b7144b979 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -32,4 +32,4 @@ IN: unix.process fork dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 7c3467b052..750a4b5044 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -177,31 +177,39 @@ FUNCTION: int kill ( pid_t pid, int sig ) ; ! Flags for waitpid -: WNOHANG 1 ; -: WUNTRACED 2 ; +: WNOHANG 1 ; inline +: WUNTRACED 2 ; inline -: WSTOPPED 2 ; -: WEXITED 4 ; -: WCONTINUED 8 ; -: WNOWAIT HEX: 1000000 ; +: WSTOPPED 2 ; inline +: WEXITED 4 ; inline +: WCONTINUED 8 ; inline +: WNOWAIT HEX: 1000000 ; inline ! Examining status -: WTERMSIG ( status -- value ) HEX: 7f bitand ; +: WTERMSIG ( status -- value ) + HEX: 7f bitand ; inline -: WIFEXITED ( status -- ? ) WTERMSIG zero? ; +: WIFEXITED ( status -- ? ) + WTERMSIG zero? ; inline -: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ; +: WEXITSTATUS ( status -- value ) + HEX: ff00 bitand -8 shift ; inline -: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ; +: WIFSIGNALED ( status -- ? ) + HEX: 7f bitand 1+ -1 shift 0 > ; inline -: WCOREFLAG ( -- value ) HEX: 80 ; +: WCOREFLAG ( -- value ) + HEX: 80 ; inline -: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ; +: WCOREDUMP ( status -- ? ) + WCOREFLAG bitand zero? not ; inline -: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ; +: WIFSTOPPED ( status -- ? ) + HEX: ff bitand HEX: 7f = ; inline -: WSTOPSIG ( status -- value ) WEXITSTATUS ; +: WSTOPSIG ( status -- value ) + WEXITSTATUS ; inline FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; From f1989fc8c6142671cc27d5f0d14041b05a104d50 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 20:10:00 -0600 Subject: [PATCH 163/317] Fix io.launcher again --- extra/io/unix/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index b44ac80159..93278e2b1a 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -111,7 +111,7 @@ M: unix-io process-stream* 2drop t ] [ find-process dup [ - >r *uint r> notify-exit f + >r *int WEXITSTATUS r> notify-exit f ] [ 2drop f ] if From 6aabef8e3213d0a92fff3688142ae30b5b5e066b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 20:49:40 -0600 Subject: [PATCH 164/317] git pull to master delete staging.*.image --- misc/factor.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..c8e0456b3a 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -196,7 +196,7 @@ git_clone() { git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git + git pull git://factorcode.org/git/factor.git master check_ret git } @@ -219,6 +219,7 @@ delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { From b2cd79ebddb28c312dd1f9bce7bdd756cf6a0bbf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 20:49:59 -0600 Subject: [PATCH 165/317] Fix deploy --- extra/tools/deploy/backend/backend.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index d768b6a334..95d19712c0 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -80,6 +80,7 @@ IN: tools.deploy.backend ] { } make ; : make-deploy-image ( vm image vocab config -- ) + make-boot-image dup staging-image-name exists? [ >r pick r> tuck make-staging-image ] unless From 1f66e8173f955a28416560be41f28707b68bba31 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:26:59 -0600 Subject: [PATCH 166/317] builder: convert to io.launcher --- extra/builder/builder.factor | 151 +++++++++++++++++++---------------- 1 file changed, 82 insertions(+), 69 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 38570ae46f..cb0720d0a9 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,7 @@ -USING: kernel io io.files io.launcher tools.deploy.backend - system namespaces sequences splitting math.parser - unix prettyprint tools.time calendar bake vars ; +USING: kernel io io.files io.launcher hashtables tools.deploy.backend + system continuations namespaces sequences splitting math.parser + prettyprint tools.time calendar bake vars http.client ; IN: builder @@ -19,16 +19,20 @@ IN: builder SYMBOL: builder-recipients -: quote ( str -- str ) "'" swap "'" 3append ; - : email-file ( subject file -- ) `{ - "cat" , - "| mutt -s" ,[ quote ] - "-x" %[ builder-recipients get ] - } - " " join system drop ; - + { +stdin+ , } + { +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } } + } + >hashtable run-process drop ; + +: email-string ( subject -- ) + `{ "mutt" "-s" , %[ builder-recipients get ] } + + dup + dispose + process-stream-process wait-for-process drop ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; @@ -41,74 +45,83 @@ VAR: stamp : build ( -- ) -datestamp >stamp + datestamp >stamp -"/builds/factor" cd -"git pull git://factorcode.org/git/factor.git" system -0 = -[ ] -[ - "builder: git pull" "/dev/null" email-file - "builder: git pull" throw -] -if + "/builds/factor" cd + + { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + run-process process-status + 0 = + [ ] + [ + "builder: git pull" email-string + "builder: git pull" throw + ] + if -"/builds/" stamp> append make-directory -"/builds/" stamp> append cd -"git clone /builds/factor" system drop + "/builds/" stamp> append make-directory + "/builds/" stamp> append cd -"factor" cd + { "git" "clone" "/builds/factor" } run-process drop -{ "git" "show" } -[ readln ] with-stream -" " split second -"../git-id" [ print ] with-stream + "factor" cd -"make clean" system drop + { "git" "show" } + [ readln ] with-stream + " " split second + "../git-id" [ print ] with-stream -"make " target " > ../compile-log" 3append system -0 = -[ ] -[ - "builder: vm compile" "../compile-log" email-file - "builder: vm compile" throw -] if + { "make" "clean" } run-process drop -"wget http://factorcode.org/images/latest/" boot-image-name append system -0 = -[ ] -[ - "builder: image download" "/dev/null" email-file - "builder: image download" throw -] if + `{ + { +arguments+ { "make" ,[ target ] } } + { +stdout+ "../compile-log" } + { +stderr+ +stdout+ } + } + >hashtable run-process process-status + 0 = + [ ] + [ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw + ] if -[ - "./factor -i=" boot-image-name " -no-user-init > ../boot-log" - 3append - system -] -benchmark nip -"../boot-time" [ . ] with-stream -0 = -[ ] -[ - "builder: bootstrap" "../boot-log" email-file - "builder: bootstrap" throw -] if + [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ "builder: image download" email-string ] + recover -[ - "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" - system -] benchmark nip -"../load-everything-time" [ . ] with-stream -0 = -[ ] -[ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw -] if + `{ + { +arguments+ { + "./factor" + ,[ "-i=" boot-image-name append ] + "-no-user-init" + } } + { +stdout+ "../boot-log" } + { +stderr+ +stdout+ } + } + >hashtable + [ run-process process-status ] + benchmark nip "../boot-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw + ] if -; + `{ + { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +stdout+ "../load-everything-log" } + { +stderr+ +stdout+ } + } + >hashtable [ run-process process-status ] benchmark nip + "../load-everything-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw + ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From bd2226d89e09fa14a600238277166a490be96984 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:58:57 -0600 Subject: [PATCH 167/317] builder: add factor-binary word --- extra/builder/builder.factor | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index cb0720d0a9..d20b5b8e5b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,8 @@ USING: kernel io io.files io.launcher hashtables tools.deploy.backend system continuations namespaces sequences splitting math.parser - prettyprint tools.time calendar bake vars http.client ; + prettyprint tools.time calendar bake vars http.client + combinators ; IN: builder @@ -39,6 +40,15 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: factor-binary ( -- name ) + os + { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } + { "windows" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,7 +102,7 @@ VAR: stamp `{ { +arguments+ { - "./factor" + ,[ factor-binary ] ,[ "-i=" boot-image-name append ] "-no-user-init" } } @@ -110,7 +120,8 @@ VAR: stamp ] if `{ - { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +arguments+ + { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } { +stdout+ "../load-everything-log" } { +stderr+ +stdout+ } } From 659b6d8f3c3e2ca0f5deed100e8ace971dd7e4c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:38 -0600 Subject: [PATCH 168/317] Better assert-depth error --- core/debugger/debugger.factor | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 77c6da38e9..53f3387d85 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -87,7 +87,32 @@ TUPLE: assert got expect ; : depth ( -- n ) datastack length ; -: assert-depth ( quot -- ) depth slip depth swap assert= ; +: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) + 2dup [ length ] 2apply min tuck tail >r tail r> ; + +TUPLE: relative-underflow stack ; + +: relative-underflow ( before after -- * ) + trim-datastacks nip \ relative-underflow construct-boa throw ; + +M: relative-underflow summary + drop "Too many items removed from data stack" ; + +TUPLE: relative-overflow stack ; + +M: relative-overflow summary + drop "Superfluous items pushed to data stack" ; + +: relative-overflow ( before after -- * ) + trim-datastacks drop \ relative-overflow construct-boa throw ; + +: assert-depth ( quot -- ) + >r datastack r> swap slip >r datastack r> + 2dup [ length ] compare sgn { + { -1 [ relative-underflow ] } + { 0 [ 2drop ] } + { 1 [ relative-overflow ] } + } case ; inline : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; @@ -222,9 +247,6 @@ M: redefine-error error. "Re-definition of " write redefine-error-def . ; -M: forward-error error. - "Forward reference to " write forward-error-word . ; - M: undefined summary drop "Calling a deferred word before it has been defined" ; From 87887a11654619d03ca37e7d63a87196c5506a7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:49 -0600 Subject: [PATCH 169/317] Monitors tweak --- extra/io/unix/linux/linux.factor | 10 ++-------- extra/io/windows/nt/monitor/monitor.factor | 16 ++++++++-------- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 1707ac9546..dcf1beabf9 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -25,8 +25,6 @@ TUPLE: inotify watches ; : wd>monitor ( wd -- monitor ) watches at ; -: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; - : ( -- port ) H{ } clone inotify_init dup io-error inotify @@ -89,12 +87,8 @@ M: linux-monitor dispose ( monitor -- ) ] { } make ; : parse-file-notify ( buffer -- changed path ) - { - inotify-event-wd - inotify-event-name - inotify-event-mask - } get-slots - parse-action -rot alien>char-string >r wd>path r> path+ ; + { inotify-event-name inotify-event-mask } get-slots + parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) buffer-fill >= ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index d418dff270..6f956760a8 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -65,20 +65,20 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; -: parse-file-notify ( directory buffer -- changed path ) +: parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array -rot - memory>u16-string path+ ; + } get-slots parse-action 1array swap + memory>u16-string ; -: (changed-files) ( directory buffer -- ) - 2dup parse-file-notify changed-file +: (changed-files) ( buffer -- ) + dup parse-file-notify changed-file dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? - [ 3drop ] [ swap (changed-files) ] if ; + [ 2drop ] [ swap (changed-files) ] if ; M: windows-nt-io fill-queue ( monitor -- ) - dup win32-monitor-path over buffer-ptr pick read-changes - [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc + dup buffer-ptr over read-changes + [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc swap set-monitor-queue ; From 2d3298d611ab2fd1dcdfa2b7577928299d8de9bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:59 -0600 Subject: [PATCH 170/317] Method usages cleanup --- core/bootstrap/image/image.factor | 8 +------- core/bootstrap/stage2.factor | 1 + core/compiler/units/units-docs.factor | 9 +-------- core/compiler/units/units.factor | 5 ----- core/definitions/definitions-docs.factor | 4 +--- core/definitions/definitions-tests.factor | 4 +++- core/generic/generic-tests.factor | 2 +- core/generic/generic.factor | 13 ++++++++----- core/generic/standard/standard.factor | 2 +- core/inference/inference.factor | 11 +++++++---- core/optimizer/backend/backend.factor | 2 +- core/parser/parser-docs.factor | 4 +--- core/parser/parser-tests.factor | 4 ++-- core/parser/parser.factor | 10 +++------- core/source-files/source-files.factor | 14 ++++++++++++++ core/vocabs/loader/loader-tests.factor | 2 +- core/words/words-tests.factor | 3 ++- extra/tools/browser/browser.factor | 2 +- extra/tools/crossref/crossref.factor | 17 +---------------- 19 files changed, 50 insertions(+), 67 deletions(-) mode change 100644 => 100755 core/compiler/units/units-docs.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 60e73cb249..3dadee5193 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,14 +203,8 @@ M: f ' ! Words -DEFER: emit-word - -: emit-generic ( generic -- ) - dup "default-method" word-prop method-word emit-word - "methods" word-prop [ nip method-word emit-word ] assoc-each ; - : emit-word ( word -- ) - dup generic? [ dup emit-generic ] when + dup subwords [ emit-word ] each [ dup hashcode ' , dup word-name ' , diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 7a0fab8a99..f3483add57 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -24,6 +24,7 @@ IN: bootstrap.stage2 "Cross-referencing..." print flush H{ } clone crossref set-global xref-words + xref-generics xref-sources ] unless diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor old mode 100644 new mode 100755 index 363b5b5014..99124d40ae --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -28,9 +28,7 @@ HELP: redefine-error HELP: remember-definition { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: old-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ; @@ -38,11 +36,6 @@ HELP: old-definitions HELP: new-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ; -HELP: forward-error -{ $values { "word" word } } -{ $description "Throws a " { $link forward-error } "." } -{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ; - HELP: with-compilation-unit { $values { "quot" quotation } } { $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." } diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 68e1a79185..242ed9854a 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -26,11 +26,6 @@ TUPLE: redefine-error def ; over new-definitions get first key? [ dup redefine-error ] when new-definitions get second (remember-definition) ; -TUPLE: forward-error word ; - -: forward-error ( word -- ) - \ forward-error construct-boa throw ; - : forward-reference? ( word -- ? ) dup old-definitions get assoc-stack [ new-definitions get assoc-stack not ] diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index eec88bba0c..d855a14be9 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -52,9 +52,7 @@ $nl $nl "If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image." $nl -"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used." -{ $subsection forward-error } -"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image." +"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used." $nl "The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case." { $subsection redefine-error } ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index a4cb4de902..f0b0888052 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -6,6 +6,8 @@ TUPLE: combination-1 ; M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 make-default-method 2drop [ "No method" throw ] ; + SYMBOL: generic-1 [ @@ -20,7 +22,7 @@ SYMBOL: generic-1 ] with-compilation-unit ] unit-test -GENERIC: some-generic +GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f0d5bf3063..f1e1ebd6d2 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -177,7 +177,7 @@ M: f tag-and-f 4 ; TUPLE: debug-combination ; M: debug-combination make-default-method - 2drop [ "Oops" throw ] when ; + 2drop [ "Oops" throw ] ; M: debug-combination perform-combination drop diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2100f49423..453d72effb 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -73,7 +73,8 @@ M: method-body stack-effect : ( quot class generic -- word ) [ make-method-def ] 2keep method-word-name f - dup rot define ; + dup rot define + dup xref ; : ( quot class generic -- method ) check-method @@ -135,12 +136,14 @@ M: assoc update-methods ( assoc -- ) make-generic ] if ; -: subwords ( generic -- seq ) +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + +M: generic subwords dup "methods" word-prop values swap "default-method" word-prop add [ method-word ] map ; : xref-generics ( -- ) - all-words - [ generic? ] subset - [ subwords [ xref ] each ] each ; + all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index d52208ccbf..88f6a05bc2 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -91,7 +91,7 @@ TUPLE: no-method object generic ; : class-hash-dispatch-quot ( methods quot picker -- quot ) >r >r hash-methods r> map - hash-dispatch-quot r> [ class-hash ] rot 3append ; + hash-dispatch-quot r> [ class-hash ] rot 3append ; inline : big-generic ( methods -- quot ) [ small-generic ] picker class-hash-dispatch-quot ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index 0fc344dd85..3f52eaadf4 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: inference.backend inference.state inference.dataflow inference.known-words inference.transforms inference.errors -sequences prettyprint io effects kernel namespaces quotations -words vocabs ; +kernel io effects namespaces sequences quotations vocabs +generic words ; IN: inference GENERIC: infer ( quot -- effect ) @@ -28,4 +28,7 @@ M: callable dataflow-with ] with-infer nip ; : forget-errors ( -- ) - all-words [ f "no-effect" set-word-prop ] each ; + all-words [ + dup subwords [ f "no-effect" set-word-prop ] each + f "no-effect" set-word-prop + ] each ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 27b1b1e0ec..9d75346091 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup word-def flat-length 6 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 30e259c033..d8d6c9b7bc 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -202,9 +202,7 @@ HELP: location HELP: save-location { $values { "definition" "a definition specifier" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: parser-notes { $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b00e8e26b4..f503528a24 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -342,7 +342,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ ] [ @@ -354,7 +354,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ t ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ffecf9493e..6d7ad47843 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -235,7 +235,8 @@ M: no-word summary : no-word ( name -- newword ) dup \ no-word construct-boa - swap words-named word-restarts throw-restarts + swap words-named [ forward-reference? not ] subset + word-restarts throw-restarts dup word-vocabulary (use+) ; : check-forward ( str word -- word ) @@ -244,7 +245,7 @@ M: no-word summary dup use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ forward-error ] ?if + [ ] [ no-word ] ?if ] [ nip ] if ; @@ -415,11 +416,6 @@ SYMBOL: interactive-vocabs over stack. ] when 2drop ; -: outside-usages ( seq -- usages ) - dup [ - over usage [ pathname? not ] subset seq-diff - ] curry { } map>assoc ; - : filter-moved ( assoc -- newassoc ) [ drop where dup [ first ] when diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c974145928..64ae2e376e 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -96,3 +96,17 @@ SYMBOL: file source-file-definitions old-definitions set [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline + +: smart-usage ( word -- definitions ) + \ f or usage [ + dup method-body? [ + "method" word-prop + { method-specializer method-generic } get-slots + 2array + ] when + ] map ; + +: outside-usages ( seq -- usages ) + dup [ + over smart-usage [ pathname? not ] subset seq-diff + ] curry { } map>assoc ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f38276d318..560affa566 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -79,7 +79,7 @@ IN: temporary "resource:core/vocabs/loader/test/a/a.factor" parse-stream - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test 0 "count-me" set-global diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 2455250dc9..35a2421e71 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -87,7 +87,8 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset [ interned? not ] subset empty? + \ * usage [ word? ] subset + [ dup interned? swap method-body? or ] all? ] unit-test DEFER: calls-a-gensym diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 370e55eb97..dabc37e5de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -238,7 +238,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ vocab ] map ; inline + remove [ ] subset [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index 663df61926..f6561e9f26 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -3,7 +3,7 @@ USING: arrays definitions assocs io kernel math namespaces prettyprint sequences strings io.styles words generic tools.completion quotations parser inspector -sorting hashtables vocabs ; +sorting hashtables vocabs parser source-files ; IN: tools.crossref : synopsis-alist ( definitions -- alist ) @@ -12,21 +12,6 @@ IN: tools.crossref : definitions. ( alist -- ) [ write-object nl ] assoc-each ; -: (method-usage) ( word generic -- methods ) - tuck methods - [ second uses member? ] with subset keys - swap [ 2array ] curry map ; - -: method-usage ( word seq -- methods ) - [ generic? ] subset [ (method-usage) ] with map concat ; - -: compound-usage ( words -- seq ) - [ generic? not ] subset ; - -: smart-usage ( word -- definitions ) - \ f or - dup usage dup compound-usage -rot method-usage append ; - : usage. ( word -- ) smart-usage synopsis-alist sort-keys definitions. ; From 751a1da3d2fb1ee36d4d5e01238307ff371c4a2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:48:18 -0600 Subject: [PATCH 171/317] Builder tweak --- extra/builder/builder.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index d20b5b8e5b..3216105d47 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -14,7 +14,7 @@ IN: builder ,[ dup timestamp-day ] ,[ dup timestamp-hour ] ,[ timestamp-minute ] } - [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + [ pad-00 ] map "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -29,10 +29,7 @@ SYMBOL: builder-recipients : email-string ( subject -- ) `{ "mutt" "-s" , %[ builder-recipients get ] } - - dup - dispose - process-stream-process wait-for-process drop ; + [ ] with-process-stream drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ba1a958a321efdec8be27cdb4c7b0edcffd13468 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 13:11:36 -0600 Subject: [PATCH 172/317] Move cd and cwd primitives to native I/O, fix Windows normalize-pathname --- core/bootstrap/primitives.factor | 2 - core/bootstrap/stage2.factor | 6 +-- core/io/files/files-docs.factor | 4 +- core/io/files/files.factor | 6 ++- extra/io/unix/files/files.factor | 9 +++- extra/io/windows/nt/backend/backend.factor | 37 +------------ extra/io/windows/nt/files/files.factor | 62 ++++++++++++++++++++-- extra/io/windows/nt/nt-tests.factor | 6 ++- extra/unix/bsd/bsd.factor | 2 + extra/unix/linux/linux.factor | 2 + extra/unix/unix.factor | 1 + extra/windows/kernel32/kernel32.factor | 6 ++- vm/io.h | 2 - vm/os-unix.c | 13 ----- vm/os-windows-ce.c | 10 ---- vm/os-windows-nt.c | 15 ------ vm/os-windows.h | 1 + vm/primitives.c | 2 - 18 files changed, 93 insertions(+), 93 deletions(-) mode change 100644 => 100755 extra/unix/bsd/bsd.factor mode change 100644 => 100755 extra/unix/linux/linux.factor mode change 100644 => 100755 vm/io.h diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 550aac71b0..967840a3dc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class { "millis" "system" } { "type" "kernel.private" } { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f3483add57..c601ba7671 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser ; +math.parser generic ; IN: bootstrap.stage2 ! Wrap everything in a catch which starts a listener so @@ -88,5 +88,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute 1 exit ] recover diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 3a23c8f6ef..0b9a748eb8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,12 +52,12 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; -HELP: cwd ( -- path ) +HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -HELP: cd ( path -- ) +HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6e4648b590..9952e6387b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs ; +HOOK: cd io-backend ( path -- ) + +HOOK: cwd io-backend ( -- path ) + HOOK: io-backend ( path -- stream ) HOOK: io-backend ( path -- stream ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index edee598435..3201c29c45 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,9 +1,16 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations math.bitfields ; IN: io.unix.files +M: unix-io cwd + MAXPATHLEN dup getcwd + [ alien>char-string ] [ (io-error) ] if* ; + +M: unix-io cd + chdir io-error ; + : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 88e7cdf84a..760bcec457 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,45 +2,10 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii ; +strings splitting io.files qualified ascii combinators.lib ; QUALIFIED: windows.winsock IN: io.windows.nt.backend -: unicode-prefix ( -- seq ) - "\\\\?\\" ; inline - -M: windows-nt-io root-directory? ( path -- ? ) - dup length 2 = [ - dup first Letter? - swap second CHAR: : = and - ] [ - drop f - ] if ; - -M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ "pathname must be a string" throw ] unless - "/" split "\\" join - { - ! empty - { [ dup empty? ] [ "empty path" throw ] } - ! .\\foo - { [ dup ".\\" head? ] [ - >r unicode-prefix cwd r> 1 tail 3append - ] } - ! c:\\foo - { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] } - ! \\\\?\\c:\\foo - { [ dup unicode-prefix head? ] [ ] } - ! foo.txt ..\\foo.txt - { [ t ] [ - [ - unicode-prefix % cwd % - dup first CHAR: \\ = [ CHAR: \\ , ] unless % - ] "" make - ] } - } cond [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when ; - SYMBOL: io-hash TUPLE: io-callback port continuation ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 4a304e5ac9..43686707a2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,64 @@ -USING: continuations destructors io.buffers io.nonblocking -io.windows io.windows.nt.backend kernel libc math threads -windows windows.kernel32 ; +USING: continuations destructors io.buffers io.files io.backend +io.nonblocking io.windows io.windows.nt.backend kernel libc math +threads windows windows.kernel32 alien.c-types alien.arrays +sequences combinators combinators.lib ascii splitting alien +strings ; IN: io.windows.nt.files +M: windows-nt-io cwd + MAX_UNICODE_PATH dup "ushort" + [ GetCurrentDirectory win32-error=0/f ] keep + alien>u16-string ; + +M: windows-nt-io cd + SetCurrentDirectory win32-error=0/f ; + +: unicode-prefix ( -- seq ) + "\\\\?\\" ; inline + +M: windows-nt-io root-directory? ( path -- ? ) + dup length 2 = [ + dup first Letter? + swap second CHAR: : = and + ] [ + drop f + ] if ; + +: root-directory ( string -- string' ) + { + [ dup length 2 >= ] + [ dup second CHAR: : = ] + [ dup first Letter? ] + } && [ 2 head ] [ "Not an absolute path" throw ] if ; + +: prepend-prefix ( string -- string' ) + unicode-prefix swap append ; + +: windows-path+ ( cwd path -- newpath ) + { + ! empty + { [ dup empty? ] [ "empty path" throw ] } + ! \\\\?\\c:\\foo + { [ dup unicode-prefix head? ] [ nip ] } + ! ..\\foo + { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + ! .\\foo + { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } + ! \\foo + { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } + ! c:\\foo + { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + ! foo.txt + { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + } cond ; + +M: windows-nt-io normalize-pathname ( string -- string ) + dup string? [ "pathname must be a string" throw ] unless + "/" split "\\" join + cwd swap windows-path+ + [ "/\\." member? ] right-trim + dup peek CHAR: : = [ "\\" append ] when ; + M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index 9dfef6796d..ad409fb083 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ -USING: io.files kernel tools.test ; +USING: io.files kernel tools.test io.backend splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -14,3 +14,7 @@ IN: temporary [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test + +[ ] [ "" resource-path cd ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor old mode 100644 new mode 100755 index 0a5aa1080e..e652f1b9f9 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! FreeBSD +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor old mode 100644 new mode 100755 index 0a3eb7ee5f..11db6cc862 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! Linux. +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 750a4b5044..d32fc25eab 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -124,6 +124,7 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; +FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 45bd6bfae9..b8928c5820 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -892,7 +892,8 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ! FUNCTION: GetCurrentActCtx ! FUNCTION: GetCurrentConsoleFont ! FUNCTION: GetCurrentDirectoryA -! FUNCTION: GetCurrentDirectoryW +FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; +: GetCurrentDirectory GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; ! FUNCTION: GetCurrentProcessId FUNCTION: HANDLE GetCurrentThread ( ) ; @@ -1387,7 +1388,8 @@ FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ; ! FUNCTION: SetCPGlobal ! FUNCTION: SetCriticalSectionSpinCount ! FUNCTION: SetCurrentDirectoryA -! FUNCTION: SetCurrentDirectoryW +FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; +: SetCurrentDirectory SetCurrentDirectoryW ; inline ! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigW ! FUNCTION: SetDllDirectoryA diff --git a/vm/io.h b/vm/io.h old mode 100644 new mode 100755 index d8cc2a0578..39e7390c3e --- a/vm/io.h +++ b/vm/io.h @@ -13,5 +13,3 @@ DECLARE_PRIMITIVE(fread); DECLARE_PRIMITIVE(open_file); DECLARE_PRIMITIVE(stat); DECLARE_PRIMITIVE(read_dir); -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); diff --git a/vm/os-unix.c b/vm/os-unix.c index 41dbe9cabf..92028dfc43 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -115,19 +115,6 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } -DEFINE_PRIMITIVE(cwd) -{ - char wd[MAXPATHLEN]; - if(getcwd(wd,MAXPATHLEN) == NULL) - io_error(); - box_char_string(wd); -} - -DEFINE_PRIMITIVE(cd) -{ - chdir(unbox_char_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index e68a6385ae..9b73692aa0 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -10,16 +10,6 @@ s64 current_millis(void) | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - not_implemented_error(); -} - -DEFINE_PRIMITIVE(cd) -{ - not_implemented_error(); -} - char *strerror(int err) { /* strerror() is not defined on WinCE */ diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..99ac21f62f 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,21 +8,6 @@ s64 current_millis(void) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - F_CHAR buf[MAX_UNICODE_PATH]; - - if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf)) - io_error(); - - box_u16_string(buf); -} - -DEFINE_PRIMITIVE(cd) -{ - SetCurrentDirectory(unbox_u16_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.h b/vm/os-windows.h index f252c214af..a22252fde8 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -30,6 +30,7 @@ typedef wchar_t F_CHAR; F_STRING *get_error_message(void); DLLEXPORT F_CHAR *error_message(DWORD id); +void windows_error(void); void init_ffi(void); void ffi_dlopen(F_DLL *dll, bool error); diff --git a/vm/primitives.c b/vm/primitives.c index f2f8ccf18d..dc7333c667 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -109,8 +109,6 @@ void *primitives[] = { primitive_millis, primitive_type, primitive_tag, - primitive_cwd, - primitive_cd, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, From c68e70877d47bd1239f6a1402edc767a7b6a3dfe Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 Feb 2008 16:42:50 -0500 Subject: [PATCH 173/317] Solution to Project Euler problem 43 --- extra/project-euler/043/043.factor | 97 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +- 2 files changed, 100 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/043/043.factor diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor new file mode 100644 index 0000000000..abe455e273 --- /dev/null +++ b/extra/project-euler/043/043.factor @@ -0,0 +1,97 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib hashtables kernel math math.combinatorics math.parser + math.ranges project-euler.common sequences sorting ; +IN: project-euler.043 + +! http://projecteuler.net/index.php?section=problems&id=43 + +! DESCRIPTION +! ----------- + +! The number, 1406357289, is a 0 to 9 pandigital number because it is made up +! of each of the digits 0 to 9 in some order, but it also has a rather +! interesting sub-string divisibility property. + +! Let d1 be the 1st digit, d2 be the 2nd digit, and so on. In this way, we note +! the following: + +! * d2d3d4 = 406 is divisible by 2 +! * d3d4d5 = 063 is divisible by 3 +! * d4d5d6 = 635 is divisible by 5 +! * d5d6d7 = 357 is divisible by 7 +! * d6d7d8 = 572 is divisible by 11 +! * d7d8d9 = 728 is divisible by 13 +! * d8d9d10 = 289 is divisible by 17 + +! Find the sum of all 0 to 9 pandigital numbers with this property. + + +! SOLUTION +! -------- + +! Brute force generating all the pandigitals then checking 3-digit divisiblity +! properties...this is very slow! + +integer swap mod zero? ; + +: interesting? ( seq -- ? ) + { + [ 17 8 pick subseq-divisible? ] + [ 13 7 pick subseq-divisible? ] + [ 11 6 pick subseq-divisible? ] + [ 7 5 pick subseq-divisible? ] + [ 5 4 pick subseq-divisible? ] + [ 3 3 pick subseq-divisible? ] + [ 2 2 pick subseq-divisible? ] + } && nip ; + +PRIVATE> + +: euler043 ( -- answer ) + 1234567890 number>digits all-permutations + [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + +! [ euler043 ] time +! 125196 ms run / 19548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Build the number from right to left, generating the next 3-digits according +! to the divisiblity rules and combining them with the previous digits if they +! overlap and still have all unique digits. When done with that, add whatever +! missing digit is needed to make the number pandigital. + + [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ; + +: overlap? ( seq -- ? ) + dup first 2 tail* swap second 2 head = ; + +: clean ( seq -- seq ) + [ unclip 1 head add* concat ] map [ all-unique? ] subset ; + +: add-missing-digit ( seq -- seq ) + dup natural-sort 10 seq-diff first add* ; + +: interesting-pandigitals ( -- seq ) + 17 candidates { 13 11 7 5 3 2 } [ + candidates swap cartesian-product [ overlap? ] subset clean + ] each [ add-missing-digit ] map ; + +PRIVATE> + +: euler043a ( -- answer ) + interesting-pandigitals [ 10 swap digits>integer ] sigma ; + +! [ euler043a ] 100 ave-time +! 19 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler043a diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 0be0b456ad..ef28cf8778 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.048 + project-euler.052 project-euler.067 project-euler.075 project-euler.097 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Tue, 5 Feb 2008 16:35:42 -0600 Subject: [PATCH 174/317] Fix MIMIC: --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c0da9c51bc..667805dcc3 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ method-def spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: From 2b9f977912d1472bd909ad58432aa98fd2403e32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:35:57 -0600 Subject: [PATCH 175/317] Fix Windows normalize-pathname --- extra/io/windows/nt/files/files.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 43686707a2..5cbcd063bd 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,8 @@ USING: continuations destructors io.buffers io.files io.backend io.nonblocking io.windows io.windows.nt.backend kernel libc math threads windows windows.kernel32 alien.c-types alien.arrays -sequences combinators combinators.lib ascii splitting alien -strings ; +sequences combinators combinators.lib sequences.lib ascii +splitting alien strings ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -47,7 +47,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\foo { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } ! c:\\foo - { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } } cond ; From 4297777e19bf43a735419f2e898edcfaaa9655eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:36:11 -0600 Subject: [PATCH 176/317] better logging for webapps.planet --- extra/io/server/server.factor | 17 +++++++++-------- extra/webapps/planet/planet.factor | 20 +++++++++++++------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 408fd29714..3c3d2c20f5 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.sockets io.files continuations kernel math math.parser namespaces parser sequences strings @@ -9,11 +9,14 @@ IN: io.server SYMBOL: log-stream +: with-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + : log-message ( str -- ) - log-stream get [ + [ "[" write now timestamp>string write "] " write print flush - ] with-stream* ; + ] with-log-stream ; : log-error ( str -- ) "Error: " swap append log-message ; @@ -24,15 +27,13 @@ SYMBOL: log-stream : log-file ( service -- path ) ".log" append resource-path ; -: with-log-stream ( stream quot -- ) - log-stream swap with-variable ; inline - : with-log-file ( file quot -- ) >r r> - [ with-log-stream ] curry with-disposal ; inline + [ log-stream swap with-variable ] curry + with-disposal ; inline : with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; + stdio get log-stream rot with-variable ; inline : with-logging ( service quot -- ) over [ diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index e9105ee459..ede0c579de 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint ; +xml.writer prettyprint io.server ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,13 +75,11 @@ SYMBOL: cached-postings SYMBOL: last-update -: diagnostic write print flush ; - : fetch-feed ( triple -- feed ) second - dup "Fetching " diagnostic + "Fetching " over append log-message dup download-feed feed-entries - swap "Done fetching " diagnostic ; + "Done fetching " swap append log-message ; : ( author entry -- entry' ) clone @@ -89,7 +87,11 @@ SYMBOL: last-update [ set-entry-title ] keep ; : ?fetch-feed ( triple -- feed/f ) - [ fetch-feed ] [ swap . error. f ] recover ; + [ + fetch-feed + ] [ + swap [ . error. ] with-log-stream f + ] recover ; : fetch-blogroll ( blogroll -- entries ) dup 0 @@ -111,7 +113,11 @@ SYMBOL: last-update update-thread ; : start-update-thread ( -- ) - [ update-thread ] in-thread ; + [ + "webapps.planet" [ + update-thread + ] with-logging + ] in-thread ; "planet" "planet-factor" "extra/webapps/planet" web-app From be39d64ef8e3f7aec8300883ab5a0903f7362b67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:07:37 -0600 Subject: [PATCH 177/317] Check fork() error code --- extra/unix/process/process.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 8b7144b979..c315d10d7f 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -8,7 +8,8 @@ IN: unix.process ! to implement io.launcher on Unix. User code should use ! io.launcher instead. -: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ; +: >argv ( seq -- alien ) + [ malloc-char-string ] map f add >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; @@ -29,7 +30,7 @@ IN: unix.process >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork dup zero? -roll swap curry if ; inline + fork dup io-error dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file From acf236342c8fd42d1ebc8bac81835e20eaa2e0bd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Tue, 5 Feb 2008 17:15:41 -0600 Subject: [PATCH 178/317] Fixing XML's whitespace handling --- extra/state-parser/state-parser.factor | 2 +- extra/xml/xml.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/state-parser/state-parser.factor b/extra/state-parser/state-parser.factor index 19a4af44cc..3f51a52e1b 100644 --- a/extra/state-parser/state-parser.factor +++ b/extra/state-parser/state-parser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: io io.streams.string kernel math namespaces sequences -strings circular prettyprint debugger unicode.categories ; +strings circular prettyprint debugger ascii ; IN: state-parser ! * Basic underlying words diff --git a/extra/xml/xml.factor b/extra/xml/xml.factor index 65a8e28dea..ec3e24b99d 100644 --- a/extra/xml/xml.factor +++ b/extra/xml/xml.factor @@ -3,7 +3,7 @@ USING: io io.streams.string io.files kernel math namespaces prettyprint sequences arrays generic strings vectors xml.char-classes xml.data xml.errors xml.tokenize xml.writer -xml.utilities state-parser assocs unicode.categories ; +xml.utilities state-parser assocs ascii ; IN: xml ! -- Overall parser with data tree From ede3254f0ab9ac092177481af3c5e994a18eb65c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:27:29 -0600 Subject: [PATCH 179/317] Bootstrap prints restarts --- core/bootstrap/stage2.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index c601ba7671..1a9bdd599a 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -88,5 +88,7 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute 1 exit + print-error :c restarts. + "listener" vocab-main execute + 1 exit ] recover From 898770f774005f701301146aaa421fba934b0286 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:31:27 -0600 Subject: [PATCH 180/317] Bootstrap fixes --- extra/io/unix/files/files.factor | 3 ++- extra/unix/process/process.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3201c29c45..a70f7339d2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations math.bitfields ; +unix kernel math continuations math.bitfields byte-arrays +alien ; IN: io.unix.files M: unix-io cwd diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index c315d10d7f..6fdc8e358b 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types sequences math unix combinators.cleave vectors kernel namespaces continuations -threads assocs vectors ; +threads assocs vectors io.unix.backend ; IN: unix.process From 9804d9462de31b3edbaa57dbe355ce0a2a674d22 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:33:36 -0600 Subject: [PATCH 181/317] Rename symbols to be consistent --- extra/io/launcher/launcher-docs.factor | 14 +++++++------- extra/io/launcher/launcher.factor | 16 ++++++++-------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index e372f7a41e..4979f135ac 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -24,11 +24,11 @@ $nl HELP: +environment-mode+ { $description "Launch descriptor key. Must equal of the following:" { $list - { $link prepend-environment } - { $link replace-environment } - { $link append-environment } + { $link +prepend-environment+ } + { $link +replace-environment+ } + { $link +append-environment+ } } -"Default value is " { $link append-environment } "." +"Default value is " { $link +append-environment+ } "." } ; HELP: +stdin+ @@ -61,17 +61,17 @@ HELP: +stderr+ HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; -HELP: prepend-environment +HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ; -HELP: replace-environment +HELP: +replace-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key." $nl "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ; -HELP: append-environment +HELP: +append-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence." $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9be90d28de..f2ed59a591 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -35,9 +35,9 @@ SYMBOL: +stdout+ SYMBOL: +stderr+ SYMBOL: +closed+ -SYMBOL: prepend-environment -SYMBOL: replace-environment -SYMBOL: append-environment +SYMBOL: +prepend-environment+ +SYMBOL: +replace-environment+ +SYMBOL: +append-environment+ : default-descriptor H{ @@ -45,7 +45,7 @@ SYMBOL: append-environment { +arguments+ f } { +detached+ f } { +environment+ H{ } } - { +environment-mode+ append-environment } + { +environment-mode+ +append-environment+ } } ; : with-descriptor ( desc quot -- ) @@ -53,14 +53,14 @@ SYMBOL: append-environment : pass-environment? ( -- ? ) +environment+ get assoc-empty? not - +environment-mode+ get replace-environment eq? or ; + +environment-mode+ get +replace-environment+ eq? or ; : get-environment ( -- env ) +environment+ get +environment-mode+ get { - { prepend-environment [ os-envs union ] } - { append-environment [ os-envs swap union ] } - { replace-environment [ ] } + { +prepend-environment+ [ os-envs union ] } + { +append-environment+ [ os-envs swap union ] } + { +replace-environment+ [ ] } } case ; GENERIC: >descriptor ( desc -- desc ) From f8df69d9a119967ea723a6924829da6a44dba210 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:00:24 -0600 Subject: [PATCH 182/317] Rename io.monitor to io.monitors; add log-viewer demo --- extra/help/handbook/handbook.factor | 4 ++-- extra/io/{monitor => monitors}/authors.txt | 0 .../monitors-docs.factor} | 14 +++++++------- .../monitor.factor => monitors/monitors.factor} | 2 +- extra/io/{monitor => monitors}/summary.txt | 0 extra/io/unix/linux/linux.factor | 2 +- .../windows/nt/{monitor => monitors}/authors.txt | 0 .../monitor.factor => monitors/monitors.factor} | 7 +++---- extra/io/windows/nt/nt.factor | 2 +- extra/log-viewer/authors.txt | 1 + extra/log-viewer/log-viewer.factor | 14 ++++++++++++++ extra/log-viewer/summary.txt | 1 + extra/log-viewer/tags.txt | 1 + 13 files changed, 32 insertions(+), 16 deletions(-) rename extra/io/{monitor => monitors}/authors.txt (100%) rename extra/io/{monitor/monitor-docs.factor => monitors/monitors-docs.factor} (87%) rename extra/io/{monitor/monitor.factor => monitors/monitors.factor} (94%) rename extra/io/{monitor => monitors}/summary.txt (100%) rename extra/io/windows/nt/{monitor => monitors}/authors.txt (100%) rename extra/io/windows/nt/{monitor/monitor.factor => monitors/monitors.factor} (94%) create mode 100755 extra/log-viewer/authors.txt create mode 100755 extra/log-viewer/log-viewer.factor create mode 100755 extra/log-viewer/summary.txt create mode 100755 extra/log-viewer/tags.txt diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 234e7891d7..81e4bea7b3 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap io.monitor ; +USING: io.sockets io.launcher io.mmap io.monitors ; ARTICLE: "io" "Input and output" { $subsection "streams" } @@ -155,7 +155,7 @@ ARTICLE: "io" "Input and output" "Advanced features:" { $subsection "io.launcher" } { $subsection "io.mmap" } -{ $subsection "io.monitor" } ; +{ $subsection "io.monitors" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/io/monitor/authors.txt b/extra/io/monitors/authors.txt similarity index 100% rename from extra/io/monitor/authors.txt rename to extra/io/monitors/authors.txt diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitors/monitors-docs.factor similarity index 87% rename from extra/io/monitor/monitor-docs.factor rename to extra/io/monitors/monitors-docs.factor index de649f48e7..9d985ff3fb 100755 --- a/extra/io/monitor/monitor-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,4 +1,4 @@ -IN: io.monitor +IN: io.monitors USING: help.markup help.syntax continuations ; HELP: @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } @@ -27,7 +27,7 @@ HELP: +modify-file+ HELP: +rename-file+ { $description "Indicates that file has been renamed." } ; -ARTICLE: "io.monitor.descriptors" "File system change descriptors" +ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } @@ -35,24 +35,24 @@ ARTICLE: "io.monitor.descriptors" "File system change descriptors" { $subsection +rename-file+ } { $subsection +add-file+ } ; -ARTICLE: "io.monitor" "File system change monitors" +ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } -{ $subsection "io.monitor.descriptors" } +{ $subsection "io.monitors.descriptors" } "Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." $nl "A utility combinator which opens a monitor and cleans it up after:" { $subsection with-monitor } "An example which watches the Factor directory for changes:" { $code - "USE: io.monitor" + "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" "\"\" resource-path f [ watch-loop ] with-monitor" } ; -ABOUT: "io.monitor" +ABOUT: "io.monitors" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitors/monitors.factor similarity index 94% rename from extra/io/monitor/monitor.factor rename to extra/io/monitors/monitors.factor index 1d8499b392..d652f34f1e 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences assocs hashtables sorting arrays ; -IN: io.monitor +IN: io.monitors ( path recursive? -- monitor ) FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array swap - memory>u16-string ; + } get-slots parse-action 1array -rot memory>u16-string ; : (changed-files) ( buffer -- ) dup parse-file-notify changed-file diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 5bdefd7713..b957aa2fca 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -5,7 +5,7 @@ USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.launcher -USE: io.windows.nt.monitor +USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.backend diff --git a/extra/log-viewer/authors.txt b/extra/log-viewer/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/log-viewer/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor new file mode 100755 index 0000000000..0f139d184e --- /dev/null +++ b/extra/log-viewer/log-viewer.factor @@ -0,0 +1,14 @@ +USING: kernel io io.files io.monitors ; +IN: log-viewer + +: read-lines ( stream -- ) + dup stream-readln dup + [ print read-lines ] [ 2drop flush ] if ; + +: tail-file-loop ( stream monitor -- ) + dup next-change 2drop over read-lines tail-file-loop ; + +: tail-file ( file -- ) + dup dup read-lines + swap parent-directory f + tail-file-loop ; diff --git a/extra/log-viewer/summary.txt b/extra/log-viewer/summary.txt new file mode 100755 index 0000000000..5eb102447a --- /dev/null +++ b/extra/log-viewer/summary.txt @@ -0,0 +1 @@ +Simple log file watcher demo using io.monitors diff --git a/extra/log-viewer/tags.txt b/extra/log-viewer/tags.txt new file mode 100755 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/log-viewer/tags.txt @@ -0,0 +1 @@ +demos From 53810cd17b49a9de41a80977e9c0e03b58be176a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 5 Feb 2008 18:28:05 -0600 Subject: [PATCH 183/317] builder: update target --- extra/builder/builder.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 3216105d47..832b89a7dc 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,7 +33,12 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +: target ( -- target ) + { { [ os "windows" = ] [ "windows-nt-x86-32" ] } + { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 20e4fcecda6d3b2a2d20756ae002fa85c19a1b34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:48:38 -0600 Subject: [PATCH 184/317] Make OS name more consistent for extra/builder --- Makefile | 8 ++++---- core/system/system-docs.factor | 3 ++- core/system/system.factor | 2 +- vm/os-windows-nt.h | 2 +- 4 files changed, 8 insertions(+), 7 deletions(-) mode change 100644 => 100755 core/system/system-docs.factor mode change 100644 => 100755 core/system/system.factor diff --git a/Makefile b/Makefile index aad7fe90eb..5e1a9d6220 100755 --- a/Makefile +++ b/Makefile @@ -63,8 +63,8 @@ default: @echo "macosx-ppc" @echo "solaris-x86-32" @echo "solaris-x86-64" - @echo "windows-ce-arm" - @echo "windows-nt-x86-32" + @echo "wince-arm" + @echo "winnt-x86-32" @echo "" @echo "Additional modifiers:" @echo "" @@ -122,10 +122,10 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -windows-nt-x86-32: +winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -windows-ce-arm: +wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor old mode 100644 new mode 100755 index d80cfa9ceb..bdd04307df --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -51,7 +51,8 @@ HELP: os "openbsd" "netbsd" "solaris" - "windows" + "wince" + "winnt" } } ; diff --git a/core/system/system.factor b/core/system/system.factor old mode 100644 new mode 100755 index 4983260a36..4500720058 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -22,7 +22,7 @@ splitting assocs ; os "wince" = ; foldable : winnt? ( -- ? ) - os "windows" = ; foldable + os "winnt" = ; foldable : windows? ( -- ? ) wince? winnt? or ; foldable diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 9e451f0301..e289b6617d 100755 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -12,7 +12,7 @@ typedef char F_SYMBOL; #define unbox_symbol_string unbox_char_string #define from_symbol_string from_char_string -#define FACTOR_OS_STRING "windows" +#define FACTOR_OS_STRING "winnt" #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" From cf99e405fe22f35900160fc054d401894f101d69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:50:24 -0600 Subject: [PATCH 185/317] More intuitive error message for about --- extra/help/help.factor | 3 +++ 1 file changed, 3 insertions(+) mode change 100644 => 100755 extra/help/help.factor diff --git a/extra/help/help.factor b/extra/help/help.factor old mode 100644 new mode 100755 index 87bc0a4b7f..aefbf2aba2 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -96,6 +96,9 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup vocab [ ] [ + "No such vocabulary: " swap append throw + ] ?if dup vocab-help [ help ] [ From 551b3a42a130eaf0e0ea77e1b9ba873c5e5628db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:52:16 -0600 Subject: [PATCH 186/317] New reset-memoized word --- extra/memoize/memoize.factor | 3 +++ extra/xmode/catalog/catalog.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) mode change 100644 => 100755 extra/xmode/catalog/catalog.factor diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 5fa112921c..3b0b8fd29f 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -50,3 +50,6 @@ M: memoized definition "memo-quot" word-prop ; : memoize-quot ( quot effect -- memo-quot ) gensym swap dupd "declared-effect" set-word-prop dup rot define-memoized 1quotation ; + +: reset-memoized ( word -- ) + "memoize" word-prop clear-assoc ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor old mode 100644 new mode 100755 index 9c7e6a1ee7..d6402603fa --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -99,7 +99,7 @@ SYMBOL: rule-sets (load-mode) dup finalize-mode ; : reset-modes ( -- ) - \ (load-mode) "memoize" word-prop clear-assoc ; + \ (load-mode) reset-memoized ; : ?glob-matches ( string glob/f -- ? ) dup [ glob-matches? ] [ 2drop f ] if ; From 18403d15faf04ade5a159672585fdb4f68a12bff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:10 -0600 Subject: [PATCH 187/317] tools.browser now uses io.monitor --- extra/tools/browser/browser-docs.factor | 22 ++++++++++-- extra/tools/browser/browser.factor | 47 ++++++++++++++++++------- extra/vocabs/monitor/authors.txt | 1 + extra/vocabs/monitor/monitor.factor | 14 ++++++++ extra/vocabs/monitor/summary.txt | 1 + 5 files changed, 71 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/tools/browser/browser-docs.factor create mode 100644 extra/vocabs/monitor/authors.txt create mode 100755 extra/vocabs/monitor/monitor.factor create mode 100644 extra/vocabs/monitor/summary.txt diff --git a/extra/tools/browser/browser-docs.factor b/extra/tools/browser/browser-docs.factor old mode 100644 new mode 100755 index db0e5942f5..28bef58a8a --- a/extra/tools/browser/browser-docs.factor +++ b/extra/tools/browser/browser-docs.factor @@ -2,16 +2,34 @@ USING: help.markup help.syntax io strings ; IN: tools.browser ARTICLE: "vocab-index" "Vocabulary index" -{ $tags,authors } +{ $tags } +{ $authors } { $describe-vocab "" } ; ARTICLE: "tools.browser" "Vocabulary browser" "Getting and setting vocabulary meta-data:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } { $subsection vocab-summary } { $subsection set-vocab-summary } { $subsection vocab-tags } { $subsection set-vocab-tags } -{ $subsection add-vocab-tags } ; +{ $subsection add-vocab-tags } +"Global meta-data:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +{ $subsection all-tags } +{ $subsection all-authors } +"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" +{ $subsection reset-cache } ; + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; HELP: vocab-summary { $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index dabc37e5de..7aefbc8aaa 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -1,13 +1,30 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet ; +help.stylesheet memoize ; IN: tools.browser +MEMO: (vocab-file-contents) ( path -- lines ) + ?resource-path dup exists? + [ lines ] [ drop f ] if ; + +: vocab-file-contents ( vocab name -- seq ) + vocab-path+ dup [ (vocab-file-contents) ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-path+ [ + ?resource-path + [ [ print ] each ] with-stream + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + : vocab-summary-path ( vocab -- string ) vocab-dir "summary.txt" path+ ; @@ -86,7 +103,7 @@ M: vocab-link summary vocab-summary ; dup [ "" vocabs-in-dir ] { } make ] { } map>assoc ; -: all-vocabs-seq ( -- seq ) +MEMO: all-vocabs-seq ( -- seq ) all-vocabs values concat ; : dangerous? ( name -- ? ) @@ -288,20 +305,20 @@ C: vocab-author : $tagged-vocabs ( element -- ) first tagged vocabs. ; -: all-tags ( vocabs -- seq ) [ vocab-tags ] map>set ; +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] map>set ; : $authored-vocabs ( element -- ) first authored vocabs. ; -: all-authors ( vocabs -- seq ) [ vocab-authors ] map>set ; +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] map>set ; -: $tags,authors ( element -- ) - drop - all-vocabs-seq - "Tags" $heading - dup all-tags tags. - "Authors" $heading - all-authors authors. ; +: $tags ( element -- ) + drop "Tags" $heading all-tags tags. ; + +: $authors ( element -- ) + drop "Authors" $heading all-authors authors. ; M: vocab-spec article-title vocab-name " vocabulary" append ; @@ -339,3 +356,9 @@ M: vocab-author article-content M: vocab-author article-parent drop "vocab-index" ; M: vocab-author summary article-title ; + +: reset-cache ( -- ) + \ (vocab-file-contents) reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; diff --git a/extra/vocabs/monitor/authors.txt b/extra/vocabs/monitor/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/vocabs/monitor/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor new file mode 100755 index 0000000000..24aa8b1d99 --- /dev/null +++ b/extra/vocabs/monitor/monitor.factor @@ -0,0 +1,14 @@ +USING: threads io.files io.monitors init kernel tools.browser ; +IN: vocabs.monitor + +! Use file system change monitoring to flush the tags/authors +! cache +: update-thread ( monitor -- ) + dup next-change 2drop reset-cache update-thread ; + +: start-update-thread + [ + "" resource-path t update-thread + ] in-thread ; + +[ start-update-thread ] "tools.browser" add-init-hook diff --git a/extra/vocabs/monitor/summary.txt b/extra/vocabs/monitor/summary.txt new file mode 100644 index 0000000000..27c0d3867a --- /dev/null +++ b/extra/vocabs/monitor/summary.txt @@ -0,0 +1 @@ +Use io.monitors to clear tools.browser authors/tags/summary cache From c87bd84635ed8c984f2cd9d87ef0e14b6711adef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:20 -0600 Subject: [PATCH 188/317] Fix opengl tags --- extra/opengl/tags.txt | 3 --- 1 file changed, 3 deletions(-) mode change 100644 => 100755 extra/opengl/tags.txt diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt old mode 100644 new mode 100755 index 5e477dbcb3..bb863cf9a0 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1,4 +1 @@ -opengl.glu -opengl.gl -opengl bindings From 687cd7860321ac07a36f0c6d96b1c1cd946099b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:28 -0600 Subject: [PATCH 189/317] Word moved --- extra/tools/deploy/config/config.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index e6d03c2233..1f34e68f29 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint namespaces math vocabs -hashtables ; +hashtables tools.browser ; IN: tools.deploy.config SYMBOL: deploy-name From 038578939f998bcdce47e47980cf019e3971105b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:01:19 -0600 Subject: [PATCH 190/317] Change require-all for Ed --- core/vocabs/loader/loader-docs.factor | 13 +++---- core/vocabs/loader/loader.factor | 50 ++++++++++++--------------- extra/bootstrap/io/io.factor | 2 ++ 3 files changed, 30 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 899d50407f..bc88661530 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,15 +124,12 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; +HELP: refresh-all-error +{ $values { "vocabs" "a sequence of vocabularies" } } +{ $description "Throws a " { $link require-all-error } "." } +{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; + HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; { refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index f2c5b2a012..6e6d1923e0 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,16 +148,31 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: require-restart { { "Ignore this vocabulary" t } } ; +: load-error. ( vocab error -- ) + "While loading " swap dup >vocab-link write-object ":" print + print-error ; -: require-all ( seq -- ) - [ +TUPLE: require-all-error vocabs ; + +: require-all-error ( vocabs -- ) + \ require-all-error construct-boa throw ; + +M: require-all-error summary + drop "The require-all operation failed" ; + +: require-all ( vocabs -- ) + dup length 1 = [ first require ] [ [ - [ require ] - [ require-restart rethrow-restarts 2drop ] - recover - ] each - ] with-compiler-errors ; + [ + [ [ require ] [ 2array , ] recover ] each + ] { } make + dup empty? [ drop ] [ + "==== LOAD ERRORS:" print + dup [ nl load-error. ] assoc-each + keys require-all-error + ] if + ] with-compiler-errors + ] if ; : do-refresh ( modified-sources modified-docs -- ) 2dup @@ -190,22 +205,3 @@ load-vocab-hook set-global M: vocab where vocab-where ; M: vocab-link where vocab-where ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ - ?resource-path dup exists? [ - lines - ] [ - drop f - ] if - ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ - ?resource-path - [ [ print ] each ] with-stream - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 065f7dd5c4..4d5440e546 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,3 +10,5 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when + +"vocabs.monitor" require From 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:16:22 -0600 Subject: [PATCH 191/317] Bug fixes --- core/io/files/files.factor | 13 ++++++++----- core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/io/windows/nt/files/files.factor | 12 +++++++++--- extra/io/windows/nt/nt-tests.factor | 22 +++++++++++++++++++--- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9952e6387b..9a99090699 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -29,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? ) M: object root-directory? ( path -- ? ) path-separator? ; -: trim-path-separators ( str -- newstr ) +: right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; +: left-trim-separators ( str -- newstr ) + [ path-separator? ] left-trim ; + : path+ ( str1 str2 -- str ) - >r trim-path-separators "/" r> - [ path-separator? ] left-trim 3append ; + >r right-trim-separators "/" r> + left-trim-separators 3append ; : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; @@ -69,7 +72,7 @@ TUPLE: no-parent-directory path ; \ no-parent-directory construct-boa throw ; : parent-directory ( path -- parent ) - trim-path-separators { + right-trim-separators { { [ dup empty? ] [ drop "/" ] } { [ dup root-directory? ] [ ] } { [ dup [ path-separator? ] contains? not ] [ drop "." ] } @@ -90,7 +93,7 @@ TUPLE: no-parent-directory path ; "resource:" ?head [ resource-path ] when ; : make-directories ( path -- ) - normalize-pathname trim-path-separators { + normalize-pathname right-trim-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index bc88661530..f8626f3370 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,7 +124,7 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: refresh-all-error +HELP: require-all-error { $values { "vocabs" "a sequence of vocabularies" } } { $description "Throws a " { $link require-all-error } "." } { $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6e6d1923e0..64372fe4b7 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,7 +149,7 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " swap dup >vocab-link write-object ":" print + "While loading " rot dup >vocab-link write-object ":" print print-error ; TUPLE: require-all-error vocabs ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 5cbcd063bd..a1c331816c 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -37,11 +37,13 @@ M: windows-nt-io root-directory? ( path -- ? ) : windows-path+ ( cwd path -- newpath ) { ! empty - { [ dup empty? ] [ "empty path" throw ] } + { [ dup empty? ] [ drop ] } + ! .. + { [ dup ".." = ] [ drop parent-directory prepend-prefix ] } ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -49,7 +51,11 @@ M: windows-nt-io root-directory? ( path -- ? ) ! c:\\foo { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt - { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + { [ t ] [ + >r right-trim-separators "\\" r> + left-trim-separators + 3append prepend-prefix + ] } } cond ; M: windows-nt-io normalize-pathname ( string -- string ) diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index ad409fb083..e4ebe3dd37 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,5 @@ -USING: io.files kernel tools.test io.backend splitting ; +USING: io.files kernel tools.test io.backend +io.windows.nt.files splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -9,8 +10,8 @@ IN: temporary [ "Z:" ] [ "Z:\\" parent-directory ] unit-test [ "c:" ] [ "c:" parent-directory ] unit-test [ "Z:" ] [ "Z:" parent-directory ] unit-test -[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test +[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test +[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test @@ -18,3 +19,18 @@ IN: temporary [ ] [ "" resource-path cd ] unit-test [ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test + +[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ + "C:\\builds\\factor\\12345\\" + "..\\log.txt" windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test From 3f9e4bcf0025c03e5a1f3ad0630e8a85f9d3410a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 20:11:35 -0600 Subject: [PATCH 192/317] More efficient specializers --- core/generator/generator.factor | 5 ++- core/optimizer/backend/backend.factor | 6 +-- core/optimizer/known-words/known-words.factor | 16 +++---- core/optimizer/optimizer-docs.factor | 29 ------------- core/optimizer/optimizer.factor | 43 +------------------ .../specializers/specializers-docs.factor | 26 +++++++++++ .../specializers/specializers.factor | 41 ++++++++++++++++++ extra/benchmark/recursive/recursive.factor | 6 --- extra/math/vectors/vectors.factor | 30 ++++++------- 9 files changed, 98 insertions(+), 104 deletions(-) mode change 100644 => 100755 core/optimizer/optimizer-docs.factor mode change 100644 => 100755 core/optimizer/optimizer.factor create mode 100755 core/optimizer/specializers/specializers-docs.factor create mode 100755 core/optimizer/specializers/specializers.factor mode change 100644 => 100755 extra/benchmark/recursive/recursive.factor diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3d66241bc3..3883fb6e35 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -3,8 +3,9 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel -kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words vectors ; +kernel.private layouts math namespaces optimizer +optimizer.specializers prettyprint quotations sequences system +threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9d75346091..e73200b861 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables combinators classes generic.math continuations optimizer.def-use -optimizer.pattern-match generic.standard ; +optimizer.pattern-match generic.standard optimizer.specializers ; IN: optimizer.backend SYMBOL: class-substitutions @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 6 >= + dup word-def flat-length 5 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t @@ -363,7 +363,7 @@ M: #dispatch optimize-node* : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ - >r node-input-classes r> length tail* + >r node-input-classes r> specialized-length tail* [ types length 1 = ] all? ] [ 2drop f diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 6828a0948c..5820d8f5b2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -124,19 +124,19 @@ float-arrays combinators.private combinators ; ] each \ push-all -{ { string array } { sbuf vector } } +{ { string sbuf } { array vector } } "specializer" set-word-prop \ append -{ { string array } { string array } } +{ { string string } { array array } } "specializer" set-word-prop \ subseq -{ fixnum fixnum { string array } } +{ { fixnum fixnum string } { fixnum fixnum array } } "specializer" set-word-prop \ reverse-here -{ { string array } } +{ { string } { array } } "specializer" set-word-prop \ mismatch @@ -147,9 +147,9 @@ float-arrays combinators.private combinators ; \ >string { sbuf } "specializer" set-word-prop -\ >array { { string vector } } "specializer" set-word-prop +\ >array { { string } { vector } } "specializer" set-word-prop -\ >vector { { array vector } } "specializer" set-word-prop +\ >vector { { array } { vector } } "specializer" set-word-prop \ >sbuf { string } "specializer" set-word-prop @@ -163,6 +163,6 @@ float-arrays combinators.private combinators ; \ assoc-stack { vector } "specializer" set-word-prop -\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop -\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop diff --git a/core/optimizer/optimizer-docs.factor b/core/optimizer/optimizer-docs.factor old mode 100644 new mode 100755 index ff694650bc..4be1176cda --- a/core/optimizer/optimizer-docs.factor +++ b/core/optimizer/optimizer-docs.factor @@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math sequences ; IN: optimizer -ARTICLE: "specializers" "Word specializers" -"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." -$nl -"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:" -{ $table - { { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } } - { { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } } - { { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } } - { { $snippet "*" } { "indicates no specialization should be performed on this parameter." } } -} -"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." -$nl -"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." -$nl -"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." -$nl -"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code -"\\ append" -"{ { string array } { string array } }" -"\"specializer\" set-word-prop" -} -"The specialized version of a word which will be compiled by the compiler can be inspected:" -{ $subsection specialized-def } ; - ARTICLE: "optimizer" "Optimizer" "The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them." $nl @@ -43,7 +18,3 @@ HELP: optimize-1 HELP: optimize { $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } } { $description "Continues to optimize a dataflow graph until a fixed point is reached." } ; - -HELP: specialized-def -{ $values { "word" word } { "quot" quotation } } -{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor old mode 100644 new mode 100755 index 66e4ac9220..219b27197f --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -combinators.private classes optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math inference.class -generic.standard ; +USING: kernel namespaces optimizer.backend optimizer.def-use +optimizer.known-words optimizer.math inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -22,39 +19,3 @@ IN: optimizer : optimize ( node -- newnode ) optimize-1 [ optimize ] when ; - -: simple-specializer ( quot dispatch# classes -- quot ) - swap (dispatch#) [ - object add* swap [ 2array ] curry map - object method-alist>quot - ] with-variable ; - -: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot ) - rot (dispatch#) [ - [ - picker % - , - get swap , - \ dispatch , - ] [ ] make - ] with-variable ; - -: tag-specializer ( quot dispatch# -- quot ) - num-tags \ tag dispatch-specializer ; - -: type-specializer ( quot dispatch# -- quot ) - num-types \ type dispatch-specializer ; - -: make-specializer ( quot dispatch# spec -- quot ) - { - { [ dup number eq? ] [ drop tag-specializer ] } - { [ dup object eq? ] [ drop type-specializer ] } - { [ dup \ * eq? ] [ 2drop ] } - { [ dup array? ] [ simple-specializer ] } - { [ t ] [ 1array simple-specializer ] } - } cond ; - -: specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - [ length ] keep [ make-specializer ] 2each - ] when* ; diff --git a/core/optimizer/specializers/specializers-docs.factor b/core/optimizer/specializers/specializers-docs.factor new file mode 100755 index 0000000000..de5d5d7a1f --- /dev/null +++ b/core/optimizer/specializers/specializers-docs.factor @@ -0,0 +1,26 @@ +IN: optimizer.specializers +USING: help.markup help.syntax sequences words quotations ; + +ARTICLE: "specializers" "Word specializers" +"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." +$nl +"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint." +$nl +"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." +$nl +"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." +$nl +"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." +$nl +"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" +{ $code +"\\ append" +"{ { string string } { array array } }" +"\"specializer\" set-word-prop" +} +"The specialized version of a word which will be compiled by the compiler can be inspected:" +{ $subsection specialized-def } ; + +HELP: specialized-def +{ $values { "word" word } { "quot" quotation } } +{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor new file mode 100755 index 0000000000..223ce18117 --- /dev/null +++ b/core/optimizer/specializers/specializers.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic hashtables kernel kernel.private math +namespaces sequences vectors words strings layouts combinators +combinators.private classes generic.standard assocs ; +IN: optimizer.specializers + +: (make-specializer) ( class picker -- quot ) + swap "predicate" word-prop append ; + +: make-specializer ( classes -- quot ) + dup length + [ (picker) 2array ] 2map + [ drop object eq? not ] assoc-subset + dup empty? [ drop [ t ] ] [ + [ (make-specializer) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; + +: tag-specializer ( quot -- newquot ) + [ + [ dup tag ] % + num-tags get swap , + \ dispatch , + ] [ ] make ; + +: specialized-def ( word -- quot ) + dup word-def swap "specializer" word-prop [ + dup { number } = [ + drop tag-specializer + ] [ + dup [ array? ] all? [ 1array ] unless [ + [ make-specializer ] keep + [ declare ] curry pick append + ] { } map>assoc + alist>quot + ] if + ] when* ; + +: specialized-length ( specializer -- n ) + dup [ array? ] all? [ first ] when length ; diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor old mode 100644 new mode 100755 index 79c6dfbaca..6e3c201cf0 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ; : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; -! HINTS: fib { fixnum float } ; -! : ack ( m n -- x ) over zero? [ nip 1+ @@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ; ] if ] if ; -! HINTS: ack fixnum fixnum ; - : tak ( x y z -- t ) pick pick swap < [ [ rot 1- -rot tak ] 3keep @@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ; 2nip ] if ; -! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ; - : recursive ( n -- ) 3 over ack . flush dup 27.0 + fib . flush diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index b2a8995df0..2be9cf7f58 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -27,20 +27,20 @@ IN: math.vectors : set-axis ( u v axis -- w ) dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; -HINTS: vneg { float-array array } ; -HINTS: norm-sq { float-array array } ; -HINTS: norm { float-array array } ; -HINTS: normalize { float-array array } ; +HINTS: vneg { float-array } { array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; -HINTS: n*v * { float-array array } ; -HINTS: v*n { float-array array } * ; -HINTS: n/v * { float-array array } ; -HINTS: v/n { float-array array } * ; +HINTS: n*v { object float-array } { object array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: n/v { object float-array } { array } ; +HINTS: v/n { float-array object } { array object } ; -HINTS: v+ { float-array array } { float-array array } ; -HINTS: v- { float-array array } { float-array array } ; -HINTS: v* { float-array array } { float-array array } ; -HINTS: v/ { float-array array } { float-array array } ; -HINTS: vmax { float-array array } { float-array array } ; -HINTS: vmin { float-array array } { float-array array } ; -HINTS: v. { float-array array } { float-array array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; From 95651daef07cea2485add25be8791f957b67dc86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 22:36:10 -0600 Subject: [PATCH 193/317] Faster parser --- core/parser/parser-docs.factor | 6 ---- core/parser/parser.factor | 47 +++++++++++++++++--------------- extra/multiline/multiline.factor | 4 +-- 3 files changed, 27 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/multiline/multiline.factor diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d8d6c9b7bc..ae38925c68 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer" { $subsection } "A word to test of the end of input has been reached:" { $subsection still-parsing? } -"A word to get the text of the current line:" -{ $subsection line-text } "A word to advance the lexer to the next line:" { $subsection next-line } "Two generic words to override the lexer's token boundary detection:" @@ -222,10 +220,6 @@ HELP: { $values { "msg" "an error" } { "error" parse-error } } { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; -HELP: line-text -{ $values { "lexer" lexer } { "str" string } } -{ $description "Outputs the text of the line being parsed." } ; - HELP: skip { $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } { $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d7ad47843..59d18dc734 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs source-files classes hashtables compiler.errors compiler.units ; IN: parser -TUPLE: lexer text line column ; +TUPLE: lexer text line line-text line-length column ; -: ( text -- lexer ) 1 0 lexer construct-boa ; +: next-line ( lexer -- ) + 0 over set-lexer-column + dup lexer-line over lexer-text ?nth over set-lexer-line-text + dup lexer-line-text length over set-lexer-line-length + dup lexer-line 1+ swap set-lexer-line ; -: line-text ( lexer -- str ) - dup lexer-line 1- swap lexer-text ?nth ; +: ( text -- lexer ) + 0 { set-lexer-text set-lexer-line } lexer construct + dup lexer-text empty? [ dup next-line ] unless ; : location ( -- loc ) file get lexer get lexer-line 2dup and @@ -50,18 +55,14 @@ t parser-notes set-global "Note: " write dup print ] when drop ; -: next-line ( lexer -- ) - 0 over set-lexer-column - dup lexer-line 1+ swap set-lexer-line ; - : skip ( i seq ? -- n ) over >r [ swap CHAR: \s eq? xor ] curry find* drop - [ r> drop ] [ r> length ] if* ; inline + [ r> drop ] [ r> length ] if* ; : change-column ( lexer quot -- ) swap - [ dup lexer-column swap line-text rot call ] keep + [ dup lexer-column swap lexer-line-text rot call ] keep set-lexer-column ; inline GENERIC: skip-blank ( lexer -- ) @@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) dup lexer-line swap lexer-text length <= ; : still-parsing-line? ( lexer -- ? ) - dup lexer-column swap line-text length < ; + dup lexer-column swap lexer-line-length < ; : (parse-token) ( lexer -- str ) [ lexer-column ] keep [ skip-word ] keep [ lexer-column ] keep - line-text subseq ; + lexer-line-text subseq ; : parse-token ( lexer -- str/f ) dup still-parsing? [ @@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ; : ( msg -- error ) file get - lexer get lexer-line - lexer get lexer-column - lexer get line-text + lexer get + { lexer-line lexer-column lexer-line-text } get-slots parse-error construct-boa [ set-delegate ] keep ; @@ -239,22 +239,25 @@ M: no-word summary word-restarts throw-restarts dup word-vocabulary (use+) ; -: check-forward ( str word -- word ) +: check-forward ( str word -- word/f ) dup forward-reference? [ drop - dup use get + use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ no-word ] ?if ] [ nip ] if ; -: search ( str -- word ) - dup use get assoc-stack [ check-forward ] [ no-word ] if* ; +: search ( str -- word/f ) + dup use get assoc-stack check-forward ; : scan-word ( -- word/number/f ) - scan dup [ dup string>number [ ] [ search ] ?if ] when ; + scan dup [ + dup search [ ] [ + dup string>number [ ] [ no-word ] ?if + ] ?if + ] when ; TUPLE: staging-violation word ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor old mode 100644 new mode 100755 index 7f831e5351..9a6d052b60 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -4,7 +4,7 @@ USING: namespaces parser kernel sequences words quotations math ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line line-text ; + lexer get dup next-line lexer-line-text ; : (parse-here) ( -- ) next-line-text dup ";" = @@ -19,7 +19,7 @@ IN: multiline parse-here 1quotation define ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get line-text 2dup start + lexer get lexer-line-text 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) From ac0aa6b3b20354042f1b7dd74e596768391d2a5d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:49:36 -0600 Subject: [PATCH 194/317] do a better merge --- Makefile | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 06d0b28ccf..05a185f643 100755 --- a/Makefile +++ b/Makefile @@ -126,14 +126,10 @@ solaris-x86-64: winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -<<<<<<< HEAD:Makefile -windows-nt-x86-64: +winnt-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 -windows-ce-arm: -======= wince-arm: ->>>>>>> 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6:Makefile $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor From 3bbf622ff4795148fc10e5f9611029550a1c37db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:51:09 -0600 Subject: [PATCH 195/317] update factor.sh for new Makefile renaming --- misc/factor.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..903038a964 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -99,9 +99,9 @@ find_os() { uname_s=`uname -s` check_ret uname case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; @@ -139,7 +139,7 @@ find_word_size() { set_factor_binary() { case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; + winnt) FACTOR_BINARY=factor-nt;; macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; *) FACTOR_BINARY=factor;; esac @@ -227,7 +227,7 @@ get_boot_image() { } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then + if [[ $OS == winnt ]] ; then wget http://factorcode.org/dlls/freetype6.dll check_ret wget wget http://factorcode.org/dlls/zlib1.dll From 4439e394cca6be96a06d85a9532795bd052f8f1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:04:31 -0600 Subject: [PATCH 196/317] fix getcwd --- extra/io/unix/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index a70f7339d2..101114ffb2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,7 +6,7 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup getcwd + MAXPATHLEN dup swap getcwd [ alien>char-string ] [ (io-error) ] if* ; M: unix-io cd From e3e2cc7e0d647b628b245372a7c178ed492f42c4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 5 Feb 2008 23:09:33 -0600 Subject: [PATCH 197/317] Add builder.load-everything --- extra/builder/builder.factor | 57 ++++++++++++------- .../load-everything/load-everything.factor | 23 ++++++++ 2 files changed, 58 insertions(+), 22 deletions(-) create mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 832b89a7dc..375023cb5e 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,19 +33,19 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -: target ( -- target ) - { { [ os "windows" = ] [ "windows-nt-x86-32" ] } - { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } - cond ; +! : target ( -- target ) +! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } +! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } +! cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "windows" [ "./factor-nt.exe" ] } + { "winnt" [ "./factor-nt.exe" ] } [ drop "./factor" ] } case ; @@ -61,7 +61,13 @@ VAR: stamp "/builds/factor" cd - { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } run-process process-status 0 = [ ] @@ -74,7 +80,7 @@ VAR: stamp "/builds/" stamp> append make-directory "/builds/" stamp> append cd - { "git" "clone" "/builds/factor" } run-process drop + { "git" "clone" "../factor" } run-process drop "factor" cd @@ -121,20 +127,27 @@ VAR: stamp "builder: bootstrap" throw ] if - `{ - { +arguments+ - { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } - { +stdout+ "../load-everything-log" } - { +stderr+ +stdout+ } - } - >hashtable [ run-process process-status ] benchmark nip - "../load-everything-time" [ . ] with-stream - 0 = - [ ] - [ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw - ] if ; +! `{ +! { +arguments+ +! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } +! { +stdout+ "../load-everything-log" } +! { +stderr+ +stdout+ } +! } +! >hashtable [ run-process process-status ] benchmark nip +! "../load-everything-time" [ . ] with-stream +! 0 = +! [ ] +! [ +! "builder: load-everything" "../load-everything-log" email-file +! "builder: load-everything" throw +! ] if ; + + `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + "../load-everything-log" exists? + [ "builder: load-everything" "../load-everything-log" email-file ] + when + + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor new file mode 100644 index 0000000000..12007f214b --- /dev/null +++ b/extra/builder/load-everything/load-everything.factor @@ -0,0 +1,23 @@ + +USING: kernel continuations io io.files prettyprint vocabs.loader + tools.time tools.browser ; + +IN: builder.load-everything + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: do-load-everything ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when ; + +MAIN: do-load-everything \ No newline at end of file From 537d94566005c51b29fe358f79d2709b33c4b392 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:14:10 -0600 Subject: [PATCH 198/317] fix getcwd --- extra/io/unix/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 101114ffb2..3bf0e3f897 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,8 +6,8 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup swap getcwd - [ alien>char-string ] [ (io-error) ] if* ; + MAXPATHLEN dup swap + getcwd [ (io-error) ] unless* ; M: unix-io cd chdir io-error ; From d27ae067089d7d196cc9634fd87940e0717ca236 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 Feb 2008 00:53:18 -0500 Subject: [PATCH 199/317] Solution to Project Euler problem 44 --- extra/project-euler/044/044.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 7 ++-- 2 files changed, 54 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/044/044.factor diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor new file mode 100644 index 0000000000..6369cb5372 --- /dev/null +++ b/extra/project-euler/044/044.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges project-euler.common sequences ; +IN: project-euler.044 + +! http://projecteuler.net/index.php?section=problems&id=44 + +! DESCRIPTION +! ----------- + +! Pentagonal numbers are generated by the formula, Pn=n(3n−1)/2. The first ten +! pentagonal numbers are: + +! 1, 5, 12, 22, 35, 51, 70, 92, 117, 145, ... + +! It can be seen that P4 + P7 = 22 + 70 = 92 = P8. However, their difference, +! 70 − 22 = 48, is not pentagonal. + +! Find the pair of pentagonal numbers, Pj and Pk, for which their sum and +! difference is pentagonal and D = |Pk − Pj| is minimised; what is the value of D? + + +! SOLUTION +! -------- + +! Brute force using a cartesian product and an arbitrarily chosen limit. + + [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ; + +: sum-and-diff? ( m n -- ? ) + 2dup + -rot - [ pentagonal? ] 2apply and ; + +PRIVATE> + +: euler044 ( -- answer ) + 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product + [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ; + +! [ euler044 ] 10 ave-time +! 8924 ms run / 2872 ms GC ave time - 10 trials + +! TODO: this solution is ugly and not very efficient...find a better algorithm + +MAIN: euler044 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index ef28cf8778..36a9069d77 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.043 project-euler.048 - project-euler.052 project-euler.067 project-euler.075 project-euler.097 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.044 + project-euler.048 project-euler.052 project-euler.067 project-euler.075 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Wed, 6 Feb 2008 04:26:13 -0600 Subject: [PATCH 200/317] Add builder.test --- extra/builder/builder.factor | 46 +++++++++++++--------------------- extra/builder/test/test.factor | 33 ++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 28 deletions(-) create mode 100644 extra/builder/test/test.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 375023cb5e..2acdbc3294 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -8,6 +8,15 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : datestamp ( -- string ) now `{ ,[ dup timestamp-year ] ,[ dup timestamp-month ] @@ -35,11 +44,6 @@ SYMBOL: builder-recipients : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -! : target ( -- target ) -! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } -! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } -! cond ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) @@ -84,10 +88,8 @@ VAR: stamp "factor" cd - { "git" "show" } - [ readln ] with-stream - " " split second - "../git-id" [ print ] with-stream + { "git" "show" } [ readln ] with-stream " " split second + "../git-id" log-object { "make" "clean" } run-process drop @@ -117,9 +119,7 @@ VAR: stamp { +stdout+ "../boot-log" } { +stderr+ +stdout+ } } - >hashtable - [ run-process process-status ] - benchmark nip "../boot-time" [ . ] with-stream + >hashtable [ run-process ] "../boot-time" log-runtime process-status 0 = [ ] [ @@ -127,26 +127,16 @@ VAR: stamp "builder: bootstrap" throw ] if -! `{ -! { +arguments+ -! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } -! { +stdout+ "../load-everything-log" } -! { +stderr+ +stdout+ } -! } -! >hashtable [ run-process process-status ] benchmark nip -! "../load-everything-time" [ . ] with-stream -! 0 = -! [ ] -! [ -! "builder: load-everything" "../load-everything-log" email-file -! "builder: load-everything" throw -! ] if ; - - `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop + "../load-everything-log" exists? [ "builder: load-everything" "../load-everything-log" email-file ] when + "../failing-tests" exists? + [ "builder: failing tests" "../failing-tests" email-file ] + when + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor new file mode 100644 index 0000000000..ed75e99527 --- /dev/null +++ b/extra/builder/test/test.factor @@ -0,0 +1,33 @@ + +USING: kernel sequences assocs builder continuations vocabs vocabs.loader + io + io.files + tools.browser + tools.test ; + +IN: builder.test + +: do-load ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when* ; + +: do-tests ( -- ) + "" child-vocabs + [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + dup empty? + [ drop ] + [ + "../failing-tests" + [ [ nl failures. ] assoc-each ] + with-stream + ] + if ; + +: do-all ( -- ) do-load do-tests ; + +MAIN: do-all \ No newline at end of file From a5c69dae631af981fdc598828c44ecdc12423bbe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 06:10:55 -0600 Subject: [PATCH 201/317] update builder.test --- .../load-everything/load-everything.factor | 23 ------------------- extra/builder/test/test.factor | 9 +++++--- 2 files changed, 6 insertions(+), 26 deletions(-) delete mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor deleted file mode 100644 index 12007f214b..0000000000 --- a/extra/builder/load-everything/load-everything.factor +++ /dev/null @@ -1,23 +0,0 @@ - -USING: kernel continuations io io.files prettyprint vocabs.loader - tools.time tools.browser ; - -IN: builder.load-everything - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: runtime ( quot -- time ) benchmark nip ; - -: log-runtime ( quot file -- ) - >r runtime r> [ . ] with-stream ; - -: log-object ( object file -- ) [ . ] with-stream ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: do-load-everything ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when ; - -MAIN: do-load-everything \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index ed75e99527..fb9c62e2aa 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -8,9 +8,12 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test : do-load ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when* ; + [ + [ load-everything ] + [ require-all-error-vocabs "../load-everything-log" log-object ] + recover + ] + "../load-everything-time" log-runtime ; : do-tests ( -- ) "" child-vocabs From 548e6dce4774507eb289968268438c255028c054 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:09:42 -0600 Subject: [PATCH 202/317] Fixing crossreferencing --- core/compiler/test/redefine.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic-tests.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic.factor | 7 +++++- core/words/words.factor | 29 ++++++++++------------ extra/help/handbook/handbook.factor | 2 ++ 5 files changed, 94 insertions(+), 18 deletions(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 01dd27f8be..9bcdcdfcde 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -250,3 +250,40 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test [ 2 1 ] [ defer-redefine-test-2 ] unit-test + +! Cross-referencing issue +: compiled-xref-a ; + +: compiled-xref-c ; inline + +GENERIC: compiled-xref-b ( a -- b ) + +TUPLE: c-1 ; + +M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ; + +TUPLE: c-2 ; + +M: c-2 compiled-xref-b drop 3 ; + +[ t ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + [ + \ compiled-xref-a forget + ] with-compilation-unit +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f1e1ebd6d2..4de05aafd0 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -203,3 +203,40 @@ TUPLE: redefinition-test-tuple ; redefinition-test-generic , ] { } make all-equal? ] unit-test + +! Issues with forget +GENERIC: generic-forget-test-1 + +M: integer generic-forget-test-1 / ; + +[ t ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +GENERIC: generic-forget-test-2 + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test + +[ ] [ + [ { sequence generic-forget-test-2 } forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 453d72effb..53f47c09d5 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,7 +102,9 @@ M: method-spec definition first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) - check-method [ delete-at ] with-methods ; + check-method + [ delete-at* ] with-methods + [ method-word forget ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -145,5 +147,8 @@ M: generic subwords swap "default-method" word-prop add [ method-word ] map ; +M: generic forget-word + dup subwords [ forget-word ] each (forget-word) ; + : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/words/words.factor b/core/words/words.factor index 93b1185335..c2118598af 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -71,7 +71,9 @@ GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; -M: interned (quot-uses) dupd set-at ; +M: word (quot-uses) + >r dup "forgotten" word-prop + [ r> 2drop ] [ dup r> set-at ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -194,24 +196,17 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: (forget-word) ( word -- ) +GENERIC: forget-word ( word -- ) -M: interned (forget-word) - dup word-name swap word-vocabulary vocab-words delete-at ; +: (forget-word) ( word -- ) + dup "forgotten" word-prop [ + dup delete-xref + dup delete-compiled-xref + dup word-name over word-vocabulary vocab-words delete-at + dup t "forgotten" set-word-prop + ] unless drop ; -M: word (forget-word) - drop ; - -: rename-word ( word newname newvocab -- ) - pick (forget-word) - pick set-word-vocabulary - over set-word-name - reveal ; - -: forget-word ( word -- ) - dup delete-xref - dup delete-compiled-xref - (forget-word) ; +M: word forget-word (forget-word) ; M: word forget* forget-word ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 81e4bea7b3..d6b4ec7ffe 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -32,6 +32,8 @@ $nl { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } +{ $heading "Stack effect conventions" } +"Stack effect conventions are documented in " { $link "effect-declaration" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table From 38b4f67b70d7cbe007fdb525dc8931edae8bd6b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:44:13 -0600 Subject: [PATCH 203/317] Save bootstrap time in a global variable --- core/bootstrap/stage2.factor | 79 +++++++++++++++++++++++------------- 1 file changed, 51 insertions(+), 28 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 1a9bdd599a..9dd56c6524 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -8,25 +8,63 @@ definitions assocs compiler.errors compiler.units math.parser generic ; IN: bootstrap.stage2 +SYMBOL: bootstrap-time + +: default-image-name ( -- string ) + vm file-name windows? [ "." split1 drop ] when + ".image" append ; + +: do-crossref ( -- ) + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-generics + xref-sources ; + +: load-components ( -- ) + "exclude" "include" + [ get-global " " split [ empty? not ] subset ] 2apply + seq-diff + [ "bootstrap." swap append require ] each ; + +: compile-remaining ( -- ) + "Compiling remaining words..." print flush + vocabs [ + words "compile" "compiler" lookup execute + ] each ; + +: count-words ( pred -- ) + all-words swap subset length number>string write ; + +: print-report ( time -- ) + 1000 /i + 60 /mod swap + "Bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + [ compiled? ] count-words " compiled words" print + [ symbol? ] count-words " symbol words" print + [ ] count-words " words total" print + + "Bootstrapping is complete." print + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush ; + ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ "." split1 drop ] when - ".image" append "output-image" set-global + ! We time bootstrap + millis >r + + default-image-name "output-image" set-global "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line - "-no-crossref" cli-args member? [ - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources - ] unless + "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -40,19 +78,12 @@ IN: bootstrap.stage2 ] if [ - "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply - seq-diff - [ "bootstrap." swap append require ] each + load-components run-bootstrap-init - "Compiling remaining words..." print flush - "bootstrap.compiler" vocab [ - vocabs [ - words "compile" "compiler" lookup execute - ] each + compile-remaining ] when ] with-compiler-errors :errors @@ -74,16 +105,8 @@ IN: bootstrap.stage2 ] [ print-error 1 exit ] recover ] set-boot-quot - : count-words ( pred -- ) - all-words swap subset length number>string write ; - - [ compiled? ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - - "Bootstrapping is complete." print - "Now, you can run Factor:" print - vm write " -i=" write "output-image" get print flush + millis r> - dup bootstrap-time set-global + print-report "output-image" get resource-path save-image-and-exit ] if From d9338b1cd26a519d00fee2bbab7cebdcf888ecb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:47:15 -0600 Subject: [PATCH 204/317] Remove interned predicate class --- core/classes/classes-tests.factor | 4 +++- core/compiler/test/redefine.factor | 4 +--- core/source-files/source-files.factor | 2 +- core/tuples/tuples-tests.factor | 2 +- core/vocabs/vocabs-docs.factor | 2 +- core/words/words-docs.factor | 16 +--------------- core/words/words-tests.factor | 11 +---------- core/words/words.factor | 21 ++++++++++++--------- 8 files changed, 21 insertions(+), 41 deletions(-) mode change 100644 => 100755 core/vocabs/vocabs-docs.factor diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 854e6add5a..efff0db5d1 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -172,7 +172,9 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; FORGET: forget-class-bug-1 FORGET: forget-class-bug-2 -[ t ] [ integer dll class-or interned? ] unit-test +[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test + +[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test DEFER: mixin-forget-test-g diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 9bcdcdfcde..5d07e764d6 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -92,8 +92,6 @@ DEFER: x-4 [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test -[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test - DEFER: g-test-1 DEFER: g-test-3 @@ -237,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test +[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 64ae2e376e..7ddf6f02c0 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -38,7 +38,7 @@ uses definitions ; : (xref-source) ( source-file -- pathname uses ) dup source-file-path swap source-file-uses - [ interned? ] subset ; + [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index edd2387645..627ee5562f 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma interned? ] unit-test + [ f ] [ \ yo-momma crossref ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor old mode 100644 new mode 100755 index cb2cabb369..f16a33f0d5 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -76,7 +76,7 @@ HELP: all-words HELP: forget-vocab { $values { "vocab" string } } -{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." } +{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: load-vocab-hook diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 24e81c70a6..62848e46b2 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -14,9 +14,7 @@ $nl { $subsection lookup } "Words can output their name and vocabulary:" { $subsection word-name } -{ $subsection word-vocabulary } -"Testing if a word object is part of a vocabulary:" -{ $subsection interned? } ; +{ $subsection word-vocabulary } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -369,18 +367,6 @@ HELP: delimiter? { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; -HELP: interned -{ $class-description "The class of words defined in the " { $link dictionary } "." } -{ $examples - { $example "\\ + interned? ." "t" } - { $example "gensym interned? ." "f" } -} ; - -HELP: rename-word -{ $values { "word" word } { "newname" string } { "newvocab" string } } -{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." } -{ $side-effects "word" } ; - HELP: make-flushable { $values { "word" word } } { $description "Declares a word as " { $link POSTPONE: flushable } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 35a2421e71..92f5284c49 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -54,22 +54,14 @@ GENERIC: testing [ f ] [ \ testing generic? ] unit-test -[ f ] [ gensym interned? ] unit-test - : forgotten ; : another-forgotten ; -[ f ] [ \ forgotten interned? ] unit-test - FORGET: forgotten -[ f ] [ \ another-forgotten interned? ] unit-test - FORGET: another-forgotten : another-forgotten ; -[ t ] [ \ + interned? ] unit-test - ! I forgot remove-crossref calls! : fee ; : foe fee ; @@ -87,8 +79,7 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset - [ dup interned? swap method-body? or ] all? + \ * usage [ word? ] subset [ crossref? ] all? ] unit-test DEFER: calls-a-gensym diff --git a/core/words/words.factor b/core/words/words.factor index c2118598af..f628d68bee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: words USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting math.parser words.private -vocabs ; +vocabs combinators ; +IN: words : word ( -- word ) \ word get-global ; @@ -65,15 +65,20 @@ SYMBOL: bootstrapping? : bootstrap-word ( word -- target ) [ target-word ] [ ] if-bootstrapping ; -PREDICATE: word interned dup target-word eq? ; +: crossref? ( word -- ? ) + { + { [ dup "forgotten" word-prop ] [ f ] } + { [ dup "method" word-prop ] [ t ] } + { [ dup word-vocabulary ] [ t ] } + { [ t ] [ f ] } + } cond nip ; GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; M: word (quot-uses) - >r dup "forgotten" word-prop - [ r> 2drop ] [ dup r> set-at ] if ; + >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -94,6 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) + [ crossref? ] subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; @@ -118,9 +124,6 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; -: crossref? ( word -- ? ) - dup word-vocabulary swap "method" word-prop or ; - : define ( word def -- ) [ ] like over unxref From 8a4db990297699eb69f1e5c105230fa75314dc54 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:15:15 -0600 Subject: [PATCH 205/317] Improved tools.test --- extra/tools/test/test.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2a26c8639e..aa994e91d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units ; +vocabs.loader source-files compiler.units inspector ; IN: tools.test SYMBOL: failures @@ -30,9 +30,17 @@ SYMBOL: this-test TUPLE: expected-error ; -: unit-test-fails ( quot -- ) - [ f ] append [ [ drop t ] recover ] curry - [ t ] swap unit-test ; +M: expected-error summary + drop + "The unit test expected the quotation to throw an error" ; + +: must-fail-with ( quot test -- ) + >r [ expected-error construct-empty throw ] compose r> + [ recover ] 2curry + [ ] swap unit-test ; + +: must-fail ( quot -- ) + [ drop t ] must-fail-with ; : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit From be2c8b13d742c843ed5cc1d1fe7019808d87d933 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:47:19 -0600 Subject: [PATCH 206/317] Rename unit-test-fails to must-fail and add must-fail-with to replace [ t ] [ [ ... ] catch ... ] unit-test idiom --- core/alien/alien-tests.factor | 6 +- core/alien/c-types/c-types-tests.factor | 2 +- core/arrays/arrays-tests.factor | 12 +-- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/byte-arrays/byte-arrays-tests.factor | 2 +- core/classes/classes-tests.factor | 6 +- core/combinators/combinators-tests.factor | 2 +- core/compiler/test/alien.factor | 20 ++--- core/compiler/test/intrinsics.factor | 4 +- core/compiler/test/optimizer.factor | 4 +- core/compiler/test/redefine.factor | 2 +- core/compiler/test/simple.factor | 4 +- core/compiler/test/stack-trace.factor | 8 +- core/continuations/continuations-docs.factor | 12 +-- core/continuations/continuations-tests.factor | 42 +++++----- core/continuations/continuations.factor | 10 +-- core/float-arrays/float-arrays-tests.factor | 2 +- core/generic/generic-tests.factor | 8 +- core/growable/growable-tests.factor | 8 +- core/hashtables/hashtables-tests.factor | 6 +- core/heaps/heaps-tests.factor | 4 +- core/inference/inference-tests.factor | 72 +++++++---------- .../transforms/transforms-tests.factor | 2 +- core/io/streams/duplex/duplex-tests.factor | 4 +- core/kernel/kernel-tests.factor | 46 +++++------ core/listener/listener-tests.factor | 4 +- core/math/integers/integers-tests.factor | 4 +- core/math/parser/parser-tests.factor | 6 +- core/memory/memory-tests.factor | 2 +- core/parser/parser-tests.factor | 78 ++++++++----------- core/quotations/quotations-tests.factor | 2 +- core/sequences/sequences-tests.factor | 20 ++--- core/splitting/splitting-tests.factor | 2 +- core/strings/strings-tests.factor | 11 ++- core/threads/threads-tests.factor | 2 +- core/tuples/tuples-tests.factor | 18 ++--- core/vectors/vectors-tests.factor | 20 ++--- core/vocabs/loader/loader-tests.factor | 14 +--- core/words/words-tests.factor | 8 +- extra/bitfields/bitfields-tests.factor | 12 +-- extra/bootstrap/io/io.factor | 2 - extra/calendar/calendar-tests.factor | 16 ++-- extra/circular/circular-tests.factor | 4 +- extra/combinators/lib/lib-tests.factor | 15 ++-- extra/concurrency/concurrency-docs.factor | 2 +- extra/concurrency/concurrency-tests.factor | 15 ++-- extra/concurrency/concurrency.factor | 2 +- extra/coroutines/coroutines-tests.factor | 2 +- extra/crypto/xor/xor-tests.factor | 8 +- extra/db/postgresql/postgresql-tests.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 4 +- extra/destructors/destructors-tests.factor | 4 +- extra/help/crossref/crossref-tests.factor | 2 +- extra/inverse/inverse-tests.factor | 8 +- extra/io/buffers/buffers-tests.factor | 2 +- extra/io/mmap/mmap-tests.factor | 4 +- extra/io/unix/launcher/launcher-tests.factor | 8 +- extra/io/unix/linux/linux.factor | 6 +- extra/io/unix/unix-tests.factor | 20 ++--- extra/io/windows/nt/nt.factor | 3 + extra/irc/irc.factor | 2 +- extra/math/complex/complex-tests.factor | 4 +- extra/math/functions/functions-tests.factor | 2 +- extra/memoize/memoize-tests.factor | 2 +- .../multi-methods/multi-methods-tests.factor | 2 +- .../parser-combinators-tests.factor | 2 +- extra/regexp/regexp-tests.factor | 2 +- extra/roman/roman-tests.factor | 6 +- extra/sequences/lib/lib-tests.factor | 2 +- extra/tetris/board/board-tests.factor | 2 +- .../interpreter/interpreter-tests.factor | 2 +- extra/tools/test/inference/inference.factor | 7 +- extra/tools/test/test.factor | 3 + extra/ui/tools/listener/listener-tests.factor | 2 +- extra/xml/test/errors.factor | 2 +- extra/xml/test/test.factor | 2 +- 76 files changed, 299 insertions(+), 369 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index d5133753c1..74c94c8edf 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -14,7 +14,7 @@ prettyprint ; ! Testing the various bignum accessor 10 "dump" set -[ "dump" get alien-address ] unit-test-fails +[ "dump" get alien-address ] must-fail [ 123 ] [ 123 "dump" get 0 set-alien-signed-1 @@ -61,9 +61,9 @@ cell 8 = [ [ ] [ 0 F{ 1 2 3 } drop ] unit-test [ ] [ 0 ?{ t f t } drop ] unit-test -[ 0 B{ 1 2 3 } alien-address ] unit-test-fails +[ 0 B{ 1 2 3 } alien-address ] must-fail -[ 1 1 ] unit-test-fails +[ 1 1 ] must-fail [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 3148b85782..719068e031 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } -] unit-test-fails +] must-fail diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index 3ff81fda72..e07f192197 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; IN: temporary -[ -2 { "a" "b" "c" } nth ] unit-test-fails -[ 10 { "a" "b" "c" } nth ] unit-test-fails -[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails -[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails +[ -2 { "a" "b" "c" } nth ] must-fail +[ 10 { "a" "b" "c" } nth ] must-fail +[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail +[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail [ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test [ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test @@ -17,5 +17,5 @@ IN: temporary [ { "a" "b" "c" "d" "e" } ] [ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test -[ -1 f ] unit-test-fails -[ cell-bits cell log2 - 2^ f ] unit-test-fails +[ -1 f ] must-fail +[ cell-bits cell log2 - 2^ f ] must-fail diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index f605eba24c..5f89b90608 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -51,4 +51,4 @@ IN: temporary [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test -[ -10 ?{ } resize-bit-array ] unit-test-fails +[ -10 ?{ } resize-bit-array ] must-fail diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b39551eb86..b5b01c201b 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -5,4 +5,4 @@ USING: tools.test byte-arrays ; [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test -[ -10 B{ } resize-byte-array ] unit-test-fails +[ -10 B{ } resize-byte-array ] must-fail diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index efff0db5d1..d78436bd5f 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test [ "union-1" ] [ 8 generic-update-test ] unit-test -[ -7 generic-update-test ] unit-test-fails +[ -7 generic-update-test ] must-fail ! Test mixins MIXIN: sequence-mixin @@ -193,7 +193,7 @@ DEFER: mixin-forget-test-g ] unit-test [ { } ] [ { } mixin-forget-test-g ] unit-test -[ H{ } mixin-forget-test-g ] unit-test-fails +[ H{ } mixin-forget-test-g ] must-fail [ ] [ { @@ -207,7 +207,7 @@ DEFER: mixin-forget-test-g parse-stream drop ] unit-test -[ { } mixin-forget-test-g ] unit-test-fails +[ { } mixin-forget-test-g ] must-fail [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test ! Method flattening interfered with mixin update diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 208f8c0c84..3cefda7f71 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -38,7 +38,7 @@ namespaces combinators words ; ! Interpreted [ "two" ] [ 2 \ case-test-1 word-def call ] unit-test -[ "x" case-test-1 ] unit-test-fails +[ "x" case-test-1 ] must-fail : case-test-2 { diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 9416fd1415..dbdbbfc9fa 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ; FUNCTION: int ffi_test_2 int x int y ; [ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] unit-test-fails +[ "hi" 3 ffi_test_2 ] must-fail FUNCTION: int ffi_test_3 int x int y int z int t ; [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test @@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ; FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails -[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail C-STRUCT: foo { "int" "x" } @@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ; [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] unit-test-fails +[ 1 2 ffi_test_15 ] must-fail C-STRUCT: bar { "long" "x" } @@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test -[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with : indirect-test-1 "int" { } "cdecl" alien-indirect ; @@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test -[ -1 indirect-test-1 ] unit-test-fails +[ -1 indirect-test-1 ] must-fail : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; @@ -120,7 +120,7 @@ unit-test FUNCTION: double ffi_test_6 float x float y ; [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] unit-test-fails +[ "a" "b" ffi_test_6 ] must-fail FUNCTION: double ffi_test_7 double x double y ; [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test @@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ; [ 987655432 ] [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test -[ 1111 f 123456789 ffi_test_22 ] unit-test-fails +[ 1111 f 123456789 ffi_test_22 ] must-fail C-STRUCT: rect { "float" "x" } @@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; @@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 1d0ad141c2..679938b7f3 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -422,11 +422,11 @@ cell 8 = [ [ B{ 0 0 0 0 } [ { byte-array } declare ] compile-call -] unit-test-fails +] must-fail [ B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call -] unit-test-fails +] must-fail [ 4 5 diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index b59c0d5f33..091648cbbc 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -136,7 +136,7 @@ TUPLE: pred-test ; GENERIC: void-generic ( obj -- * ) : breakage "hi" void-generic ; [ t ] [ \ breakage compiled? ] unit-test -[ breakage ] unit-test-fails +[ breakage ] must-fail ! regression : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline @@ -247,7 +247,7 @@ M: slice foozul ; GENERIC: detect-number ( obj -- obj ) M: number detect-number ; -[ 10 f [ 0 + detect-number ] compile-call ] unit-test-fails +[ 10 f [ 0 + detect-number ] compile-call ] must-fail ! Regression [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 5d07e764d6..e9927f4964 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -243,7 +243,7 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test -[ defer-redefine-test-2 ] unit-test-fails +[ defer-redefine-test-2 ] must-fail [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 9f831bb1f8..6f5cb33c1a 100755 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -57,8 +57,8 @@ IN: temporary ! Make sure error reporting works -[ [ dup ] compile-call ] unit-test-fails -[ [ drop ] compile-call ] unit-test-fails +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail ! Regression diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index 59ee3c3d88..71c95b1b61 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -10,7 +10,7 @@ words splitting ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; -[ 3 ] [ [ baz ] catch ] unit-test +[ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace [ word? ] subset @@ -22,11 +22,11 @@ words splitting ; : stack-trace-contains? symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? ] unit-test [ t f ] [ - [ { "hi" } bleh ] catch drop + [ { "hi" } bleh ] ignore-errors \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test @@ -34,6 +34,6 @@ words splitting ; : quux [ t [ "hi" throw ] when ] times ; [ t ] [ - [ 10 quux ] catch drop + [ 10 quux ] ignore-errors \ (each-integer) stack-trace-contains? ] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 51e461c715..2977d02c6f 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,10 +23,9 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"A set of words establish an error handler:" +"Two words for establishing an error handler:" { $subsection cleanup } { $subsection recover } -{ $subsection catch } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -147,12 +146,7 @@ HELP: throw { $values { "error" object } } { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; -HELP: catch -{ $values { "try" quotation } { "error/f" object } } -{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." } -{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ; - -{ catch cleanup recover } related-words +{ cleanup recover } related-words HELP: cleanup { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } @@ -166,7 +160,7 @@ HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } { $notes - "This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler." + "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 360f4750c9..b7d580afe5 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -25,13 +25,11 @@ IN: temporary [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test [ t ] [ callcc-namespace-test ] unit-test -[ f ] [ [ ] catch ] unit-test - -[ 5 ] [ [ 5 throw ] catch ] unit-test +[ 5 throw ] [ 5 = ] must-fail-with [ t ] [ - [ "Hello" throw ] catch drop - global [ error get ] bind + [ "Hello" throw ] ignore-errors + error get-global "Hello" = ] unit-test @@ -41,13 +39,13 @@ IN: temporary "!!! The following error is part of the test" print -[ [ "2 car" ] eval ] catch print-error +[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test -[ f throw ] unit-test-fails +[ f throw ] must-fail ! Weird PowerPC bug. [ ] [ - [ "4" throw ] catch drop + [ "4" throw ] ignore-errors data-gc data-gc ] unit-test @@ -56,10 +54,10 @@ IN: temporary [ f ] [ { "A" "B" } kernel-error? ] unit-test ! ! See how well callstack overflow is handled -! [ clear drop ] unit-test-fails +! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; -! [ callstack-overflow ] unit-test-fails +! [ callstack-overflow ] must-fail : don't-compile-me { } [ ] each ; @@ -84,24 +82,20 @@ SYMBOL: error-counter [ 1 ] [ always-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ "a" throw ] - [ always-counter inc ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 2 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ ] - [ always-counter inc "a" throw ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 3 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6e4ce16bea..b6ca056691 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces math splitting sorting quotations assocs ; @@ -17,9 +17,6 @@ SYMBOL: restarts : c> ( -- continuation ) catchstack* pop ; -: (catch) ( quot -- newquot ) - [ swap >c call c> drop ] curry ; inline - : dummy ( -- obj ) #! Optimizing compiler assumes stack won't be messed with #! in-transit. To ensure that a value is actually reified @@ -120,11 +117,8 @@ PRIVATE> catchstack* empty? [ die ] when dup save-error c> continue-with ; -: catch ( try -- error/f ) - (catch) [ f ] compose callcc1 ; inline - : recover ( try recovery -- ) - >r (catch) r> ifcc ; inline + >r [ swap >c call c> drop ] curry r> ifcc ; inline : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index afadaac0db..0e0ab3feb6 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -7,4 +7,4 @@ USING: float-arrays tools.test ; [ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test -[ -10 F{ } resize-float-array ] unit-test-fails +[ -10 F{ } resize-float-array ] must-fail diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 4de05aafd0..e4d4160605 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -16,7 +16,7 @@ M: word class-of drop "word" ; [ "fixnum" ] [ 5 class-of ] unit-test [ "word" ] [ \ class-of class-of ] unit-test -[ 3.4 class-of ] unit-test-fails +[ 3.4 class-of ] must-fail [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test @@ -90,7 +90,7 @@ M: number union-containment drop 2 ; "IN: temporary GENERIC: unhappy ( x -- x )" eval [ "IN: temporary M: dictionary unhappy ;" eval -] unit-test-fails +] must-fail [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) @@ -155,9 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ T{ no-method f 1.0 my-hook } ] [ - 1.0 my-var set [ my-hook ] catch -] unit-test +[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index 39d8721726..a220ccc45e 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -9,16 +9,16 @@ IN: temporary ! overflow bugs [ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + { 1 } clone nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone lengthen ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone set-length ] -unit-test-fails +must-fail [ ] [ 10 V{ } [ set-length ] keep diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 40d079402c..acb05be720 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -127,9 +127,9 @@ H{ } "x" set ! Another crash discovered by erg [ ] [ H{ } clone - [ 1 swap set-at ] catch drop - [ 2 swap set-at ] catch drop - [ 3 swap set-at ] catch drop + [ 1 swap set-at ] ignore-errors + [ 2 swap set-at ] ignore-errors + [ 3 swap set-at ] ignore-errors drop ] unit-test diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index de661fad92..92b06b866c 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private ; IN: temporary -[ heap-pop ] unit-test-fails -[ heap-pop ] unit-test-fails +[ heap-pop ] must-fail +[ heap-pop ] must-fail [ t ] [ heap-empty? ] unit-test [ f ] [ 1 t pick heap-push heap-empty? ] unit-test diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3e3858d45d..1738a71b7e 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -12,14 +12,14 @@ IN: temporary { 1 2 } [ dup ] unit-test-effect { 1 2 } [ [ dup ] call ] unit-test-effect -[ [ call ] infer ] unit-test-fails +[ [ call ] infer ] must-fail { 2 4 } [ 2dup ] unit-test-effect { 1 0 } [ [ ] [ ] if ] unit-test-effect -[ [ if ] infer ] unit-test-fails -[ [ [ ] if ] infer ] unit-test-fails -[ [ [ 2 ] [ ] if ] infer ] unit-test-fails +[ [ if ] infer ] must-fail +[ [ [ ] if ] infer ] must-fail +[ [ [ 2 ] [ ] if ] infer ] must-fail { 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect { 4 3 } [ @@ -42,7 +42,7 @@ IN: temporary [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] unit-test-fails +] must-fail ! Test inference of termination of control flow : termination-test-1 @@ -54,10 +54,10 @@ IN: temporary : infinite-loop infinite-loop ; -[ [ infinite-loop ] infer ] unit-test-fails +[ [ infinite-loop ] infer ] must-fail : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ; -[ [ no-base-case-1 ] infer ] unit-test-fails +[ [ no-base-case-1 ] infer ] must-fail : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; @@ -72,7 +72,7 @@ IN: temporary : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer ] must-fail : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -192,7 +192,7 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail ! Regression : bad-input# @@ -207,13 +207,13 @@ DEFER: blah4 DEFER: do-crap : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] unit-test-fails +[ [ do-crap ] infer ] must-fail ! This one does not DEFER: do-crap* : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] unit-test-fails +[ [ do-crap* ] infer ] must-fail ! Regression : too-deep ( a b -- c ) @@ -226,7 +226,7 @@ M: fixnum xyz 2array ; M: float xyz [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; -[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test +[ [ xyz ] infer ] [ inference-error? ] must-fail-with ! Doug Coleman discovered this one while working on the ! calendar library @@ -277,78 +277,66 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] unit-test-fails -[ [ #1 ] infer ] unit-test-fails +[ \ #4 word-def infer ] must-fail +[ [ #1 ] infer ] must-fail ! Similar DEFER: bar : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; -[ [ foo ] infer ] unit-test-fails +[ [ foo ] infer ] must-fail -[ 1234 infer ] unit-test-fails +[ 1234 infer ] must-fail ! This used to hang -[ t ] [ - [ [ [ dup call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ dup call ] dup call ] infer ] +[ inference-error? ] must-fail-with : m dup call ; inline -[ t ] [ - [ [ [ m ] m ] infer ] catch inference-error? -] unit-test +[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with : m' dup curry call ; inline -[ t ] [ - [ [ [ m' ] m' ] infer ] catch inference-error? -] unit-test +[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with : m'' [ dup curry ] ; inline : m''' m'' call call ; inline -[ t ] [ - [ [ [ m''' ] m''' ] infer ] catch inference-error? -] unit-test +[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with : m-if t over if ; inline -[ t ] [ - [ [ [ m-if ] m-if ] infer ] catch inference-error? -] unit-test +[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case -[ t ] [ - [ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ [ drop 3 ] swap call ] dup call ] infer ] +[ inference-error? ] must-fail-with ! This form should not have a stack effect : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ [ bad-recursion-1 ] infer ] unit-test-fails +[ [ bad-recursion-1 ] infer ] must-fail : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] unit-test-fails +[ [ bad-bin ] infer ] must-fail -[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test +[ [ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test +[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect { 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail ! Test number protocol \ bitor must-infer @@ -459,7 +447,7 @@ DEFER: bar : fooxxx ( a b -- c ) over [ foo ] when ; inline : barxxx fooxxx ; -[ [ barxxx ] infer ] unit-test-fails +[ [ barxxx ] infer ] must-fail ! A typo { 1 0 } [ { [ ] } dispatch ] unit-test-effect diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 152da8c757..f58e557b10 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ; : set-slots-test-2 { set-a-tuple-x set-a-tuple-x } set-slots ; -[ [ set-slots-test-2 ] infer ] unit-test-fails +[ [ set-slots-test-2 ] infer ] must-fail diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 962a46413f..44542e05ce 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -28,13 +28,13 @@ M: unclosable-stream dispose [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c294c23738..e37b208ef0 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -7,25 +7,22 @@ IN: temporary [ t ] [ [ \ = \ = ] all-equal? ] unit-test ! Don't leak extra roots if error is thrown -[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test -[ ] [ 10000 [ [ -1 f ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ { "kernel-error" 11 f f } ] -[ [ clear drop ] catch ] unit-test +[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ { "kernel-error" 13 f f } ] -[ [ { } set-retainstack r> ] catch ] unit-test +[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test : overflow-d 3 overflow-d ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d ] catch ] unit-test +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -33,24 +30,17 @@ IN: temporary : overflow-d-alt (overflow-d-alt) overflow-d-alt ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d-alt ] catch ] unit-test +[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] string-out drop ] unit-test : overflow-r 3 >r overflow-r ; -[ { "kernel-error" 14 f f } ] -[ [ overflow-r ] catch ] unit-test +[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test -! : overflow-c overflow-c 3 ; -! -! [ { "kernel-error" 16 f f } ] -! [ [ overflow-c ] catch ] unit-test - -[ -7 ] unit-test-fails +[ -7 ] must-fail [ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test [ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test @@ -61,27 +51,27 @@ IN: temporary [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test -[ slip ] unit-test-fails +[ slip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] unit-test-fails +[ 1 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] unit-test-fails +[ 1 2 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] unit-test-fails +[ 1 2 3 slip ] must-fail [ ] [ :c ] unit-test [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test -[ [ ] keep ] unit-test-fails +[ [ ] keep ] must-fail [ 6 ] [ 2 [ sq ] keep + ] unit-test -[ [ ] 2keep ] unit-test-fails -[ 1 [ ] 2keep ] unit-test-fails +[ [ ] 2keep ] must-fail +[ 1 [ ] 2keep ] must-fail [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test @@ -100,13 +90,13 @@ IN: temporary [ ] [ callstack set-callstack ] unit-test -[ 3drop datastack ] unit-test-fails +[ 3drop datastack ] must-fail [ ] [ :c ] unit-test ! Doesn't compile; important : foo 5 + 0 [ ] each ; -[ drop foo ] unit-test-fails +[ drop foo ] must-fail [ ] [ :c ] unit-test ! Regression @@ -117,4 +107,4 @@ IN: temporary : loop ( obj obj -- ) H{ } values swap >r dup length swap r> 0 -roll (loop) ; -[ loop ] unit-test-fails +[ loop ] must-fail diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 626c2b3e06..4570b1162a 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -22,7 +22,7 @@ IN: temporary [ "\\ + 1 2 3 4" parse-interactive "cont" get continue-with - ] catch + ] ignore-errors "USE: debugger :1" eval ] callcc1 ] unit-test @@ -36,7 +36,7 @@ IN: temporary [ "USE: vocabs.loader.test.c" parse-interactive -] unit-test-fails +] must-fail [ ] [ [ diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 680119a56e..194edb8f7e 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -121,8 +121,8 @@ unit-test ! We don't care if this fails or returns 0 (its CPU-specific) ! as long as it doesn't crash -[ ] [ [ 0 0 /i ] catch clear ] unit-test -[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test +[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test +[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test [ -2 ] [ 1 bitnot ] unit-test [ -2 ] [ 1 >bignum bitnot ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 62893e2618..7c30012a19 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -105,6 +105,6 @@ unit-test ! [ dup number>string string>number = ] all? ! ] unit-test -[ 1 1 >base ] unit-test-fails -[ 1 0 >base ] unit-test-fails -[ 1 -1 >base ] unit-test-fails +[ 1 1 >base ] must-fail +[ 1 0 >base ] must-fail +[ 1 -1 >base ] must-fail diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index f543c08744..d0dfd2c0be 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,7 +4,7 @@ IN: temporary TUPLE: testing x y z ; -[ save-image-and-exit ] unit-test-fails +[ save-image-and-exit ] must-fail [ ] [ num-types get [ diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f503528a24..eb04e329d9 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -93,12 +93,12 @@ IN: temporary ! Funny bug [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails + [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] unit-test-fails - [ "OCT: 999" eval ] unit-test-fails - [ "BIN: --0" eval ] unit-test-fails + [ "HEX: zzz" eval ] must-fail + [ "OCT: 999" eval ] must-fail + [ "BIN: --0" eval ] must-fail ! Another funny bug [ t ] [ @@ -205,12 +205,10 @@ IN: temporary "a" source-files get delete-at - [ t ] [ - [ - "IN: temporary : x ; : y 3 throw ; this is an error" - "a" parse-stream - ] catch parse-error? - ] unit-test + [ + "IN: temporary : x ; : y 3 throw ; this is an error" + "a" parse-stream + ] [ parse-error? ] must-fail-with [ t ] [ "y" "temporary" lookup >boolean @@ -307,62 +305,50 @@ IN: temporary "killer?" "temporary" lookup >boolean ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" - "removing-the-predicate" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "removing-the-predicate" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" - "redefining-a-class-1" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" - "redefining-a-class-3" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "redefining-a-class-3" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary : foo ; TUPLE: foo ;" - "redefining-a-class-4" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary : foo ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with ] with-file-vocabs [ diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index f1cc6cd828..d357fb70ff 100644 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] unit-test-fails +[ 1 \ + curry ] must-fail diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 73ae4737ba..40b2fef85e 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -83,8 +83,8 @@ unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test -[ "a" -1 append ] unit-test-fails -[ -1 "a" append ] unit-test-fails +[ "a" -1 append ] must-fail +[ -1 "a" append ] must-fail [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -119,7 +119,7 @@ unit-test [ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test -[ 6 >vector 2 8 pick delete-slice ] unit-test-fails +[ 6 >vector 2 8 pick delete-slice ] must-fail [ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test @@ -173,7 +173,7 @@ unit-test [ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test -[ -1 1 "abc" ] unit-test-fails +[ -1 1 "abc" ] must-fail [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test @@ -195,8 +195,8 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test -[ -10 "hi" "bye" copy ] unit-test-fails -[ 10 "hi" "bye" copy ] unit-test-fails +[ -10 "hi" "bye" copy ] must-fail +[ 10 "hi" "bye" copy ] must-fail [ V{ 1 2 3 5 6 } ] [ 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep @@ -228,13 +228,13 @@ unit-test [ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test [ 0 ] [ f length ] unit-test -[ f first ] unit-test-fails +[ f first ] must-fail [ 3 ] [ 3 10 nth ] unit-test [ 3 ] [ 3 10 nth-unsafe ] unit-test -[ -3 10 nth ] unit-test-fails -[ 11 10 nth ] unit-test-fails +[ -3 10 nth ] must-fail +[ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] unit-test-fails +[ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 3ca78248ab..2b6107e08b 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,7 +1,7 @@ USING: splitting tools.test ; IN: temporary -[ { 1 2 3 } 0 group ] unit-test-fails +[ { 1 2 3 } 0 group ] must-fail [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 985c025827..90e74275ff 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -4,7 +4,7 @@ IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test @@ -31,7 +31,7 @@ IN: temporary [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test -[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test +[ 0 10 "hello" subseq ] must-fail [ "Replacing+spaces+with+plus" ] [ @@ -43,8 +43,8 @@ unit-test [ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test [ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test -[ 1 "" nth ] unit-test-fails -[ -6 "hello" nth ] unit-test-fails +[ 1 "" nth ] must-fail +[ -6 "hello" nth ] must-fail [ t ] [ "hello world" dup >vector >string = ] unit-test @@ -55,8 +55,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ { "kernel-error" 3 12 -7 } ] -[ [ 2 -7 resize-string ] catch ] unit-test +[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index b1b2f86a47..379b10ce88 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -9,4 +9,4 @@ IN: temporary yield [ ] [ 0.3 sleep ] unit-test -[ "hey" sleep ] unit-test-fails +[ "hey" sleep ] must-fail diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 627ee5562f..dede1a2136 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -55,7 +55,7 @@ C: point "IN: temporary TUPLE: point z y ;" eval -[ "p" get point-x ] unit-test-fails +[ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test [ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test @@ -97,7 +97,7 @@ TUPLE: delegate-clone ; [ f ] [ \ tuple \ delegate-clone class< ] unit-test ! Compiler regression -[ t ] [ [ t length ] catch no-method-object ] unit-test +[ t length ] [ no-method-object t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class [ "IN: temporary C: not-a-tuple-class" eval -] unit-test-fails +] must-fail [ t ] [ "not-a-tuple-class" "temporary" lookup symbol? ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] unit-test-fails -[ not-a-tuple-class construct-empty ] unit-test-fails +[ not-a-tuple-class construct-boa ] must-fail +[ not-a-tuple-class construct-empty ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -234,8 +234,6 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test -[ t ] [ - [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval - ] catch [ check-tuple? ] is? -] unit-test +[ + "IN: temporary SYMBOL: not-a-class C: not-a-class" eval +] [ [ check-tuple? ] is? ] must-fail-with diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 4c57c238b4..b56cee1b34 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors continuations random growable classes ; IN: temporary -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ 3 ] [ [ t f t ] length ] unit-test [ 3 ] [ V{ t f t } length ] unit-test -[ -3 V{ } nth ] unit-test-fails -[ 3 V{ } nth ] unit-test-fails -[ 3 54.3 nth ] unit-test-fails +[ -3 V{ } nth ] must-fail +[ 3 V{ } nth ] must-fail +[ 3 54.3 nth ] must-fail -[ "hey" [ 1 2 ] set-length ] unit-test-fails -[ "hey" V{ 1 2 } set-length ] unit-test-fails +[ "hey" [ 1 2 ] set-length ] must-fail +[ "hey" V{ 1 2 } set-length ] must-fail [ 3 ] [ 3 0 [ set-length ] keep length ] unit-test [ "yo" ] [ "yo" 4 1 [ set-nth ] keep 4 swap nth ] unit-test -[ 1 V{ } nth ] unit-test-fails -[ -1 V{ } set-length ] unit-test-fails +[ 1 V{ } nth ] must-fail +[ -1 V{ } set-length ] must-fail [ V{ } ] [ [ ] >vector ] unit-test [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test @@ -64,8 +64,8 @@ IN: temporary [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test [ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test -[ "funny-stack" get pop ] unit-test-fails -[ "funny-stack" get pop ] unit-test-fails +[ "funny-stack" get pop ] must-fail +[ "funny-stack" get pop ] must-fail [ ] [ "funky" "funny-stack" get push ] unit-test [ "funky" ] [ "funny-stack" get pop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 560affa566..764f14e45f 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -18,16 +18,6 @@ debugger compiler.units ; [ t ] [ "kernel" f >vocab-link "kernel" vocab = ] unit-test -! This vocab should not exist, but just in case... -[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test - -2 [ - [ T{ no-vocab f "core" } ] - [ [ "core" require ] catch ] unit-test -] times - -[ f ] [ "core" vocab ] unit-test - [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files @@ -59,7 +49,7 @@ IN: temporary 0 "count-me" set-global 2 [ - [ "vocabs.loader.test.a" require ] unit-test-fails + [ "vocabs.loader.test.a" require ] must-fail [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test @@ -97,7 +87,7 @@ IN: temporary ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.b" require ] unit-test-fails +[ "vocabs.loader.test.b" require ] must-fail [ 1 ] [ "count-me" get-global ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 92f5284c49..f29d21cd9f 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -110,7 +110,7 @@ M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x -[ t ] [ [ x ] catch undefined? ] unit-test +[ x ] [ undefined? ] must-fail-with [ ] [ "no-loc" "temporary" create drop ] unit-test [ f ] [ "no-loc" "temporary" lookup where ] unit-test @@ -141,10 +141,8 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ t ] [ - [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch - [ undefined? ] is? -] unit-test +[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ [ undefined? ] is? ] must-fail-with [ ] [ "IN: temporary GENERIC: symbol-generic" eval diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor index 6c82ec0323..8a3bb1f043 100644 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; [ 855 ] [ 21 852 3 855 swap with-foo-baz foo-baz ] unit-test [ 1 ] [ 21 852 3 1 swap with-foo-bing foo-bing ] unit-test -[ 100 0 0 ] unit-test-fails -[ 0 5000 0 ] unit-test-fails -[ 0 0 10 ] unit-test-fails +[ 100 0 0 ] must-fail +[ 0 5000 0 ] must-fail +[ 0 0 10 ] must-fail -[ 100 0 with-foo-bar ] unit-test-fails -[ 5000 0 with-foo-baz ] unit-test-fails -[ 10 0 with-foo-bing ] unit-test-fails +[ 100 0 with-foo-bar ] must-fail +[ 5000 0 with-foo-baz ] must-fail +[ 10 0 with-foo-bing ] must-fail [ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 ] unit-test diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 4d5440e546..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,5 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -"vocabs.monitor" require diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index fbb60b2d49..3b0cfc8455 100644 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test +[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor index 01504a0e8a..8ca4574885 100644 --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,7 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] unit-test-fails +[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,7 +18,7 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] unit-test-fails +[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index deeb105758..235f441b8b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -8,26 +8,25 @@ IN: temporary [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test -: infers? [ infer drop ] curry catch not ; - [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test -{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test + +[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test +[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test -[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test +[ [ sq ] 3apply ] must-infer [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test +[ [ dup 2^ 2array ] 5 napply ] must-infer ! && diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index dafbafbc5b..f04811b72a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" } +{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index a9d4b39854..2f9b6605d7 100644 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -67,15 +67,12 @@ IN: temporary ] unit-test -[ "crash" ] [ +[ [ - [ - "crash" throw - ] spawn-link drop - receive - ] - catch -] unit-test + "crash" throw + ] spawn-link drop + receive +] [ "crash" = ] must-fail-with [ 50 ] [ [ 50 ] future ?future @@ -115,7 +112,7 @@ SYMBOL: value ! this is fixed (via a timeout). ! [ ! [ "this should propogate" throw ] future ?future -! ] unit-test-fails +! ] must-fail [ ] [ [ "this should not propogate" throw ] future drop diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index bc0d01956f..8d842f15d0 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -166,7 +166,7 @@ M: process send ( message process -- ) PRIVATE> : spawn-link ( quot -- process ) - [ catch [ rethrow-linked ] when* ] curry + [ [ rethrow-linked ] recover ] curry [ ((spawn)) ] curry (spawn-link) ; inline "parent-test" parse-stream drop - ] catch [ :1 ] when + ] [ :1 ] recover ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index a61be734fc..31e7c5f78a 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -3,7 +3,7 @@ math.functions math.constants ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test -[ { 3 4 } [ dup 2array ] undo ] unit-test-fails +[ { 3 4 } [ dup 2array ] undo ] must-fail TUPLE: foo bar baz ; @@ -15,7 +15,7 @@ C: foo [ t ] [ { 3 3 } [ 2same ] matches? ] unit-test [ f ] [ { 3 4 } [ 2same ] matches? ] unit-test -[ [ 2same ] matches? ] unit-test-fails +[ [ 2same ] matches? ] must-fail : something ( array -- num ) { @@ -25,9 +25,9 @@ C: foo [ 5 ] [ { 1 2 2 } something ] unit-test [ 6 ] [ { 2 3 } something ] unit-test -[ { 1 } something ] unit-test-fails +[ { 1 } something ] must-fail -[ 1 2 [ eq? ] undo ] unit-test-fails +[ 1 2 [ eq? ] undo ] must-fail : f>c ( *fahrenheit -- *celsius ) 32 - 1.8 / ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 6fcdc86423..c9203d9ef8 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -75,5 +75,5 @@ sequences tools.test namespaces ; "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] unit-test-fails +[ 1000 "b" get n>buffer ] must-fail "b" get buffer-free diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index a01481ecdc..f0547961bc 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,9 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; IN: temporary -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-stream ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index fec97baa5a..eb3038e1b5 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,8 +1,8 @@ IN: temporary USING: io.unix.launcher tools.test ; -[ "" tokenize-command ] unit-test-fails -[ " " tokenize-command ] unit-test-fails +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail [ { "a" } ] [ "a" tokenize-command ] unit-test [ { "abc" } ] [ "abc" tokenize-command ] unit-test [ { "abc" } ] [ "abc " tokenize-command ] unit-test @@ -14,8 +14,8 @@ USING: io.unix.launcher tools.test ; [ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] unit-test-fails -[ "'abc def" tokenize-command ] unit-test-fails +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail [ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9c4aced03f..55f5f01abc 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,7 +3,7 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs namespaces threads -continuations init math alien.c-types alien ; +continuations init math alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; @@ -134,4 +134,6 @@ M: linux-io init-io ( -- ) T{ linux-io } set-io-backend -[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file +[ start-wait-thread ] "io.unix.linux" add-init-hook + +"vocabs.monitor" require \ No newline at end of file diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 8a621f8f48..5a93257949 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -7,7 +7,7 @@ IN: temporary [ [ "unix-domain-socket-test" resource-path delete-file - ] catch drop + ] ignore-errors "unix-domain-socket-test" resource-path [ @@ -36,7 +36,7 @@ yield ! Unix domain datagram sockets [ "unix-domain-datagram-test" resource-path delete-file -] catch drop +] ignore-errors : server-addr "unix-domain-datagram-test" resource-path ; : client-addr "unix-domain-datagram-test-2" resource-path ; @@ -75,7 +75,7 @@ yield [ "unix-domain-datagram-test-2" resource-path delete-file -] catch drop +] ignore-errors client-addr "d" set @@ -110,7 +110,7 @@ client-addr [ "unix-domain-datagram-test-3" resource-path delete-file -] catch drop +] ignore-errors "unix-domain-datagram-test-2" resource-path delete-file @@ -118,29 +118,29 @@ client-addr [ B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] unit-test-fails +] must-fail [ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close -[ "d" get receive ] unit-test-fails +[ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] unit-test-fails +[ B{ 1 2 } server-addr "d" get send ] must-fail ! Invalid parameter tests [ image [ stdio get accept ] with-stream -] unit-test-fails +] must-fail [ image [ stdio get receive ] with-stream -] unit-test-fails +] must-fail [ image [ B{ 1 2 } server-addr stdio get send ] with-stream -] unit-test-fails +] must-fail diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index b957aa2fca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: vocabs.loader USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files @@ -11,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 5b4355986f..44c682e671 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -189,7 +189,7 @@ SYMBOL: line : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush - over catch drop dup sleep with-infinite-loop ; + over [ drop ] recover dup sleep with-infinite-loop ; : start-irc ( irc-client -- ) ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index be512e5052..e8535d0637 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -2,8 +2,8 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; IN: temporary -[ 1 C{ 0 1 } rect> ] unit-test-fails -[ C{ 0 1 } 1 rect> ] unit-test-fails +[ 1 C{ 0 1 } rect> ] must-fail +[ C{ 0 1 } 1 rect> ] must-fail [ f ] [ C{ 5 12.5 } 5 = ] unit-test [ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 439eaace6f..6f4dc42593 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -73,7 +73,7 @@ IN: temporary [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test -[ 2 10 mod-inv ] unit-test-fails +[ 2 10 mod-inv ] must-fail [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1 ] [ 10 0 ^ ] unit-test diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index f5a7f85edb..dbd2d3a16a 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -7,4 +7,4 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails +[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index d2af88d02a..a0769dffda 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -52,7 +52,7 @@ METHOD: beats? { thing thing } f ; : play ( obj1 obj2 -- ? ) beats? 2nip ; -[ { } 3 play ] unit-test-fails +[ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test [ t ] [ T{ paper } T{ scissors } play ] unit-test diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index fc8cec770b..a1f82391a0 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -76,7 +76,7 @@ IN: scratchpad [ "begin1" "begin" token some parse -] unit-test-fails +] must-fail { "begin" } [ "begin" "begin" token some parse diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 9c0ed5bd81..f6e7c05910 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -95,7 +95,7 @@ IN: regexp-tests [ t ] [ "]" "[]]" f matches? ] unit-test [ f ] [ "]" "[^]]" f matches? ] unit-test -! [ "^" "[^]" f matches? ] unit-test-fails +! [ "^" "[^]" f matches? ] must-fail [ t ] [ "^" "[]^]" f matches? ] unit-test [ t ] [ "]" "[]^]" f matches? ] unit-test diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index e850411726..a15dcef354 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -28,11 +28,11 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 1666 ] [ 1666 >roman roman> ] unit-test [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test -[ 0 >roman ] unit-test-fails -[ 4000 >roman ] unit-test-fails +[ 0 >roman ] must-fail +[ 4000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test [ "i" ] [ "iii" "ii" roman/i ] unit-test [ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test -[ "iii" "iii" roman- ] unit-test-fails +[ "iii" "iii" roman- ] must-fail diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 717f463c45..d0bc0a9e52 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -38,7 +38,7 @@ math.functions tools.test strings ; [ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] unit-test-fails +[ V{ } [ delete-random drop ] keep length ] must-fail [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 3a870e621e..bd8789c4d6 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -5,7 +5,7 @@ colors ; [ { { f f } { f f } { f f } } ] [ 2 3 board-rows ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] unit-test-fails +[ 2 3 { 2 3 } board-block ] must-fail red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test [ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 3976ada845..e7fe7854fa 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/extra/tools/interpreter/interpreter-tests.factor @@ -99,7 +99,7 @@ IN: temporary [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test [ { 6 } ] -[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test +[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ { "{ 1 2 3 }\n" } ] [ [ [ { 1 2 3 } . ] string-out ] test-interpreter diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor index 17ff7e1acd..cc77f4910d 100755 --- a/extra/tools/test/inference/inference.factor +++ b/extra/tools/test/inference/inference.factor @@ -10,7 +10,6 @@ IN: tools.test.inference : unit-test-effect ( effect quot -- ) >r 1quotation r> [ infer short-effect ] curry unit-test ; -: must-infer ( word -- ) - dup "declared-effect" word-prop - dup effect-in length swap effect-out length 2array - swap 1quotation unit-test-effect ; +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index aa994e91d2..1037323ddb 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -42,6 +42,9 @@ M: expected-error summary : must-fail ( quot -- ) [ drop t ] must-fail-with ; +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit [ diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index eab85209cc..56c90f760f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ timers [ init-timers ] unless [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test [ ] [ - "i" get [ { "SYMBOL:" } parse-lines ] catch go-to-error + "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test [ t ] [ diff --git a/extra/xml/test/errors.factor b/extra/xml/test/errors.factor index 596f1e6c43..c0a60d8a3f 100644 --- a/extra/xml/test/errors.factor +++ b/extra/xml/test/errors.factor @@ -1,7 +1,7 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; : xml-error-test ( expected-error xml-string -- ) - swap 1array >quotation swap [ [ string>xml ] catch nip ] curry unit-test ; + [ string>xml ] curry swap [ = ] curry must-fail-with ; T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" } diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index ec59d3564e..0198ebacb7 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -17,7 +17,7 @@ SYMBOL: xml-file xml-file get T{ name f "" "this" "http://d.de" } swap at ] unit-test [ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ xml-file get xml-before [ comment? ] find nip ] unit-test From f7ca140c230af21ad26a00e0320f056783d56a6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:16 -0600 Subject: [PATCH 207/317] Fix compiled-xref --- core/words/words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words.factor b/core/words/words.factor index f628d68bee..bd49a3d855 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -99,7 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) - [ crossref? ] subset + [ drop crossref? ] assoc-subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; From 31b863f8b20da0a8850b2eabcafa0625ff13d035 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:23 -0600 Subject: [PATCH 208/317] Fix docs load error --- extra/tools/test/test-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/tools/test/test-docs.factor diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor old mode 100644 new mode 100755 index 32825c965d..147e795861 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -10,7 +10,8 @@ $nl $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } -{ $subsection unit-test-fails } +{ $subsection must-fail } +{ $subsection must-fail-with } "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } { $subsection test-all } ; @@ -21,7 +22,7 @@ HELP: unit-test { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; -HELP: unit-test-fails +HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; From b18a4632852bee2b421c2e35df254e84e738d1f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 14:59:53 -0600 Subject: [PATCH 209/317] Better inlining heuristic --- core/compiler/test/optimizer.factor | 11 ++++++++++- core/compiler/test/redefine.factor | 2 +- core/optimizer/backend/backend.factor | 22 ++++++++++++++++++---- 3 files changed, 29 insertions(+), 6 deletions(-) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 091648cbbc..7ee4ebfd1c 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations ; +continuations growable ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ; : construct-empty-bug construct-empty ; [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index e9927f4964..ab472668c3 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -235,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test +[ f ] [ \ bx \ ax compiled-usage key? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index e73200b861..788f862849 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,18 +245,32 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; -: flat-length ( seq -- n ) +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + dup get over inline? not or + [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + +: (flat-length) ( seq -- n ) [ - dup quotation? over array? or - [ flat-length ] [ drop 1 ] if + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond ] map sum ; +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup flat-length 10 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t From 8428f66933f1cfb9c20e818667b8ef36eb93b614 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 15:00:10 -0600 Subject: [PATCH 210/317] Fixing unit tests --- core/classes/classes-tests.factor | 6 ++++-- core/generic/generic-tests.factor | 2 +- core/inference/inference-tests.factor | 4 ++-- core/tuples/tuples-tests.factor | 2 +- core/vocabs/loader/loader-tests.factor | 17 +++++++---------- extra/combinators/lib/lib-tests.factor | 2 +- extra/tools/test/test.factor | 2 +- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d78436bd5f..c7024a7490 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -169,8 +169,10 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; UNION: forget-class-bug-1 integer ; UNION: forget-class-bug-2 forget-class-bug-1 dll ; -FORGET: forget-class-bug-1 -FORGET: forget-class-bug-2 +[ + \ forget-class-bug-1 forget + \ forget-class-bug-2 forget +] with-compilation-unit [ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e4d4160605..e3fdbc7b46 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -155,7 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1738a71b7e..b43226166a 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -326,10 +326,10 @@ DEFER: bar : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; [ [ bad-bin ] infer ] must-fail -[ [ [ r> ] infer ] [ inference-error? ] must-fail-with +[ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with +[ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index dede1a2136..c9656a3b9e 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma crossref ] unit-test + [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 764f14e45f..3a8fc37583 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -63,14 +63,12 @@ IN: temporary [ 2 ] [ "count-me" get-global ] unit-test -[ t ] [ - [ - "IN: vocabs.loader.test.a v-l-t-a-hello" - - "resource:core/vocabs/loader/test/a/a.factor" - parse-stream - ] catch [ no-word? ] is? -] unit-test +[ + "IN: vocabs.loader.test.a v-l-t-a-hello" + + "resource:core/vocabs/loader/test/a/a.factor" + parse-stream +] [ [ no-word? ] is? ] must-fail-with 0 "count-me" set-global @@ -121,8 +119,7 @@ IN: temporary [ "kernel" vocab where ] unit-test [ t ] [ - [ "vocabs.loader.test.d" require ] catch - [ :1 ] when + [ "vocabs.loader.test.d" require ] [ :1 ] recover "vocabs.loader.test.d" vocab-source-loaded? ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 235f441b8b..20f52b2ea3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test inference continuations arrays vectors ; +tools.test tools.test.inference continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 1037323ddb..9590f32539 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -37,7 +37,7 @@ M: expected-error summary : must-fail-with ( quot test -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry - [ ] swap unit-test ; + [ t ] swap unit-test ; : must-fail ( quot -- ) [ drop t ] must-fail-with ; From 90ed177a9c410eacdf6ddad3a09cf025bcae13fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 19:23:39 -0600 Subject: [PATCH 211/317] Fixing load-everything and unit tests --- core/dlists/dlists.factor | 5 +++++ core/io/files/files-tests.factor | 3 ++- core/io/files/files.factor | 8 ++++++-- core/parser/parser-tests.factor | 8 ++++++++ core/parser/parser.factor | 10 +++++++--- core/vocabs/loader/loader.factor | 7 ++++--- extra/asn1/asn1-tests.factor | 4 ++-- extra/concurrency/concurrency-tests.factor | 2 ++ extra/concurrency/concurrency.factor | 2 +- extra/hardware-info/windows/ce/ce.factor | 16 ++++++++-------- extra/http/server/templating/templating.factor | 7 ++++--- extra/ldap/libldap/libldap.factor | 8 ++++---- extra/math/constants/constants-docs.factor | 4 ++-- extra/math/constants/constants.factor | 2 +- .../math/matrices/elimination/elimination.factor | 7 +++++-- extra/nehe/5/5.factor | 4 +++- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/openssl-tests.factor | 2 +- extra/openssl/openssl.factor | 2 +- .../partial-continuations.factor | 4 ++-- extra/random-tester/random-tester.factor | 6 +++--- extra/regexp/regexp.factor | 2 +- extra/serialize/serialize-tests.factor | 4 +--- extra/state-parser/state-parser-tests.factor | 2 +- extra/tuple-syntax/tuple-syntax-tests.factor | 1 + extra/tuple-syntax/tuple-syntax.factor | 9 +++++---- extra/ui/gadgets/editors/editors.factor | 6 +++--- extra/xmode/utilities/utilities-tests.factor | 4 ++-- 28 files changed, 86 insertions(+), 55 deletions(-) mode change 100644 => 100755 extra/concurrency/concurrency-tests.factor mode change 100644 => 100755 extra/concurrency/concurrency.factor mode change 100644 => 100755 extra/ldap/libldap/libldap.factor mode change 100644 => 100755 extra/nehe/5/5.factor mode change 100644 => 100755 extra/openssl/libcrypto/libcrypto.factor mode change 100644 => 100755 extra/openssl/openssl-tests.factor mode change 100644 => 100755 extra/openssl/openssl.factor mode change 100644 => 100755 extra/partial-continuations/partial-continuations.factor mode change 100644 => 100755 extra/random-tester/random-tester.factor mode change 100644 => 100755 extra/serialize/serialize-tests.factor mode change 100644 => 100755 extra/state-parser/state-parser-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax.factor mode change 100644 => 100755 extra/xmode/utilities/utilities-tests.factor diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index ddec312182..12b1cd51ad 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -144,6 +144,11 @@ PRIVATE> : dlist-delete ( obj dlist -- obj/f ) >r [ eq? ] curry r> delete-node-if ; +: dlist-delete-all ( dlist -- ) + f over set-dlist-front + f over set-dlist-back + 0 swap set-dlist-length ; + : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 5d4bb70912..bac9a2e65e 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -2,7 +2,8 @@ IN: temporary USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test -[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ "test-foo.txt" resource-path [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..5d0cf6bf11 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -64,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; normalize-directory dup (directory) fixup-directory ; : last-path-separator ( path -- n ? ) - [ length 2 [-] ] keep [ path-separator? ] find-last* ; + [ length 1- ] keep [ path-separator? ] find-last* ; TUPLE: no-parent-directory path ; @@ -83,7 +83,11 @@ TUPLE: no-parent-directory path ; } cond ; : file-name ( path -- string ) - dup last-path-separator [ 1+ tail ] [ drop ] if ; + right-trim-separators { + { [ dup empty? ] [ drop "/" ] } + { [ dup last-path-separator ] [ 1+ tail ] } + { [ t ] [ drop ] } + } cond ; : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index eb04e329d9..c40bc54335 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -349,6 +349,14 @@ IN: temporary "IN: temporary : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with + + [ ] [ + "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + ] unit-test + + [ + "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + ] must-fail ] with-file-vocabs [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 59d18dc734..d54bf1c1f4 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -307,10 +307,14 @@ SYMBOL: lexer-factory ! Parsing word utilities : parse-effect ( -- effect ) - ")" parse-tokens { "--" } split1 dup [ - + ")" parse-tokens "(" over member? [ + "Stack effect declaration must not contain (" throw ] [ - "Stack effect declaration must contain --" throw + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if ] if ; TUPLE: bad-number ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 64372fe4b7..e42dace945 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,12 +149,14 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " rot dup >vocab-link write-object ":" print - print-error ; + "==== " write >r + dup vocab-name swap f >vocab-link write-object ":" print nl + r> print-error ; TUPLE: require-all-error vocabs ; : require-all-error ( vocabs -- ) + [ vocab-name ] map \ require-all-error construct-boa throw ; M: require-all-error summary @@ -167,7 +169,6 @@ M: require-all-error summary [ [ require ] [ 2array , ] recover ] each ] { } make dup empty? [ drop ] [ - "==== LOAD ERRORS:" print dup [ nl load-error. ] assoc-each keys require-all-error ] if diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor index 1c9bc79d76..329ba8256d 100755 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ; ] unit-test [ "testing" ] [ - "\u0004\u0007testing" [ asn-syntax read-ber ] with-stream + "\u000004\u000007testing" [ asn-syntax read-ber ] with-stream ] unit-test [ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [ - "0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus" + "0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus" [ asn-syntax read-ber ] with-stream ] unit-test diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor old mode 100644 new mode 100755 index 2f9b6605d7..b6f62d1779 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words match quotations concurrency.private ; IN: temporary +[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test + [ V{ 1 2 3 } ] [ 0 make-mailbox diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor old mode 100644 new mode 100755 index 8d842f15d0..cf44ab125c --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -73,7 +73,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data delete-node ; inline + mailbox-data delete-node-if ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 8923d86b03..f671ea9426 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -10,25 +10,25 @@ T{ wince-os } os set-global "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince cpus ( -- n ) 1 ; +M: wince-os cpus ( -- n ) 1 ; -M: wince memory-load ( -- n ) +M: wince-os memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince physical-mem ( -- n ) +M: wince-os physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince available-mem ( -- n ) +M: wince-os available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince total-page-file ( -- n ) +M: wince-os total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince available-page-file ( -- n ) +M: wince-os available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince total-virtual-mem ( -- n ) +M: wince-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince available-virtual-mem ( -- n ) +M: wince-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f5de4664a1..dc83562600 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -32,17 +32,18 @@ M: template-lexer skip-word DEFER: <% delimiter : check-<% ( lexer -- col ) - "<%" over line-text rot lexer-column start* ; + "<%" over lexer-line-text rot lexer-column start* ; : found-<% ( accum lexer col -- accum ) [ - over line-text >r >r lexer-column r> r> subseq parsed + over lexer-line-text + >r >r lexer-column r> r> subseq parsed \ write-html parsed ] 2keep 2 + swap set-lexer-column ; : still-looking ( accum lexer -- accum ) [ - dup line-text swap lexer-column tail + dup lexer-line-text swap lexer-column tail parsed \ print-html parsed ] keep next-line ; diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor old mode 100644 new mode 100755 index 6113fe5b7e..492aed1a54 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -40,9 +40,9 @@ IN: ldap.libldap : LDAP_RES_UNSOLICITED 0 ; inline ! how many messages to retrieve results for -: LDAP_MSG_ONE HEX: 00 ; inline -: LDAP_MSG_ALL HEX: 01 ; inline -: LDAP_MSG_RECEIVED HEX: 02 ; inline +: LDAP_MSG_ONE HEX: 00 ; inline +: LDAP_MSG_ALL HEX: 01 ; inline +: LDAP_MSG_RECEIVED HEX: 02 ; inline ! the possible result types returned : LDAP_RES_BIND HEX: 61 ; inline @@ -71,7 +71,7 @@ IN: ldap.libldap { HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" } } ; -: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline +: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline C-STRUCT: ldap { "char" "ld_lberoptions" } diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 653444376a..42cdf0e8f1 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -4,7 +4,7 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" { $subsection e } -{ $subsection gamma } +{ $subsection euler } { $subsection phi } { $subsection pi } "Various limits:" @@ -17,7 +17,7 @@ ABOUT: "math-constants" HELP: e { $values { "e" "base of natural logarithm" } } ; -HELP: gamma +HELP: euler { $values { "gamma" "Euler-Mascheroni constant" } } { $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ; diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index c4abeca0eb..c207eaa63c 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -3,7 +3,7 @@ IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline -: gamma ( -- gamma ) 0.57721566490153286060 ; inline +: euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 73f6dd7e96..8ac9771767 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.vectors math.matrices namespaces -sequences parser ; +sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -20,6 +20,9 @@ SYMBOL: matrix : cols ( -- n ) 0 nth-row length ; +: skip ( i seq quot -- n ) + over >r find* drop r> length or ; inline + : first-col ( row# -- n ) #! First non-zero column 0 swap nth-row [ zero? not ] skip ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor old mode 100644 new mode 100755 index a792f04479..31a7d059ae --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -108,10 +108,12 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) : nehe5-update-thread ( gadget -- ) dup nehe5-gadget-quit? [ + drop + ] [ redraw-interval sleep dup relayout-1 nehe5-update-thread - ] unless ; + ] if ; M: nehe5-gadget graft* ( gadget -- ) [ f swap set-nehe5-gadget-quit? ] keep diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor old mode 100644 new mode 100755 index 52cb06f62e..8378a11956 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -49,7 +49,7 @@ C-STRUCT: bio : BIO_CLOSE HEX: 01 ; inline : RSA_3 HEX: 3 ; inline -: RSA_F4 HEX: 10001 ; inline +: RSA_F4 HEX: 10001 ; inline : BIO_C_SET_SSL 109 ; inline : BIO_C_GET_SSL 110 ; inline diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor old mode 100644 new mode 100755 index f4576dca19..c40bc5628b --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types assocs bit-arrays hashtables io io.files io.sockets kernel mirrors openssl.libcrypto openssl.libssl -namespaces math math.parser openssl prettyprint sequences tools.test unix ; +namespaces math math.parser openssl prettyprint sequences tools.test ; ! ========================================================= ! Some crypto functions (still to be turned into words) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor old mode 100644 new mode 100755 index 3b5474ea9f..bfa7f32594 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -4,7 +4,7 @@ ! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC USING: alien alien.c-types assocs kernel libc namespaces -openssl.libcrypto openssl.libssl sequences unix ; +openssl.libcrypto openssl.libssl sequences ; IN: openssl diff --git a/extra/partial-continuations/partial-continuations.factor b/extra/partial-continuations/partial-continuations.factor old mode 100644 new mode 100755 index 0dce7c2390..b80e3a9ddb --- a/extra/partial-continuations/partial-continuations.factor +++ b/extra/partial-continuations/partial-continuations.factor @@ -6,7 +6,7 @@ USING: kernel continuations arrays sequences quotations ; : breset ( quot -- ) [ 1array swap keep first continue-with ] callcc1 nip ; -: (bshift) ( v r k -- ) +: (bshift) ( v r k -- obj ) >r dup first -rot r> [ rot set-first @@ -19,4 +19,4 @@ USING: kernel continuations arrays sequences quotations ; over >r [ (bshift) ] 2curry swap call r> first continue-with - ] callcc1 2nip ; + ] callcc1 2nip ; inline diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor old mode 100644 new mode 100755 index c3a1ecbec4..8704687e34 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -17,9 +17,9 @@ TUPLE: random-tester-error ; : test-compiler ! ( data... quot -- ... ) errored off dup quot set - datastack clone >vector dup pop* before set - [ call ] catch drop - datastack clone after set + datastack 1 head* before set + [ call ] [ drop ] recover + datastack after set clear before get [ ] each quot get [ compile-call ] [ errored on ] recover ; diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index ef88e84f05..fe1d87d9e9 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -77,7 +77,7 @@ PRIVATE> : 'hex' ( -- parser ) "x" token 'hex-digit' 2 exactly-n &> - "u" token 'hex-digit' 4 exactly-n &> <|> + "u" token 'hex-digit' 6 exactly-n &> <|> [ hex> ] <@ ; : satisfy-tokens ( assoc -- parser ) diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor old mode 100644 new mode 100755 index a713840a20..e0ecb5393a --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -10,8 +10,6 @@ TUPLE: serialize-test a b ; C: serialize-test -: CURRY< \ > parse-until first2 curry parsed ; parsing - : objects { f @@ -33,7 +31,7 @@ C: serialize-test B{ 50 13 55 64 1 } ?{ t f t f f t f } F{ 1.0 3.0 4.0 1.0 2.35 0.33 } - CURRY< 1 [ 2 ] > + << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } } ; diff --git a/extra/state-parser/state-parser-tests.factor b/extra/state-parser/state-parser-tests.factor old mode 100644 new mode 100755 index ff8ac91513..4e1ecaddfc --- a/extra/state-parser/state-parser-tests.factor +++ b/extra/state-parser/state-parser-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test state-parser kernel io strings ; +USING: tools.test state-parser kernel io strings ascii ; [ "hello" ] [ "hello" [ rest ] string-parse ] unit-test [ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor old mode 100644 new mode 100755 index b16c5b337d..0a9711c446 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,4 +1,5 @@ USING: tools.test tuple-syntax ; +IN: temporary TUPLE: foo bar baz ; diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor old mode 100644 new mode 100755 index 6082f529ac..2f0ba6bde5 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -1,4 +1,5 @@ -USING: kernel sequences slots parser words classes ; +USING: kernel sequences slots parser words classes +slots.private ; IN: tuple-syntax ! TUPLE: foo bar baz ; @@ -7,15 +8,15 @@ IN: tuple-syntax : parse-object ( -- object ) scan-word dup parsing? [ V{ } clone swap execute first ] when ; -: parse-slot-writer ( tuple -- slot-setter ) +: parse-slot-writer ( tuple -- slot# ) scan dup "}" = [ 2drop f ] [ 1 head* swap class "slots" word-prop - [ slot-spec-name = ] with find nip slot-spec-writer + [ slot-spec-name = ] with find nip slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) dup parse-slot-writer - [ parse-object pick rot execute parse-slots ] when* ; + [ parse-object pick rot set-slot parse-slots ] when* ; : TUPLE{ scan-word construct-empty parse-slots parsed ; parsing diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 00b574f853..e2df6a343b 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -249,11 +249,11 @@ M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) dup request-focus dup editor-caret click-loc ; -: mouse-elt ( -- elelement ) +: mouse-elt ( -- element ) hand-click# get { + { 1 T{ one-char-elt } } { 2 T{ one-word-elt } } - { 3 T{ one-line-elt } } - } at T{ one-char-elt } or ; + } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) editor-mark* <=> 0 < ; diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor old mode 100644 new mode 100755 index 89cb588336..713700bf7a --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,6 +1,6 @@ IN: temporary -USING: xmode.utilities tools.test xml xml.data -kernel strings vectors sequences io.files prettyprint assocs ; +USING: xmode.utilities tools.test xml xml.data kernel strings +vectors sequences io.files prettyprint assocs unicode.case ; [ "hi" 3 ] [ { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find From 2a417f4a9c79f02fa1af909337c2e669910cf42b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:36:53 -0600 Subject: [PATCH 212/317] add with-file-in with-file-out with-file-appender --- core/io/files/files.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..8c9bd8f2e9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -169,3 +169,12 @@ PRIVATE> : file-contents ( path -- str ) dup swap file-length [ stream-copy ] keep >string ; + +: with-file-in ( path quot -- ) + >r r> with-stream ; inline + +: with-file-out ( path quot -- ) + >r r> with-stream ; inline + +: with-file-appender ( path quot -- ) + >r r> with-stream ; inline From 99411495c2eaa5e4a6a7501cf8c3dbed2bed80b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:49:07 -0600 Subject: [PATCH 213/317] add http-update to work around firewalls --- misc/factor.sh | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 26ebd04531..f0eb232821 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -200,6 +200,12 @@ git_pull_factorcode() { check_ret git } +http_git_pull_factorcode() { + echo "Updating the git repository from factorcode.org..." + git pull http://factorcode.org/git/factor.git master + check_ret git +} + cd_factor() { cd factor check_ret cd @@ -271,6 +277,7 @@ install() { bootstrap } + update() { get_config_info git_pull_factorcode @@ -278,6 +285,13 @@ update() { make_factor } +http_update() { + get_config_info + http_git_pull_factorcode + make_clean + make_factor +} + update_bootstrap() { delete_boot_images get_boot_image @@ -310,6 +324,7 @@ case "$1" in self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; + http-update) http_update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; From 5f997fe2c7c5c071a0f7975170daa6d9f4256aef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:04:09 -0600 Subject: [PATCH 214/317] Make extra/unix load on Windows --- extra/unix/unix.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index d32fc25eab..59141c1940 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -220,7 +220,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { - { [ linux? ] [ "unix.linux" ] } - { [ bsd? ] [ "unix.bsd" ] } - { [ solaris? ] [ "unix.solaris" ] } -} cond require + { [ linux? ] [ "unix.linux" require ] } + { [ bsd? ] [ "unix.bsd" require ] } + { [ solaris? ] [ "unix.solaris" require ] } + { [ t ] [ ] } +} cond From 93eb74476e776f044283ce61354852037a5c0cb1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 20:04:46 -0600 Subject: [PATCH 215/317] add with-file-in docs, update a couple of usages --- core/io/files/files-docs.factor | 15 +++++++++++++++ extra/tar/tar.factor | 5 ++--- extra/tools/browser/browser.factor | 4 ++-- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0b9a748eb8..99f2d42542 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,6 +52,21 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; +HELP: with-file-in +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file is unreadable." } ; + +HELP: with-file-out +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: with-file-appender +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 20e997185d..e15d9511a3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) - ] with-stream ; - + ] with-file-out ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..167c238069 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -10,7 +10,7 @@ IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ lines ] [ drop f ] if ; + [ file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-stream + [ [ print ] each ] with-file-out ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From f3c8bd266b0300a920fd8896372177504aa6984c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:05:03 -0600 Subject: [PATCH 216/317] Improved syntax for ratios --- core/math/parser/parser-tests.factor | 10 --- core/math/parser/parser.factor | 89 ++++++++++++++++++--------- extra/math/ratios/ratios-tests.factor | 5 ++ extra/math/ratios/ratios.factor | 1 + 4 files changed, 66 insertions(+), 39 deletions(-) diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 7c30012a19..226e47090a 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,16 +95,6 @@ unit-test [ f ] [ "\0." string>number ] unit-test -! [ t ] [ -! { "1.0/0.0" "-1.0/0.0" "0.0/0.0" } -! [ dup string>number number>string = ] all? -! ] unit-test -! -! [ t ] [ -! { 1.0/0.0 -1.0/0.0 0.0/0.0 } -! [ dup number>string string>number = ] all? -! ] unit-test - [ 1 1 >base ] must-fail [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 7f0404812d..73b4a725d2 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays combinators splitting math assocs ; IN: math.parser -DEFER: base> - -: string>ratio ( str radix -- a/b ) - >r "/" split1 r> tuck base> >r base> r> - 2dup and [ / ] [ 2drop f ] if ; - : digit> ( ch -- n ) H{ { CHAR: 0 0 } @@ -36,30 +30,54 @@ DEFER: base> { CHAR: f 15 } } at ; -: digits>integer ( radix seq -- n ) - 0 rot [ swapd * + ] curry reduce ; - -: valid-digits? ( radix seq -- ? ) - { - { [ dup empty? ] [ 2drop f ] } - { [ f over memq? ] [ 2drop f ] } - { [ t ] [ swap [ < ] curry all? ] } - } cond ; - : string>digits ( str -- digits ) [ digit> ] { } map-as ; -: string>integer ( str radix -- n/f ) - swap "-" ?head >r - string>digits 2dup valid-digits? - [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ; +DEFER: base> + +) ( str -- n ) radix get base> ; + +: whole-part ( str -- m n ) + "+" split1 >r (base>) r> + dup [ (base>) ] [ drop 0 swap ] if ; + +: string>ratio ( str -- a/b ) + "/" split1 (base>) >r whole-part r> + 3dup and and [ / + ] [ 3drop f ] if ; + +: digits>integer ( seq -- n ) + 0 radix get [ swapd * + ] curry reduce ; + +: valid-digits? ( seq -- ? ) + { + { [ dup empty? ] [ drop f ] } + { [ f over memq? ] [ drop f ] } + { [ t ] [ radix get [ < ] curry all? ] } + } cond ; + +: string>integer ( str -- n/f ) + string>digits dup valid-digits? + [ digits>integer ] [ drop f ] if ; + +PRIVATE> : base> ( str radix -- n/f ) - { - { [ CHAR: / pick member? ] [ string>ratio ] } - { [ CHAR: . pick member? ] [ drop string>float ] } - { [ t ] [ string>integer ] } - } cond ; + [ + "-" ?head >r + { + { [ CHAR: / over member? ] [ string>ratio ] } + { [ CHAR: . over member? ] [ string>float ] } + { [ t ] [ string>integer ] } + } cond + r> [ dup [ neg ] when ] when + ] with-radix ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -74,8 +92,16 @@ DEFER: base> dup >r /mod >digit , dup 0 > [ r> integer, ] [ r> 2drop ] if ; +PRIVATE> + GENERIC# >base 1 ( n radix -- str ) +base) ( n -- str ) radix get >base ; + +PRIVATE> + M: integer >base [ over 0 < [ @@ -87,10 +113,15 @@ M: integer >base M: ratio >base [ - over numerator over >base % - CHAR: / , - swap denominator swap >base % - ] "" make ; + [ + dup 0 < [ "-" % neg ] when + 1 /mod + >r dup zero? [ drop ] [ (>base) % "+" % ] if r> + dup numerator (>base) % + "/" % + denominator (>base) % + ] "" make + ] with-radix ; : fix-float ( str -- newstr ) { diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 79b0b21d28..858a7b0544 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -105,3 +105,8 @@ unit-test [ "33/100" ] [ "66/200" string>number number>string ] unit-test + +[ 3 ] [ "1+1/2" string>number 2 * ] unit-test +[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test +[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test +[ "1/8" ] [ 1 8 / number>string ] unit-test diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 954fd8dd20..5d07bd046f 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -48,3 +48,4 @@ M: ratio * 2>fraction * >r * r> / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio mod 2dup >r >r /i r> r> rot * - ; +M: ratio /mod [ /i ] 2keep mod ; From 01b1ba0f88836a6543b8b17a8cb83ae0f0cc4c23 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 20:05:52 -0600 Subject: [PATCH 217/317] Temporarily use onigirihouse as the primary --- extra/builder/builder.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2acdbc3294..5bfd5e01cf 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,7 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - "git://factorcode.org/git/factor.git" + ! "git://factorcode.org/git/factor.git" + "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 7534d84d2769fa7d83a78dfa9ec00bca79db38b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:33 -0600 Subject: [PATCH 218/317] Refactor tools.test --- extra/tools/test/test.factor | 41 +++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 9590f32539..d761df35d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,35 +61,42 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( path failures -- ) - "Failing tests in " write swap . - [ nl failure. nl ] each ; - -: run-tests ( seq -- ) - dup empty? [ drop "==== NOTHING TO TEST" print ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] subset +: failures. ( assoc -- ) + dup [ nl dup empty? [ drop "==== ALL TESTS PASSED" print ] [ "==== FAILING TESTS:" print - [ nl failures. ] assoc-each + [ + nl + "Failing tests in " write swap . + [ nl failure. nl ] each + ] assoc-each ] if + ] [ + drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- ) - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-tests ; +: run-vocab-tests ( vocabs -- failures ) + dup empty? [ f ] [ + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + ] if ; -: test ( prefix -- ) +: run-tests ( prefix -- failures ) child-vocabs [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset run-vocab-tests ; -: test-all ( -- ) "" test ; +: test ( prefix -- ) + run-tests failures. ; -: test-changes ( -- ) - "" to-refresh dupd do-refresh run-vocab-tests ; +: run-all-tests ( prefix -- failures ) + "" run-tests ; + +: test-all ( -- ) + run-all-tests failures. ; From 2541c62e291ad04de93fadbac7514820bcae657c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:47 -0600 Subject: [PATCH 219/317] Fix code for math.parser changes --- core/math/parser/parser.factor | 8 ++++---- core/syntax/syntax-docs.factor | 4 +++- extra/json/reader/reader.factor | 2 +- extra/math/ratios/ratios-docs.factor | 1 + extra/math/text/english/english.factor | 2 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/peg/peg.factor | 2 +- extra/project-euler/024/024.factor | 2 +- extra/project-euler/032/032.factor | 10 +++++----- extra/project-euler/035/035.factor | 2 +- extra/project-euler/037/037.factor | 2 +- extra/project-euler/038/038.factor | 2 +- extra/project-euler/040/040.factor | 2 +- extra/random-tester/safe-words/safe-words.factor | 2 +- 14 files changed, 23 insertions(+), 20 deletions(-) mode change 100644 => 100755 extra/json/reader/reader.factor mode change 100644 => 100755 extra/math/text/english/english.factor mode change 100644 => 100755 extra/peg/peg.factor mode change 100644 => 100755 extra/project-euler/024/024.factor mode change 100644 => 100755 extra/project-euler/032/032.factor mode change 100644 => 100755 extra/project-euler/035/035.factor mode change 100644 => 100755 extra/project-euler/037/037.factor mode change 100644 => 100755 extra/project-euler/038/038.factor mode change 100644 => 100755 extra/project-euler/040/040.factor mode change 100644 => 100755 extra/random-tester/safe-words/safe-words.factor diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 73b4a725d2..64ce296a0b 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -33,6 +33,9 @@ IN: math.parser : string>digits ( str -- digits ) [ digit> ] { } map-as ; +: digits>integer ( seq radix -- n ) + 0 swap [ swapd * + ] curry reduce ; + DEFER: base> ) >r whole-part r> 3dup and and [ / + ] [ 3drop f ] if ; -: digits>integer ( seq -- n ) - 0 radix get [ swapd * + ] curry reduce ; - : valid-digits? ( seq -- ? ) { { [ dup empty? ] [ drop f ] } @@ -64,7 +64,7 @@ SYMBOL: radix : string>integer ( str -- n/f ) string>digits dup valid-digits? - [ digits>integer ] [ drop f ] if ; + [ radix get digits>integer ] [ drop f ] if ; PRIVATE> diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 2e5b41cd8d..9ccfd2efcd 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -47,11 +47,13 @@ ARTICLE: "syntax-integers" "Integer syntax" "More information on integers can be found in " { $link "integers" } "." ; ARTICLE: "syntax-ratios" "Ratio syntax" -"The printed representation of a ratio is a pair of integers separated by a slash (/). No intermediate whitespace is permitted. Either integer may be signed, however the ratio will be normalized into a form where the denominator is positive and the greatest common divisor of the two terms is 1." +"The printed representation of a ratio is a pair of integers separated by a slash (/), prefixed by an optional whole number part followed by a plus (+). No intermediate whitespace is permitted. Here are some examples:" { $code "75/33" "1/10" "-5/-6" + "1+1/3" + "-10+1/7" } "More information on ratios can be found in " { $link "rationals" } ; diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor old mode 100644 new mode 100755 index 105989ab93..b136012433 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -104,7 +104,7 @@ LAZY: 'digit1-9' ( -- parser ) LAZY: 'digit0-9' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; -: decimal>integer ( seq -- num ) 10 swap digits>integer ; +: decimal>integer ( seq -- num ) 10 digits>integer ; LAZY: 'int' ( -- parser ) 'zero' diff --git a/extra/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor index d996acaf1f..b780a7c322 100755 --- a/extra/math/ratios/ratios-docs.factor +++ b/extra/math/ratios/ratios-docs.factor @@ -7,6 +7,7 @@ ARTICLE: "rationals" "Rational numbers" "When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:" { $example "1210 11 / ." "110" } { $example "100 330 / ." "10/33" } +{ $example "14 10 / ." "1+2/5" } "Ratios are printed and can be input literally in the form above. Ratios are always reduced to lowest terms by factoring out the greatest common divisor of the numerator and denominator. A ratio with a denominator of 1 becomes an integer. Division with a denominator of 0 throws an error." $nl "Ratios behave just like any other number -- all numerical operations work as you would expect." diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor old mode 100644 new mode 100755 index 645d7e2054..b77ac725ab --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -33,7 +33,7 @@ SYMBOL: and-needed? : 3digit-groups ( n -- seq ) number>string 3 - [ reverse 10 string>integer ] map ; + [ reverse string>number ] map ; : hundreds-place ( n -- str ) 100 /mod swap dup zero? [ diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 763f823348..745442610c 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -8,7 +8,7 @@ IN: parser-combinators.simple [ digit? ] satisfy [ digit> ] <@ ; : 'integer' ( -- parser ) - 'digit' [ 10 swap digits>integer ] <@ ; + 'digit' [ 10 digits>integer ] <@ ; : 'string' ( -- parser ) [ CHAR: " = ] satisfy diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor old mode 100644 new mode 100755 index 41df8735e5..59a8b63c14 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -343,7 +343,7 @@ MEMO: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 swap digits>integer ] action ; + 'digit' repeat1 [ 10 digits>integer ] action ; MEMO: 'string' ( -- parser ) [ diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor old mode 100644 new mode 100755 index c795fc0169..0cc0c39e07 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -23,7 +23,7 @@ IN: project-euler.024 ! -------- : euler024 ( -- answer ) - 999999 10 permutation 10 swap digits>integer ; + 999999 10 permutation 10 digits>integer ; ! [ euler024 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor old mode 100644 new mode 100755 index 2baa6f8714..b8b0758974 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -27,21 +27,21 @@ IN: project-euler.032 integer ] map ; + 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) number>string 1 cut-slice 4 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : 2and3 ( n -- ? ) number>string 2 cut-slice 3 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : valid? ( n -- ? ) dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ number>string 4 tail* string>number ] map ; PRIVATE> @@ -65,7 +65,7 @@ PRIVATE> ! multiplicand/multiplier/product : mmp ( pair -- n ) - first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; + first2 2dup * [ number>string ] 3apply 3append string>number ; PRIVATE> diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor old mode 100644 new mode 100755 index 867bbc44ac..29172111c1 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -38,7 +38,7 @@ IN: project-euler.035 : (circular?) ( seq n -- ? ) dup 0 > [ - 2dup rotate 10 swap digits>integer + 2dup rotate 10 digits>integer prime? [ 1- (circular?) ] [ 2drop f ] if ] [ 2drop t diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor old mode 100644 new mode 100755 index f2d5d17c4d..66b1665037 --- a/extra/project-euler/037/037.factor +++ b/extra/project-euler/037/037.factor @@ -32,7 +32,7 @@ IN: project-euler.037 ] if ; : reverse-digits ( n -- m ) - number>string reverse 10 string>integer ; + number>string reverse string>number ; : l-trunc? ( n -- ? ) reverse-digits 10 /i reverse-digits dup 0 > [ diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor old mode 100644 new mode 100755 index cbe6f2363c..2369db25fb --- a/extra/project-euler/038/038.factor +++ b/extra/project-euler/038/038.factor @@ -36,7 +36,7 @@ IN: project-euler.038 : (concat-product) ( accum n multiplier -- m ) pick length 8 > [ - 2drop 10 swap digits>integer + 2drop 10 digits>integer ] [ [ * number>digits over push-all ] 2keep 1+ (concat-product) ] if ; diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor old mode 100644 new mode 100755 index 8984559265..e2df1df2c9 --- a/extra/project-euler/040/040.factor +++ b/extra/project-euler/040/040.factor @@ -37,7 +37,7 @@ IN: project-euler.040 SBUF" " clone 1 -rot (concat-upto) ; : nth-integer ( n str -- m ) - [ 1- ] dip nth 1string 10 string>integer ; + [ 1- ] dip nth 1string string>number ; PRIVATE> diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor old mode 100644 new mode 100755 index 9bc87a9c5a..ab528786bb --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -16,7 +16,7 @@ IN: random-tester.safe-words array? integer? complex? value-ref? ref? key-ref? interval? number? wrapper? tuple? - [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 + [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 2^ not ! arrays resize-array From c1dd7cf855c2f863c44f4d8cb0877e3f854f525c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:16:52 -0600 Subject: [PATCH 220/317] Fix Doug's bug --- extra/ui/tools/operations/operations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 2375730a81..fbb4338b17 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -188,7 +188,7 @@ source-editor "These commands operate on the Factor word named by the token at the caret position." \ selected-word [ selected-word ] -[ search ] +[ dup search [ ] [ no-word ] ?if ] define-operation-map interactor From 9271da5070370a0ea4e2c2bada37ddf0bc53c408 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:12:44 -0600 Subject: [PATCH 221/317] More cleanups to require-all and unit tests --- core/vocabs/loader/loader.factor | 23 ++++++++++++----- extra/tools/test/test.factor | 44 ++++++++++++++++---------------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index e42dace945..352ef9fe02 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,10 +148,17 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: load-error. ( vocab error -- ) - "==== " write >r - dup vocab-name swap f >vocab-link write-object ":" print nl - r> print-error ; +: vocab-heading. ( vocab -- ) + nl + "==== " write + dup vocab-name swap f >vocab-link write-object ":" print + nl ; + +: load-error. ( triple -- ) + dup first vocab-heading. + dup second print-error + drop ; + ! third "Traceback" swap write-object ; TUPLE: require-all-error vocabs ; @@ -166,10 +173,14 @@ M: require-all-error summary dup length 1 = [ first require ] [ [ [ - [ [ require ] [ 2array , ] recover ] each + [ + [ require ] + [ error-continuation get 3array , ] + recover + ] each ] { } make dup empty? [ drop ] [ - dup [ nl load-error. ] assoc-each + dup [ load-error. nl ] each keys require-all-error ] if ] with-compiler-errors diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index d761df35d2..09d497aac7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -11,7 +11,8 @@ SYMBOL: failures : ( error what -- triple ) error-continuation get 3array ; -: failure ( error what -- ) failures get push ; +: failure ( error what -- ) + failures get push ; SYMBOL: this-test @@ -45,16 +46,23 @@ M: expected-error summary : ignore-errors ( quot -- ) [ drop ] recover ; inline -: run-test ( path -- failures ) - [ "temporary" forget-vocab ] with-compilation-unit - [ - V{ } clone [ - failures [ - [ run-file ] [ swap failure ] recover - ] with-variable - ] keep - ] keep - [ forget-source ] with-compilation-unit ; +: (run-test) ( vocab -- ) + dup vocab-source-loaded? [ + vocab-tests-path dup [ + dup ?resource-path exists? [ + [ "temporary" forget-vocab ] with-compilation-unit + dup run-file + [ dup forget-source ] with-compilation-unit + ] when + ] when + ] when drop ; + +: run-test ( vocab -- failures ) + V{ } clone [ + failures [ + (run-test) + ] with-variable + ] keep ; : failure. ( triple -- ) dup second . @@ -70,8 +78,7 @@ M: expected-error summary ] [ "==== FAILING TESTS:" print [ - nl - "Failing tests in " write swap . + swap vocab-heading. [ nl failure. nl ] each ] assoc-each ] if @@ -79,19 +86,12 @@ M: expected-error summary drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- failures ) - dup empty? [ f ] [ +: run-tests ( prefix -- failures ) + child-vocabs dup empty? [ f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; -: run-tests ( prefix -- failures ) - child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-vocab-tests ; - : test ( prefix -- ) run-tests failures. ; From 5ecf3f722587f95232485c21949b9983bdf549fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:58:41 -0600 Subject: [PATCH 222/317] Improve unit test documentation and update some tests --- core/bootstrap/image/image-tests.factor | 3 +- core/compiler/test/alien.factor | 6 +- core/compiler/test/redefine.factor | 8 +- core/inference/inference-docs.factor | 11 +- core/inference/inference-tests.factor | 115 +++++++++--------- .../transforms/transforms-tests.factor | 2 +- extra/combinators/lib/lib-tests.factor | 2 +- extra/io/launcher/launcher-tests.factor | 2 +- extra/io/server/server-tests.factor | 4 +- extra/tools/test/test-docs.factor | 77 ++++++++++-- extra/tools/test/test.factor | 17 ++- extra/ui/gadgets/books/books-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons-tests.factor | 3 +- extra/ui/gadgets/editors/editors-tests.factor | 5 +- extra/ui/gadgets/gadgets-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/tools/browser/browser-tests.factor | 3 +- .../tools/interactor/interactor-tests.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- .../ui/tools/workspace/workspace-tests.factor | 2 +- 20 files changed, 172 insertions(+), 98 deletions(-) mode change 100644 => 100755 extra/io/server/server-tests.factor diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index ea533f0d6f..8c618a8f30 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: bootstrap.image bootstrap.image.private -tools.test.inference ; +USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer \ write-image must-infer diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index dbdbbfc9fa..4adb1c234b 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects namespaces.private io io.streams.string memory system threads -tools.test.inference ; +tools.test ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -80,7 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-1 "int" { } "cdecl" alien-indirect ; -{ 1 1 } [ indirect-test-1 ] unit-test-effect +{ 1 1 } [ indirect-test-1 ] must-infer-as [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test @@ -89,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; -{ 3 1 } [ indirect-test-2 ] unit-test-effect +{ 3 1 } [ indirect-test-2 ] must-infer-as [ 5 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index ab472668c3..9eaf2d1263 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units inference.state ; +effects tools.test compiler.units inference.state ; IN: temporary DEFER: x-1 @@ -28,13 +28,13 @@ DEFER: c [ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test -{ 0 4 } [ b ] unit-test-effect +{ 0 4 } [ b ] must-infer-as [ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test [ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test -{ 0 6 } [ b ] unit-test-effect +{ 0 6 } [ b ] must-infer-as \ b word-xt "b-xt" set @@ -52,7 +52,7 @@ DEFER: c [ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test -{ 0 4 } [ c ] unit-test-effect +{ 0 4 } [ c ] must-infer-as [ f ] [ "c-xt" get \ c word-xt = ] unit-test diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5f7e926b6a..68e5920a3d 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -73,6 +73,12 @@ $nl { $subsection infer-quot-value } "The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; +ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" +"The dataflow graph used by " { $link "compiler" } " can be obtained:" +{ $subsection dataflow } +"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." +$nl ; + 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 compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." $nl @@ -80,14 +86,15 @@ $nl { $subsection infer. } "Instead of printing the inferred information, it can be returned as objects on the stack:" { $subsection infer } -"The dataflow graph used by " { $link "compiler" } " can be obtained:" -{ $subsection dataflow } +"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +$nl "The following articles describe the implementation of the stack effect inference algorithm:" { $subsection "inference-simple" } { $subsection "inference-combinators" } { $subsection "inference-branches" } { $subsection "inference-recursive" } { $subsection "inference-limitations" } +{ $subsection "dataflow-graphs" } { $subsection "compiler-transforms" } ; ABOUT: "inference" diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index b43226166a..c5bc3b5fda 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -4,23 +4,22 @@ math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate -debugger threads.private io.streams.string combinators.private -tools.test.inference ; +debugger threads.private io.streams.string combinators.private ; IN: temporary -{ 0 2 } [ 2 "Hello" ] unit-test-effect -{ 1 2 } [ dup ] unit-test-effect +{ 0 2 } [ 2 "Hello" ] must-infer-as +{ 1 2 } [ dup ] must-infer-as -{ 1 2 } [ [ dup ] call ] unit-test-effect +{ 1 2 } [ [ dup ] call ] must-infer-as [ [ call ] infer ] must-fail -{ 2 4 } [ 2dup ] unit-test-effect +{ 2 4 } [ 2dup ] must-infer-as -{ 1 0 } [ [ ] [ ] if ] unit-test-effect +{ 1 0 } [ [ ] [ ] if ] must-infer-as [ [ if ] infer ] must-fail [ [ [ ] if ] infer ] must-fail [ [ [ 2 ] [ ] if ] infer ] must-fail -{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect +{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as { 4 3 } [ [ @@ -28,17 +27,17 @@ IN: temporary ] [ -rot ] if -] unit-test-effect +] must-infer-as -{ 1 1 } [ dup [ ] when ] unit-test-effect -{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect -{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect +{ 1 1 } [ dup [ ] when ] must-infer-as +{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as +{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as -{ 1 0 } [ [ drop ] when* ] unit-test-effect -{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect +{ 1 0 } [ [ drop ] when* ] must-infer-as +{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as { 0 1 } -[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect +[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer @@ -50,7 +49,7 @@ IN: temporary : termination-test-2 [ termination-test-1 ] [ 3 ] if ; -{ 1 1 } [ termination-test-2 ] unit-test-effect +{ 1 1 } [ termination-test-2 ] must-infer-as : infinite-loop infinite-loop ; @@ -62,12 +61,12 @@ IN: temporary : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; -{ 1 1 } [ simple-recursion-1 ] unit-test-effect +{ 1 1 } [ simple-recursion-1 ] must-infer-as : simple-recursion-2 ( obj -- obj ) dup [ ] [ simple-recursion-2 ] if ; -{ 1 1 } [ simple-recursion-2 ] unit-test-effect +{ 1 1 } [ simple-recursion-2 ] must-infer-as : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; @@ -77,10 +76,10 @@ IN: temporary : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; -{ 1 1 } [ funny-recursion ] unit-test-effect +{ 1 1 } [ funny-recursion ] must-infer-as ! Simple combinators -{ 1 2 } [ [ first ] keep second ] unit-test-effect +{ 1 2 } [ [ first ] keep second ] must-infer-as ! Mutual recursion DEFER: foe @@ -103,8 +102,8 @@ DEFER: foe 2drop f ] if ; -{ 2 1 } [ fie ] unit-test-effect -{ 2 1 } [ foe ] unit-test-effect +{ 2 1 } [ fie ] must-infer-as +{ 2 1 } [ foe ] must-infer-as : nested-when ( -- ) t [ @@ -113,7 +112,7 @@ DEFER: foe ] when ] when ; -{ 0 0 } [ nested-when ] unit-test-effect +{ 0 0 } [ nested-when ] must-infer-as : nested-when* ( obj -- ) [ @@ -122,11 +121,11 @@ DEFER: foe ] when* ] when* ; -{ 1 0 } [ nested-when* ] unit-test-effect +{ 1 0 } [ nested-when* ] must-infer-as SYMBOL: sym-test -{ 0 1 } [ sym-test ] unit-test-effect +{ 0 1 } [ sym-test ] must-infer-as : terminator-branch dup [ @@ -135,7 +134,7 @@ SYMBOL: sym-test "foo" throw ] if ; -{ 1 1 } [ terminator-branch ] unit-test-effect +{ 1 1 } [ terminator-branch ] must-infer-as : recursive-terminator ( obj -- ) dup [ @@ -144,7 +143,7 @@ SYMBOL: sym-test "Hi" throw ] if ; -{ 1 0 } [ recursive-terminator ] unit-test-effect +{ 1 0 } [ recursive-terminator ] must-infer-as GENERIC: potential-hang ( obj -- obj ) M: fixnum potential-hang dup [ potential-hang ] when ; @@ -157,24 +156,24 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -{ 1 0 } [ iterate ] unit-test-effect +{ 1 0 } [ iterate ] must-infer-as ! Regression : cat ( obj -- * ) dup [ throw ] [ throw ] if ; : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ; -{ 3 0 } [ dog ] unit-test-effect +{ 3 0 } [ dog ] must-infer-as ! Regression DEFER: monkey : friend ( a b c -- ) dup [ friend ] [ monkey ] if ; : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ; -{ 3 0 } [ friend ] unit-test-effect +{ 3 0 } [ friend ] must-infer-as ! Regression -- same as above but we infer the second word first DEFER: blah2 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ; : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ; -{ 3 0 } [ blah2 ] unit-test-effect +{ 3 0 } [ blah2 ] must-infer-as ! Regression DEFER: blah4 @@ -182,7 +181,7 @@ DEFER: blah4 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ; : blah4 ( a b c -- ) dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ; -{ 3 0 } [ blah4 ] unit-test-effect +{ 3 0 } [ blah4 ] must-infer-as ! Regression : bad-combinator ( obj quot -- ) @@ -199,7 +198,7 @@ DEFER: blah4 dup string? [ 2array throw ] unless over string? [ 2array throw ] unless ; -{ 2 2 } [ bad-input# ] unit-test-effect +{ 2 2 } [ bad-input# ] must-infer-as ! Regression @@ -218,7 +217,7 @@ DEFER: do-crap* ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline -{ 2 1 } [ too-deep ] unit-test-effect +{ 2 1 } [ too-deep ] must-infer-as ! Error reporting is wrong MATH: xyz @@ -258,17 +257,17 @@ DEFER: C [ dup B C ] } dispatch ; -{ 1 0 } [ A ] unit-test-effect -{ 1 0 } [ B ] unit-test-effect -{ 1 0 } [ C ] unit-test-effect +{ 1 0 } [ A ] must-infer-as +{ 1 0 } [ B ] must-infer-as +{ 1 0 } [ C ] must-infer-as ! I found this bug by thinking hard about the previous one DEFER: Y : X ( a b -- c d ) dup [ swap Y ] [ ] if ; : Y ( a b -- c d ) X ; -{ 2 2 } [ X ] unit-test-effect -{ 2 2 } [ Y ] unit-test-effect +{ 2 2 } [ X ] must-infer-as +{ 2 2 } [ Y ] must-infer-as ! This one comes from UI code DEFER: #1 @@ -332,9 +331,9 @@ DEFER: bar [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff -{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect +{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as -{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect +{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail @@ -381,7 +380,7 @@ DEFER: bar \ assoc-like must-infer \ assoc-clone-like must-infer \ >alist must-infer -{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect +{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as ! Test some random library words \ 1quotation must-infer @@ -404,10 +403,10 @@ DEFER: bar \ define-predicate-class must-infer ! Test words with continuations -{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect -{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect -{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect -{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +{ 0 0 } [ [ drop ] callcc0 ] must-infer-as +{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as +{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as +{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as \ dispose must-infer @@ -450,13 +449,13 @@ DEFER: bar [ [ barxxx ] infer ] must-fail ! A typo -{ 1 0 } [ { [ ] } dispatch ] unit-test-effect +{ 1 0 } [ { [ ] } dispatch ] must-infer-as DEFER: inline-recursive-2 : inline-recursive-1 ( -- ) inline-recursive-2 ; : inline-recursive-2 ( -- ) inline-recursive-1 ; -{ 0 0 } [ inline-recursive-1 ] unit-test-effect +{ 0 0 } [ inline-recursive-1 ] must-infer-as ! Hooks SYMBOL: my-var @@ -465,22 +464,22 @@ HOOK: my-hook my-var ( -- x ) M: integer my-hook "an integer" ; M: string my-hook "a string" ; -{ 0 1 } [ my-hook ] unit-test-effect +{ 0 1 } [ my-hook ] must-infer-as DEFER: deferred-word : calls-deferred-word [ deferred-word ] [ 3 ] if ; -{ 1 1 } [ calls-deferred-word ] unit-test-effect +{ 1 1 } [ calls-deferred-word ] must-infer-as USE: inference.dataflow -{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect +{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as { 1 0 } [ [ [ iterate-next ] iterate-nodes ] with-node-iterator -] unit-test-effect +] must-infer-as : nilpotent ( quot -- ) t [ [ call ] keep nilpotent ] [ drop ] if ; inline @@ -490,11 +489,11 @@ USE: inference.dataflow { 0 1 } [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ] -unit-test-effect +must-infer-as -{ 0 0 } [ [ ] semisimple ] unit-test-effect +{ 0 0 } [ [ ] semisimple ] must-infer-as -{ 1 0 } [ [ drop ] each-node ] unit-test-effect +{ 1 0 } [ [ drop ] each-node ] must-infer-as DEFER: an-inline-word @@ -510,9 +509,9 @@ DEFER: an-inline-word : an-inline-word ( obj quot -- ) >r normal-word r> call ; inline -{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect +{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as -{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect +{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as TUPLE: custom-error ; @@ -536,4 +535,4 @@ TUPLE: custom-error ; ! This was a false trigger of the undecidable quotation ! recursion bug -{ 2 1 } [ find-last-sep ] unit-test-effect +{ 2 1 } [ find-last-sep ] must-infer-as diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f58e557b10..0e5c3e231e 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: sequences inference.transforms tools.test math kernel -quotations tools.test.inference inference ; +quotations inference ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 20f52b2ea3..24d70a86c6 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test tools.test.inference continuations arrays vectors ; +tools.test continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index b9f8f3e061..6705caa33c 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference io.launcher ; +USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor old mode 100644 new mode 100755 index 5c37a37380..776bc4b429 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference io.server ; +USING: tools.test io.server ; -{ 1 0 } [ [ ] spawn-server ] unit-test-effect +{ 1 0 } [ [ ] spawn-server ] must-infer-as diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 147e795861..c027073398 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -1,6 +1,36 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations io ; IN: tools.test +ARTICLE: "tools.test.write" "Writing unit tests" +"Assert that a quotation outputs a specific set of values:" +{ $subsection unit-test } +"Assert that a quotation throws an error:" +{ $subsection must-fail } +{ $subsection must-fail-with } +"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" +{ $subsection must-infer } +{ $subsection must-infer-as } ; + +ARTICLE: "tools.test.run" "Running unit tests" +"The following words run test harness files; any test failures are collected and printed at the end:" +{ $subsection test } +{ $subsection test-all } ; + +ARTICLE: "tools.test.failure" "Handling test failures" +"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "." +$nl +"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" +{ $list + { { $snippet "error" } " - the error thrown by the unit test" } + { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } + { { $snippet "continuation" } " - the traceback at the point of the error" } +} +"The following words run test harness files and output failures:" +{ $subsection run-tests } +{ $subsection run-all-tests } +"The following word prints failures:" +{ $subsection failures. } ; + ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." $nl @@ -8,13 +38,10 @@ $nl $nl "Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" -{ $subsection unit-test } -{ $subsection must-fail } -{ $subsection must-fail-with } -"The following words run test harness files; any test failures are collected and printed at the end:" -{ $subsection test } -{ $subsection test-all } ; +"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +{ $subsection "tools.test.write" } +{ $subsection "tools.test.run" } +{ $subsection "tools.test.failure" } ; ABOUT: "tools.test" @@ -26,3 +53,37 @@ HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; + +HELP: must-fail-with +{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } } +{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." } +{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; + +HELP: must-infer +{ $values { "word/quot" "a quotation or a word" } } +{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: must-infer-as +{ $values { "effect" "a pair with shape " { $snippet "{ inputs outputs }" } } { "quot" quotation } } +{ $description "Ensures that the quotation has the indicated stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: test +{ $values { "prefix" "a vocabulary name" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; + +HELP: run-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: test-all +{ $description "Runs unit tests for all loaded vocabularies." } ; + +HELP: run-all-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: failure. +{ $values { "failures" "an association list of unit test failures" } } +{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 09d497aac7..0b1a495e90 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,8 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units inspector ; +vocabs.loader source-files compiler.units inspector +inference effects ; IN: tools.test SYMBOL: failures @@ -29,13 +30,23 @@ SYMBOL: this-test { } swap with-datastack swap >array assert= ] 2curry (unit-test) ; +: short-effect ( effect -- pair ) + dup effect-in length swap effect-out length 2array ; + +: must-infer-as ( effect quot -- ) + >r 1quotation r> [ infer short-effect ] curry unit-test ; + +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; + TUPLE: expected-error ; M: expected-error summary drop "The unit test expected the quotation to throw an error" ; -: must-fail-with ( quot test -- ) +: must-fail-with ( quot pred -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry [ t ] swap unit-test ; @@ -60,7 +71,7 @@ M: expected-error summary : run-test ( vocab -- failures ) V{ } clone [ failures [ - (run-test) + [ (run-test) ] [ swap failure ] recover ] with-variable ] keep ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 35016e1669..9e1b0aa985 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference ui.gadgets.books ; +USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 77dfd30d96..224ef9e1ce 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,7 +1,6 @@ IN: temporary USING: ui.commands ui.gadgets.buttons ui.gadgets.labels -ui.gadgets tools.test namespaces sequences kernel models -tools.test.inference ; +ui.gadgets tools.test namespaces sequences kernel models ; TUPLE: foo-gadget ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index bc302c1a09..f3a6b9fd5d 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -1,7 +1,6 @@ USING: ui.gadgets.editors tools.test kernel io io.streams.plain -definitions namespaces ui.gadgets -ui.gadgets.grids prettyprint documents ui.gestures -tools.test.inference tools.test.ui models ; +definitions namespaces ui.gadgets ui.gadgets.grids prettyprint +documents ui.gestures tools.test.ui models ; [ "foo bar" ] [ "editor" set diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 81b30559df..1e27744f33 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test -namespaces models kernel tools.test.inference dlists math +namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays prettyprint io.streams.string ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 30ba4a18f3..dd667fdfec 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -3,7 +3,7 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.inference tools.test.ui ; +tools.test.ui ; [ ] [ "g" set diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 3102ad1bd9..7262c72756 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: tools.test tools.test.ui ui.tools.browser -tools.test.inference ; +USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer [ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index bf9de10a1e..0422c4170a 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: ui.tools.interactor tools.test.inference ; +USING: ui.tools.interactor tools.test ; \ must-infer diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index a23b629d1e..acf0a39bfb 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -2,7 +2,7 @@ USING: arrays continuations ui.tools.listener ui.tools.walker ui.tools.workspace inspector kernel namespaces sequences threads listener tools.test ui ui.gadgets ui.gadgets.worlds ui.gadgets.packs vectors ui.tools tools.interpreter -tools.interpreter.debug tools.test.inference tools.test.ui ; +tools.interpreter.debug tools.test.ui ; IN: temporary \ must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 41f0151746..5e3695fed3 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference ui.tools ; +USING: tools.test ui.tools ; \ must-infer From 78abc143d626838d551592dd61bf1de31e4fe458 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:01:14 -0600 Subject: [PATCH 223/317] Load fix --- core/math/parser/parser-docs.factor | 11 +- .../furnace-pastebin/annotate-paste.furnace | 28 ----- .../furnace-pastebin/annotation.furnace | 11 -- unmaintained/furnace-pastebin/load.factor | 4 - .../furnace-pastebin/new-paste.furnace | 27 ----- .../furnace-pastebin/paste-list.furnace | 7 -- .../furnace-pastebin/paste-summary.furnace | 9 -- unmaintained/furnace-pastebin/pastebin.factor | 110 ------------------ .../furnace-pastebin/show-paste.furnace | 15 --- 9 files changed, 1 insertion(+), 221 deletions(-) delete mode 100644 unmaintained/furnace-pastebin/annotate-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/annotation.furnace delete mode 100644 unmaintained/furnace-pastebin/load.factor delete mode 100644 unmaintained/furnace-pastebin/new-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-list.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-summary.furnace delete mode 100644 unmaintained/furnace-pastebin/pastebin.factor delete mode 100644 unmaintained/furnace-pastebin/show-paste.furnace diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index b0d52ef2ef..1d2a24057c 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -25,14 +25,10 @@ $nl ABOUT: "number-strings" HELP: digits>integer -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } } +{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } } { $description "Converts a sequence of digits (with most significant digit first) into an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: valid-digits? -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } } -{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ; - HELP: >digit { $values { "n" "an integer between 0 and 35" } { "ch" "a character" } } { $description "Outputs a character representation of a digit." } @@ -43,11 +39,6 @@ HELP: digit> { $description "Converts a character representation of a digit to an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: string>integer -{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } } -{ $description "Creates an integer from a string representation." } -{ $notes "The " { $link base> } " word is more general." } ; - HELP: base> { $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } } { $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10." diff --git a/unmaintained/furnace-pastebin/annotate-paste.furnace b/unmaintained/furnace-pastebin/annotate-paste.furnace deleted file mode 100644 index 24f0d4ea94..0000000000 --- a/unmaintained/furnace-pastebin/annotate-paste.furnace +++ /dev/null @@ -1,28 +0,0 @@ -<% USING: namespaces math io ; %> - -

      Annotate

      - -
      - - - -string write %>" /> - - - - - - - - - - - - - - - -
      Summary:
      Your name:
      Contents:
      - - -
      diff --git a/unmaintained/furnace-pastebin/annotation.furnace b/unmaintained/furnace-pastebin/annotation.furnace deleted file mode 100644 index ed1bdac845..0000000000 --- a/unmaintained/furnace-pastebin/annotation.furnace +++ /dev/null @@ -1,11 +0,0 @@ -<% USING: namespaces io ; %> - -

      Annotation: <% "summary" get write %>

      - - - - - -
      Annotation by:<% "author" get write %>
      Channel:<% "channel" get write %>
      Created:<% "date" get write %>
      - -
      <% "contents" get write %>
      diff --git a/unmaintained/furnace-pastebin/load.factor b/unmaintained/furnace-pastebin/load.factor deleted file mode 100644 index 4f3bdc8db9..0000000000 --- a/unmaintained/furnace-pastebin/load.factor +++ /dev/null @@ -1,4 +0,0 @@ -REQUIRES: libs/concurrency libs/furnace libs/irc libs/store ; - -PROVIDE: apps/furnace-pastebin -{ +files+ { "pastebin.factor" } } ; diff --git a/unmaintained/furnace-pastebin/new-paste.furnace b/unmaintained/furnace-pastebin/new-paste.furnace deleted file mode 100644 index 36f0397b67..0000000000 --- a/unmaintained/furnace-pastebin/new-paste.furnace +++ /dev/null @@ -1,27 +0,0 @@ -
      - - - - - - - - - - - - - - - - - - - - - - -
      Summary:
      Your name:
      Channel:
      Contents:
      - - -
      diff --git a/unmaintained/furnace-pastebin/paste-list.furnace b/unmaintained/furnace-pastebin/paste-list.furnace deleted file mode 100644 index 7a25ae2f50..0000000000 --- a/unmaintained/furnace-pastebin/paste-list.furnace +++ /dev/null @@ -1,7 +0,0 @@ -<% USING: namespaces furnace sequences ; %> - - -<% "new-paste-quot" get "New paste" render-link %> - -<% "pastes" get [ "paste-summary" render-template ] each %>
       Summary:Paste by:LinkDate
      - diff --git a/unmaintained/furnace-pastebin/paste-summary.furnace b/unmaintained/furnace-pastebin/paste-summary.furnace deleted file mode 100644 index ad54c8d397..0000000000 --- a/unmaintained/furnace-pastebin/paste-summary.furnace +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: namespaces io kernel math furnace ; %> - - -<% "n" get number>string write %> -<% "summary" get write %> -<% "author" get write %> -<% "n" get number>string "show-paste-quot" get curry "Show" render-link %> -<% "date" get print %> - diff --git a/unmaintained/furnace-pastebin/pastebin.factor b/unmaintained/furnace-pastebin/pastebin.factor deleted file mode 100644 index b11129312f..0000000000 --- a/unmaintained/furnace-pastebin/pastebin.factor +++ /dev/null @@ -1,110 +0,0 @@ -IN: furnace:pastebin -USING: calendar concurrency irc kernel namespaces sequences -furnace hashtables math store ; - -TUPLE: paste n summary author channel contents date annotations ; - -TUPLE: annotation summary author contents ; - -C: paste ( summary author channel contents -- paste ) - V{ } clone over set-paste-annotations - [ set-paste-contents ] keep - [ set-paste-channel ] keep - [ set-paste-author ] keep - [ set-paste-summary ] keep ; - -TUPLE: pastebin pastes ; - -C: pastebin ( -- pastebin ) - V{ } clone over set-pastebin-pastes ; - -SYMBOL: store -"pastebin.store" load-store store set-global - pastebin store get store-variable - -: add-paste ( paste pastebin -- ) - now timestamp>http-string pick set-paste-date - dup pastebin-pastes length pick set-paste-n - pastebin-pastes push ; - -: get-paste ( n -- paste ) - pastebin get pastebin-pastes nth ; - -: show-paste ( n -- ) - get-paste "show-paste" "Paste" render-page ; - -\ show-paste { { "n" v-number } } define-action - -: new-paste ( -- ) - f "new-paste" "New paste" render-page ; - -\ new-paste { } define-action - -: make-remote-process - "trifocus.net" 4030 "public-irc" ; - -: alert-new-paste ( paste -- ) - >r make-remote-process r> - f over paste-channel rot [ - dup paste-author % - " pasted " % - CHAR: " , - dup paste-summary % - CHAR: " , - " at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - paste-n # - ] "" make swap send ; - -: alert-annotation ( annotation paste -- ) - make-remote-process -rot - f over paste-channel 2swap [ - over annotation-author % - " annotated paste " % - " with \"" % - over annotation-summary % - "\" at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - dup paste-n # - 2drop - ] "" make swap send ; - - -: submit-paste ( summary author channel contents -- ) - dup pastebin get-global add-paste - alert-new-paste store get save-store ; - -\ submit-paste { - { "summary" v-required } - { "author" v-required } - { "channel" "#concatenative" v-default } - { "contents" v-required } -} define-action - -: paste-list ( -- ) - [ - [ show-paste ] "show-paste-quot" set - [ new-paste ] "new-paste-quot" set - - pastebin get "paste-list" "Pastebin" render-page - ] with-scope ; - -\ paste-list { } define-action - -\ submit-paste [ paste-list ] define-redirect - -: annotate-paste ( paste# summary author contents -- ) - swap get-paste - [ paste-annotations push ] 2keep - alert-annotation store get save-store ; - -\ annotate-paste { - { "n" v-required v-number } - { "summary" v-required } - { "author" v-required } - { "contents" v-required } -} define-action - -\ annotate-paste [ "n" show-paste ] define-redirect - -"pastebin" "paste-list" "apps/furnace-pastebin" web-app diff --git a/unmaintained/furnace-pastebin/show-paste.furnace b/unmaintained/furnace-pastebin/show-paste.furnace deleted file mode 100644 index b3b4e99b6e..0000000000 --- a/unmaintained/furnace-pastebin/show-paste.furnace +++ /dev/null @@ -1,15 +0,0 @@ -<% USING: namespaces io furnace sequences ; %> - -

      Paste: <% "summary" get write %>

      - - - - - -
      Paste by:<% "author" get write %>
      Channel:<% "channel" get write %>
      Created:<% "date" get write %>
      - -
      <% "contents" get write %>
      - -<% "annotations" get [ "annotation" render-template ] each %> - -<% model get "annotate-paste" render-template %> From 831b712f848c90d97e5431e25ff47f122c27843e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:26 -0600 Subject: [PATCH 224/317] Move logging code to io.logging --- extra/io/logging/authors.txt | 1 + extra/io/logging/logging-docs.factor | 26 +++++++++++++++ extra/io/logging/logging.factor | 47 ++++++++++++++++++++++++++++ extra/io/logging/summary.txt | 1 + extra/io/server/server-docs.factor | 23 -------------- extra/io/server/server.factor | 41 ++---------------------- 6 files changed, 77 insertions(+), 62 deletions(-) create mode 100644 extra/io/logging/authors.txt create mode 100644 extra/io/logging/logging-docs.factor create mode 100644 extra/io/logging/logging.factor create mode 100644 extra/io/logging/summary.txt diff --git a/extra/io/logging/authors.txt b/extra/io/logging/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor new file mode 100644 index 0000000000..6cd03ce212 --- /dev/null +++ b/extra/io/logging/logging-docs.factor @@ -0,0 +1,26 @@ +IN: io.logging +USING: help.markup help.syntax io ; + +HELP: log-stream +{ $var-description "Holds an output stream for logging messages." } +{ $see-also log-error log-client with-logging } ; + +HELP: log-message +{ $values { "str" "a string" } } +{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } +{ $see-also log-error log-client } ; + +HELP: log-error +{ $values { "str" "a string" } } +{ $description "Logs an error message." } +{ $see-also log-message log-client } ; + +HELP: log-client +{ $values { "client" "a client socket stream" } } +{ $description "Logs an incoming client connection." } +{ $see-also log-message log-error } ; + +HELP: with-logging +{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } +{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; + diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor new file mode 100644 index 0000000000..bd9dc0862e --- /dev/null +++ b/extra/io/logging/logging.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint ; +IN: io.logging + +SYMBOL: log-stream + +: to-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + +: log-message ( str -- ) + [ + "[" write now timestamp>string write "] " write + print flush + ] to-log-stream ; + +: log-error ( str -- ) "Error: " swap append log-message ; + +: log-client ( client -- ) + "Accepted connection from " + swap client-stream-addr unparse append log-message ; + +: log-file ( service -- path ) + ".log" append resource-path ; + +: with-log-stream ( stream quot -- ) + log-stream get [ nip call ] [ + log-stream swap with-variable + ] if ; inline + +: with-log-file ( file quot -- ) + >r r> + [ with-log-stream ] curry + with-disposal ; inline + +: with-log-stdio ( quot -- ) + stdio get swap with-log-stream ; inline + +: with-logging ( service quot -- ) + over [ + >r log-file + "Writing log messages to " write dup print flush r> + with-log-file + ] [ + nip with-log-stdio + ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt new file mode 100644 index 0000000000..0edce8f0cf --- /dev/null +++ b/extra/io/logging/summary.txt @@ -0,0 +1 @@ +Basic logging framework for server applications diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor index ea8320f18d..4e4342266a 100644 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -1,29 +1,6 @@ USING: help help.syntax help.markup io ; IN: io.server -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - HELP: with-client { $values { "quot" "a quotation" } { "client" "a client socket stream" } } { $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 3c3d2c20f5..182712c984 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,49 +1,12 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files continuations kernel math -math.parser namespaces parser sequences strings +USING: io io.sockets io.files io.logging continuations kernel +math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -SYMBOL: log-stream - -: with-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] with-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-file ( file quot -- ) - >r r> - [ log-stream swap with-variable ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get log-stream rot with-variable ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline - : with-client ( quot client -- ) dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline From 6373e350baf86d3814fdd05c3614522db84cd4b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:38 -0600 Subject: [PATCH 225/317] Removed test-changes word --- extra/ui/tools/tools.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 8e2eeaa0ba..71a7080c86 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -80,14 +80,10 @@ H{ { +nullary+ t } } define-command \ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command -\ test-changes -H{ { +nullary+ t } { +listener+ t } } define-command - workspace "workflow" f { { T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f f "ESC" } hide-popup } { T{ key-down f f "F2" } refresh-all } - { T{ key-down f { A+ } "F2" } test-changes } } define-command-map [ From a06c536123a2b8a1c7785caa591a9bdf1e742cbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:03:27 -0600 Subject: [PATCH 226/317] Cleaned up SMTP implementation and added some features --- extra/smtp/authors.txt | 2 + extra/smtp/server/server.factor | 72 ++++++++++ extra/smtp/smtp-tests.factor | 130 ++++++++++++++---- extra/smtp/smtp.factor | 237 ++++++++++++++++++-------------- 4 files changed, 310 insertions(+), 131 deletions(-) create mode 100644 extra/smtp/server/server.factor diff --git a/extra/smtp/authors.txt b/extra/smtp/authors.txt index 7c29e7c401..159b1e91e9 100644 --- a/extra/smtp/authors.txt +++ b/extra/smtp/authors.txt @@ -1 +1,3 @@ Elie Chaftari +Dirk Vleugels +Slava Pestov diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor new file mode 100644 index 0000000000..2cfc1e65e4 --- /dev/null +++ b/extra/smtp/server/server.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007 Elie CHAFTARI +! See http://factorcode.org/license.txt for BSD license. + +! Mock SMTP server for testing purposes. + +! Usage: 4321 smtp-server +! $ telnet 127.0.0.1 4321 +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! 220 hello +! EHLO +! 220 and..? +! MAIL FROM: +! 220 OK +! RCPT TO: +! 220 OK +! Hi +! 500 ERROR +! DATA +! 354 Enter message, ending with "." on a line by itself +! Hello I am still waiting for your call +! Thanks +! . +! 220 OK +! QUIT +! bye +! Connection closed by foreign host. + +USING: combinators kernel prettyprint io io.server sequences +namespaces io.sockets continuations ; + +SYMBOL: data-mode + +: process ( -- ) + readln { + { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ + "220 and..?\r\n" write flush t + ] } + { [ dup "QUIT" = ] [ + "bye\r\n" write flush f + ] } + { [ dup "MAIL FROM:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "RCPT TO:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "DATA" = ] [ + data-mode on + "354 Enter message, ending with \".\" on a line by itself\r\n" + write flush t + ] } + { [ dup "." = data-mode get and ] [ + data-mode off + "220 OK\r\n" write flush t + ] } + { [ data-mode get ] [ t ] } + { [ t ] [ + "500 ERROR\r\n" write flush t + ] } + } cond nip [ process ] when ; + +: smtp-server ( port -- ) + "Starting SMTP server on port " write dup . flush + "127.0.0.1" swap [ + accept [ + 60000 stdio get set-timeout + "220 hello\r\n" write flush + process + ] with-stream + ] with-disposal ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 8ab1fd0899..9a357fdc7d 100644 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,41 +1,111 @@ -! Tested with Apache JAMES version 2.3.1 on localhost -! cram-md5 authentication tested against Exim 4 -! Replace "localhost" with your smtp server -! e.g. "your.smtp.server" initialize +USING: smtp tools.test io.streams.string io.logging threads +smtp.server kernel sequences namespaces ; +IN: temporary -USING: smtp tools.test ; +{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as -"localhost" initialize ! replace localhost with your smtp server +[ "hello\nworld" validate-address ] must-fail -! 8889 set-port ! default port = 25, change for testing purposes +[ "slava@factorcode.org" ] +[ "slava@factorcode.org" validate-address ] unit-test -! 30000 set-read-timeout ! default = 60000 -! f set-esmtp ! when esmtp (extended smtp) is not supported +[ { "hello" "." "world" } validate-message ] must-fail -start +[ "hello\r\nworld\r\n.\r\n" ] [ + { "hello" "world" } [ send-body ] string-out +] unit-test -! "md5 password here" "login" cram-md5-auth +[ + [ + "500 syntax error" check-response + ] with-log-stdio +] must-fail -"root@localhost" mailfrom ! your@mail.address +[ ] [ + [ + "220 success" check-response + ] with-log-stdio +] unit-test -"root@localhost" rcptto ! someone@example.com +[ "220 success" ] [ + "220 success" [ receive-response ] string-in +] unit-test -! { "From: Your Name " -! "To: Destination Address " -! "Subject: test message" -! "Date: Thu, 17 May 2007 18:46:45 +0200" -! "Message-Id: " -! " " -! "This is a test message." -! } send-message +[ "220 the end" ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ receive-response ] string-in + ] with-log-stdio +] unit-test -{ "From: Your Name " - "To: Destination Address " - "Subject: test message" - "Date: Thu, 17 May 2007 18:46:45 +0200" - "Message-Id: " - " " - "This is a test message." -} send-message +[ ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ get-ok ] string-in + ] with-log-stdio +] unit-test -quit \ No newline at end of file +[ + "Subject:\r\nsecurity hole" validate-header +] must-fail + +[ + V{ + { "To" "Slava , Ed " } + { "From" "Doug " } + { "Subject" "Factor rules" } + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + simple-headers >r >r 2 head* r> r> +] unit-test + +[ + { + "To: Slava , Ed " + "From: Doug " + "Subject: Factor rules" + f + f + " " + "Hi guys" + "Bye guys" + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + prepare-simple-message + >r >r f 3 pick set-nth f 4 pick set-nth r> r> +] unit-test + +[ ] [ [ 4321 smtp-server ] in-thread ] unit-test + +[ ] [ + [ + 4321 smtp-port set + + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + + send-simple-message + ] with-scope +] unit-test \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 9116d094de..77bfb6cd82 100644 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,138 +1,173 @@ -! Copyright (C) 2007 Elie CHAFTARI +! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -! -! cram-md5 auth code contributed by Dirk Vleugels - -USING: alien alien.c-types combinators crypto.common crypto.hmac base64 -kernel io io.sockets namespaces sequences splitting ; +USING: namespaces io kernel io.logging io.sockets sequences +combinators sequences.lib splitting assocs strings math.parser +random system calendar ; IN: smtp -! ========================================================= -! smtp.factor implementation -! ========================================================= +SYMBOL: smtp-domain +SYMBOL: smtp-host "localhost" smtp-host set-global +SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: esmtp t esmtp set-global -! Connection default values -: default-port 25 ; inline -: read-timeout 60000 ; inline -: esmtp t ; inline ! t = ehlo -: domain "localhost.localdomain" ; inline +: log-smtp-connection ( host port -- ) + [ + "Establishing SMTP connection to " % swap % ":" % # + ] "" make log-message ; -SYMBOL: sess -SYMBOL: conn -SYMBOL: challenge +: with-smtp-connection ( quot -- ) + [ + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream + ] with-log-stdio ; inline -TUPLE: session address port timeout domain esmtp ; +: crlf "\r\n" write ; -: ( address -- session ) - default-port read-timeout domain esmtp - session construct-boa ; +: helo ( -- ) + esmtp get "EHLO " "HELO " ? write host-name write crlf ; -! ========================================================= -! Initialization routines -! ========================================================= +: validate-address ( string -- string' ) + #! Make sure we send funky stuff to the server by accident. + dup [ "\r\n>" member? ] contains? + [ "Bad e-mail address: " swap append throw ] when ; -: initialize ( address -- ) - sess set ; +: mail-from ( fromaddr -- ) + "MAIL FROM:<" write validate-address write ">" write crlf ; -: set-port ( port -- ) - sess get set-session-port ; +: rcpt-to ( to -- ) + "RCPT TO:<" write validate-address write ">" write crlf ; -: set-read-timeout ( timeout -- ) - sess get set-session-timeout ; +: data ( -- ) + "DATA" write crlf ; -: set-esmtp ( esmtp -- ) - sess get set-session-esmtp ; +: validate-message ( msg -- msg' ) + "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; -: set-domain ( -- ) - host-name sess get set-session-domain ; +: send-body ( body -- ) + validate-message + [ write crlf ] each + "." write crlf ; -: do-start ( -- ) - sess get [ session-address ] keep session-port - dup conn set [ sess get session-timeout swap set-timeout ] - keep stream-readln print ; +: quit ( -- ) + "QUIT" write crlf ; -! ========================================================= -! Command routines -! ========================================================= +: log-response ( string -- ) "SMTP: " swap append log-message ; : check-response ( response -- ) { - { [ dup "220" head? ] [ print ] } - { [ dup "235" swap subseq? ] [ print ] } - { [ dup "250" head? ] [ print ] } - { [ dup "221" head? ] [ print ] } - { [ dup "bye" head? ] [ print ] } + { [ dup "220" head? ] [ log-response ] } + { [ dup "235" swap subseq? ] [ log-response ] } + { [ dup "250" head? ] [ log-response ] } + { [ dup "221" head? ] [ log-response ] } + { [ dup "bye" head? ] [ log-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } - { [ dup "354" head? ] [ print ] } - { [ dup "50" head? ] [ print "syntax error" throw ] } - { [ dup "53" head? ] [ print "invalid authentication data" throw ] } - { [ dup "55" head? ] [ print "fatal error" throw ] } - { [ t ] [ "unknow error" throw ] } + { [ dup "354" head? ] [ log-response ] } + { [ dup "50" head? ] [ log-response "syntax error" throw ] } + { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ t ] [ "unknown error" throw ] } } cond ; -SYMBOL: multiline - : multiline? ( response -- boolean ) - CHAR: - swap index 3 = ; + ?fourth CHAR: - = ; -: process-multiline ( -- response ) - conn get stream-readln dup - multiline get " " append head? [ - print +: process-multiline ( multiline -- response ) + >r readln r> 2dup " " append head? [ + drop dup log-response ] [ - check-response process-multiline + swap check-response process-multiline ] if ; -: recv-response ( -- response ) - conn get stream-readln - dup multiline? [ - dup 3 head multiline set process-multiline - ] [ ] if ; +: receive-response ( -- response ) + readln + dup multiline? [ 3 head process-multiline ] when ; -: get-ok ( command -- ) - >r conn get r> over stream-write stream-flush - recv-response check-response ; +: get-ok ( -- ) flush receive-response check-response ; -: helo ( -- ) - "HELO " sess get session-domain append "\r\n" append get-ok ; +: send-raw-message ( body to from -- ) + [ + helo get-ok + mail-from get-ok + [ rcpt-to get-ok ] each + data get-ok + send-body get-ok + quit get-ok + ] with-smtp-connection ; -: ehlo ( -- ) - "EHLO " sess get session-domain append "\r\n" append get-ok ; +: validate-header ( string -- string' ) + dup [ "\r\n" member? ] contains? + [ "Invalid header string: " swap append throw ] when ; -: mailfrom ( fromaddr -- ) - "MAIL FROM:<" swap append ">\r\n" append get-ok ; +: prepare-header ( key value -- ) + swap + validate-header % + ": " % + validate-header % ; -: rcptto ( to -- ) - "RCPT TO:<" swap append ">\r\n" append get-ok ; +: prepare-headers ( assoc -- ) + [ [ prepare-header ] "" make , ] assoc-each ; -: (cram-md5-auth) ( -- response ) - swap challenge get - string>md5-hmac hex-string - " " swap append append - >base64 ; +: extract-email ( recepient -- email ) + #! This could be much smarter. + " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; -: cram-md5-auth ( key login -- ) - "AUTH CRAM-MD5\r\n" get-ok - (cram-md5-auth) "\r\n" append get-ok ; - -: data ( -- ) - "DATA\r\n" get-ok ; +: message-id ( -- string ) + [ + "<" % + 2 big-random # + "-" % + millis # + "@" % + smtp-domain get % + ">" % + ] "" make ; -: start ( -- ) - set-domain ! replaces localhost.localdomain with hostname - do-start - sess get session-esmtp [ - ehlo - ] [ - helo - ] if ; +: simple-headers ( subject to from -- headers to from ) + [ + >r dup ", " join "To" set [ extract-email ] map r> + dup "From" set extract-email + rot "Subject" set + now timestamp>rfc822-string "Date" set + message-id "Message-Id" set + ] { } make-assoc -rot ; -: send-message ( msg -- ) - data - "\r\n" join conn get swap "\r\n" append over stream-write - stream-flush ".\r\n" get-ok ; +: prepare-message ( body headers -- body' ) + [ + prepare-headers + " " , + dup string? [ string-lines ] when % + ] { } make ; -: quit ( -- ) - "QUIT\r\n" get-ok ; +: prepare-simple-message ( body subject to from -- body' to from ) + simple-headers >r >r prepare-message r> r> ; + +: send-message ( body headers to from -- ) + >r >r prepare-message r> r> send-raw-message ; + +: send-simple-message ( body subject to from -- ) + prepare-simple-message send-raw-message ; + +! Dirk's old AUTH CRAM-MD5 code. I don't know anything about +! CRAM MD5, and the old code didn't work properly either, so here +! it is in case anyone wants to fix it later. +! +! check-response used to have this clause: +! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } +! +! and the rest of the code was as follows: +! : (cram-md5-auth) ( -- response ) +! swap challenge get +! string>md5-hmac hex-string +! " " swap append append +! >base64 ; +! +! : cram-md5-auth ( key login -- ) +! "AUTH CRAM-MD5\r\n" get-ok +! (cram-md5-auth) "\r\n" append get-ok ; From 2f46a618a694e4eb8cc2830684b21ba64dba0a84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:00 -0600 Subject: [PATCH 227/317] Add new word to calendar --- extra/calendar/calendar.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index a1fe0a55ea..32c5c0233c 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,13 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + timestamp-gmt-offset { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } + { [ dup 0 > ] [ "+" write write-00 "00" write ] } + } cond + ] string-out ; + : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt [ - (timestamp>string) - " GMT" write - ] string-out ; + >gmt timestamp>rfc822-string ; : (timestamp>rfc3339) ( timestamp -- ) dup timestamp-year number>string write CHAR: - write1 From dad715e7b0e2fe985eb5b5027632c2ee0d4acaaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:10 -0600 Subject: [PATCH 228/317] Update for io.logging change --- extra/http/server/responders/responders.factor | 4 ++-- extra/http/server/server.factor | 4 ++-- extra/webapps/planet/planet.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 70503236f6..8f4f146508 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib ; +strings io.server vectors assocs.lib io.logging ; IN: http.server.responders diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 99ed41afa3..f8ac503819 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server ; +io.server io.logging ; IN: http.server diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index ede0c579de..b777780e11 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.server ; +xml.writer prettyprint io.logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -90,7 +90,7 @@ SYMBOL: last-update [ fetch-feed ] [ - swap [ . error. ] with-log-stream f + swap [ . error. ] to-log-stream f ] recover ; : fetch-blogroll ( blogroll -- entries ) From 386d93b6e5a68b3d65a1b342a17cced48c554bdc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:28 -0600 Subject: [PATCH 229/317] Moved smtp-server.factor to smtp/server/server.factor --- extra/smtp/smtp-server.factor | 68 ----------------------------------- 1 file changed, 68 deletions(-) delete mode 100644 extra/smtp/smtp-server.factor diff --git a/extra/smtp/smtp-server.factor b/extra/smtp/smtp-server.factor deleted file mode 100644 index e980ee36e6..0000000000 --- a/extra/smtp/smtp-server.factor +++ /dev/null @@ -1,68 +0,0 @@ -! Copyright (C) 2007 Elie CHAFTARI -! See http://factorcode.org/license.txt for BSD license. - -! Usage: 8889 start-server -! $ telnet 127.0.0.1 8889 -! Trying 127.0.0.1... -! Connected to localhost. -! Escape character is '^]'. -! 220 hello -! EHLO -! 220 and..? -! MAIL FROM: -! 220 OK -! RCPT TO: -! 220 OK -! Hi -! 500 ERROR -! DATA -! 354 Enter message, ending with "." on a line by itself -! Hello I am still waiting for your call -! Thanks -! . -! 220 OK -! QUIT -! bye -! Connection closed by foreign host. - -USING: combinators kernel prettyprint io io.server sequences -namespaces ; - -SYMBOL: data-mode - -: process ( -- ) - readln { - { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ - "220 and..?\r\n" write flush t - ] } - { [ dup "QUIT" = ] [ - "bye\r\n" write flush f - ] } - { [ dup "MAIL FROM:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "RCPT TO:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "DATA" = ] [ - data-mode on - "354 Enter message, ending with \".\" on a line by itself\r\n" - write flush t - ] } - { [ dup "." = data-mode get and ] [ - data-mode off - "220 OK\r\n" write flush t - ] } - { [ data-mode get ] [ t ] } - { [ t ] [ - "500 ERROR\r\n" write flush t - ] } - } cond nip [ process ] when ; - -: start-server ( port -- ) - "Starting SMTP server on port " write dup . flush - internet-server "smtp-server" [ - 60000 stdio get set-timeout - "220 hello\r\n" write flush - process - ] with-server ; From b5e1edfeed462036ce9c211006cfca29273bf333 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:36:11 -0600 Subject: [PATCH 230/317] Removed obsolete vocab --- extra/tools/test/inference/authors.txt | 1 - extra/tools/test/inference/inference.factor | 15 --------------- 2 files changed, 16 deletions(-) delete mode 100755 extra/tools/test/inference/authors.txt delete mode 100755 extra/tools/test/inference/inference.factor diff --git a/extra/tools/test/inference/authors.txt b/extra/tools/test/inference/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/tools/test/inference/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor deleted file mode 100755 index cc77f4910d..0000000000 --- a/extra/tools/test/inference/inference.factor +++ /dev/null @@ -1,15 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: effects sequences kernel arrays quotations inference -tools.test words ; -IN: tools.test.inference - -: short-effect - dup effect-in length swap effect-out length 2array ; - -: unit-test-effect ( effect quot -- ) - >r 1quotation r> [ infer short-effect ] curry unit-test ; - -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - [ infer drop ] curry [ ] swap unit-test ; From 6204f5698130c8d35056593e60b7c8ac79dab282 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 13:48:49 -0600 Subject: [PATCH 231/317] fix gmt-offset on windows --- extra/calendar/windows/windows.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 320400822c..afc040ef75 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -9,5 +9,4 @@ T{ windows-calendar } calendar-backend set-global M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" [ GetTimeZoneInformation win32-error=0/f ] keep - [ TIME_ZONE_INFORMATION-Bias ] keep - TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ; + TIME_ZONE_INFORMATION-Bias 60 / neg ; From e05bb24a697b5721be7ed6d5caa9e1136b05f1ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 14:17:07 -0600 Subject: [PATCH 232/317] make rfc822-string print fractional times fix windows gmt-offset yet again -- bad return value --- extra/calendar/calendar.factor | 16 +++++++++++----- extra/calendar/windows/windows.factor | 5 ++++- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 32c5c0233c..012080d3b7 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,17 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + : timestamp>rfc822-string ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ dup (timestamp>string) " " write - timestamp-gmt-offset { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } - { [ dup 0 > ] [ "+" write write-00 "00" write ] } - } cond + timestamp-gmt-offset write-gmt-offset ] string-out ; : timestamp>http-string ( timestamp -- str ) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index afc040ef75..9e34fdac00 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -6,7 +6,10 @@ TUPLE: windows-calendar ; T{ windows-calendar } calendar-backend set-global +: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline + M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" - [ GetTimeZoneInformation win32-error=0/f ] keep + dup GetTimeZoneInformation + TIME_ZONE_ID_INVALID = [ win32-error ] when TIME_ZONE_INFORMATION-Bias 60 / neg ; From 0570449ffdabeaad6dc49e4489e178200568d1cc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 15:14:40 -0600 Subject: [PATCH 233/317] Tweak builder --- extra/builder/builder.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5bfd5e01cf..5e992ccc81 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,8 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - ! "git://factorcode.org/git/factor.git" - "http://dharmatech.onigirihouse.com/factor.git" + "git://factorcode.org/git/factor.git" + ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 5310a2cabea0341d33f7096e4e7ff9f043717bc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:07:43 -0600 Subject: [PATCH 234/317] New logging framework --- .../distributed/distributed.factor | 2 +- .../http/server/responders/responders.factor | 39 +++--- extra/http/server/server.factor | 6 +- extra/io/logging/logging-docs.factor | 26 ---- extra/io/logging/logging.factor | 47 ------- extra/io/logging/summary.txt | 1 - extra/io/server/server.factor | 40 +++--- extra/logging/analysis/analysis.factor | 69 ++++++++++ .../logging => logging/analysis}/authors.txt | 2 +- extra/logging/analysis/summary.txt | 1 + extra/logging/authors.txt | 1 + extra/logging/insomniac/authors.txt | 1 + extra/logging/insomniac/insomniac.factor | 49 +++++++ extra/logging/insomniac/summary.txt | 1 + extra/logging/logging.factor | 122 ++++++++++++++++++ extra/logging/parser/authors.txt | 1 + extra/logging/parser/parser.factor | 66 ++++++++++ extra/logging/parser/summary.txt | 1 + extra/logging/server/authors.txt | 1 + extra/logging/server/server.factor | 101 +++++++++++++++ extra/logging/server/summary.txt | 1 + extra/logging/summary.txt | 1 + extra/raptor/cron/cron.factor | 6 +- extra/smtp/smtp-tests.factor | 2 +- extra/smtp/smtp.factor | 47 ++++--- extra/tools/annotations/annotations.factor | 20 ++- extra/tools/browser/browser.factor | 1 + extra/webapps/file/file.factor | 18 ++- extra/webapps/planet/planet.factor | 20 +-- 29 files changed, 523 insertions(+), 170 deletions(-) mode change 100644 => 100755 extra/concurrency/distributed/distributed.factor mode change 100644 => 100755 extra/http/server/responders/responders.factor mode change 100644 => 100755 extra/http/server/server.factor delete mode 100644 extra/io/logging/logging-docs.factor delete mode 100644 extra/io/logging/logging.factor delete mode 100644 extra/io/logging/summary.txt create mode 100755 extra/logging/analysis/analysis.factor rename extra/{io/logging => logging/analysis}/authors.txt (92%) mode change 100644 => 100755 create mode 100755 extra/logging/analysis/summary.txt create mode 100755 extra/logging/authors.txt create mode 100755 extra/logging/insomniac/authors.txt create mode 100755 extra/logging/insomniac/insomniac.factor create mode 100755 extra/logging/insomniac/summary.txt create mode 100755 extra/logging/logging.factor create mode 100755 extra/logging/parser/authors.txt create mode 100755 extra/logging/parser/parser.factor create mode 100755 extra/logging/parser/summary.txt create mode 100755 extra/logging/server/authors.txt create mode 100755 extra/logging/server/server.factor create mode 100755 extra/logging/server/summary.txt create mode 100755 extra/logging/summary.txt mode change 100644 => 100755 extra/raptor/cron/cron.factor mode change 100644 => 100755 extra/smtp/smtp-tests.factor mode change 100644 => 100755 extra/smtp/smtp.factor diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor old mode 100644 new mode 100755 index 9024c0630f..83052b803a --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -14,7 +14,7 @@ C: node : node-server ( port -- ) internet-server - "concurrency" + "concurrency.distributed" [ handle-node-client ] with-server ; : send-to-node ( msg pid host port -- ) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor old mode 100644 new mode 100755 index 8f4f146508..e4e0e257c4 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib io.logging ; +strings io.server vectors assocs.lib logging ; IN: http.server.responders @@ -22,7 +22,7 @@ SYMBOL: responders

      write

      ; : error-head ( error -- ) - dup log-error response + response H{ { "Content-Type" V{ "text/html" } } } print-header nl ; : httpd-error ( error -- ) @@ -30,6 +30,8 @@ SYMBOL: responders dup error-head "head" "method" get = [ drop ] [ error-body ] if ; +\ httpd-error ERROR add-error-logging + : bad-request ( -- ) [ ! Make httpd-error print a body @@ -84,17 +86,21 @@ SYMBOL: max-post-request : read-post-request ( header -- str hash ) content-length [ read dup query>hash ] [ f f ] if* ; -: log-headers ( hash -- ) +LOG: log-headers DEBUG + +: interesting-headers ( assoc -- string ) [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append log-message - ] multi-assoc-each ; + [ + drop { + "user-agent" + "referer" + "x-forwarded-for" + "host" + } member? + ] assoc-subset [ + ": " swap 3append % "\n" % + ] multi-assoc-each + ] "" make ; : prepare-url ( url -- url ) #! This is executed in the with-request namespace. @@ -105,7 +111,7 @@ SYMBOL: max-post-request : prepare-header ( -- ) read-header dup "header" set - dup log-headers + dup interesting-headers log-headers read-post-request "response" set "raw-response" set ; ! Responders are called in a new namespace with these @@ -177,9 +183,6 @@ SYMBOL: max-post-request "/" "responder-url" set "default" responder call-responder ; -: log-responder ( path -- ) - "Calling responder " swap append log-message ; - : trim-/ ( url -- url ) #! Trim a leading /, if there is one. "/" ?head drop ; @@ -199,13 +202,15 @@ SYMBOL: max-post-request #! /foo/bar... - default responder used #! /responder/foo/bar - responder foo, argument bar vhost [ - dup log-responder trim-/ "responder/" ?head [ + trim-/ "responder/" ?head [ serve-explicit-responder ] [ serve-default-responder ] if ] bind ; +\ serve-responder DEBUG add-input-logging + : no-such-responder ( -- ) "404 No such responder" httpd-error ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor old mode 100644 new mode 100755 index f8ac503819..eca2253e2a --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server io.logging ; +io.server logging ; IN: http.server @@ -36,7 +36,6 @@ IN: http.server [ (handle-request) serve-responder ] with-scope ; : parse-request ( request -- ) - dup log-message " " split1 dup [ " HTTP" split1 drop url>path secure-path dup [ swap handle-request @@ -47,8 +46,9 @@ IN: http.server 2drop bad-request ] if ; +\ parse-request NOTICE add-input-logging + : httpd ( port -- ) - "Starting HTTP server on port " write dup . flush internet-server "http.server" [ 60000 stdio get set-timeout readln [ parse-request ] when* diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor deleted file mode 100644 index 6cd03ce212..0000000000 --- a/extra/io/logging/logging-docs.factor +++ /dev/null @@ -1,26 +0,0 @@ -IN: io.logging -USING: help.markup help.syntax io ; - -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor deleted file mode 100644 index bd9dc0862e..0000000000 --- a/extra/io/logging/logging.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io calendar sequences io.files -io.sockets continuations prettyprint ; -IN: io.logging - -SYMBOL: log-stream - -: to-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] to-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-stream ( stream quot -- ) - log-stream get [ nip call ] [ - log-stream swap with-variable - ] if ; inline - -: with-log-file ( file quot -- ) - >r r> - [ with-log-stream ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt deleted file mode 100644 index 0edce8f0cf..0000000000 --- a/extra/io/logging/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Basic logging framework for server applications diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 182712c984..829da27f6e 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,32 +1,34 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files io.logging continuations kernel +USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -: with-client ( quot client -- ) - dup log-client - [ swap with-stream ] 2curry concurrency:spawn drop ; inline +LOG: accepted-connection NOTICE + +: with-client ( client quot -- ) + [ + over client-stream-addr accepted-connection + with-stream* + ] curry with-disposal ; inline + +\ with-client NOTICE add-error-logging : accept-loop ( server quot -- ) - [ swap accept with-client ] 2keep accept-loop ; inline + [ + >r accept r> [ with-client ] 2curry concurrency:spawn + ] 2keep accept-loop ; inline : server-loop ( server quot -- ) [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) - "Waiting for connections on " pick unparse append - log-message - [ - >r r> server-loop - ] [ - "Cannot spawn server: " print - print-error - 2drop - ] recover ; inline + >r r> server-loop ; inline + +\ spawn-server NOTICE add-error-logging : local-server ( port -- seq ) "localhost" swap t resolve-host ; @@ -39,19 +41,21 @@ IN: io.server [ spawn-server ] curry concurrency:parallel-each ] curry with-logging ; inline -: log-datagram ( addrspec -- ) - "Received datagram from " swap unparse append log-message ; +: received-datagram ( addrspec -- ) drop ; + +\ received-datagram NOTICE add-input-logging : datagram-loop ( quot datagram -- ) [ - [ receive dup log-datagram >r swap call r> ] keep + [ receive dup received-datagram >r swap call r> ] keep pick [ send ] [ 3drop ] keep ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) - "Waiting for datagrams on " over unparse append log-message [ datagram-loop ] with-disposal ; inline +\ spawn-datagrams NOTICE add-input-logging + : with-datagrams ( seq service quot -- ) [ [ swap spawn-datagrams ] curry concurrency:parallel-each diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor new file mode 100755 index 0000000000..df53a8e70b --- /dev/null +++ b/extra/logging/analysis/analysis.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces words assocs logging sorting +prettyprint io io.styles strings logging.parser ; +IN: logging.analysis + +SYMBOL: word-names +SYMBOL: errors +SYMBOL: word-histogram +SYMBOL: message-histogram + +: analyze-entry ( entry -- ) + dup second ERROR eq? [ dup errors get push ] when + 1 over third word-histogram get at+ + dup third word-names get member? [ + 1 over 1 tail message-histogram get at+ + ] when + drop ; + +: analyze-entries ( entries word-names -- errors word-histogram message-histogram ) + [ + word-names set + V{ } clone errors set + H{ } clone word-histogram set + H{ } clone message-histogram set + + [ + analyze-entry + ] each + + errors get + word-histogram get + message-histogram get + ] with-scope ; + +: histogram. ( assoc quot -- ) + standard-table-style [ + >r >alist sort-values r> [ + [ >r swap r> with-cell pprint-cell ] with-row + ] curry assoc-each + ] tabular-output ; + +: log-entry. + [ + dup first [ write ] with-cell + dup second [ pprint ] with-cell + dup third [ write ] with-cell + fourth "\n" join [ write ] with-cell + ] with-row ; + +: errors. ( errors -- ) + standard-table-style + [ [ log-entry. ] each ] tabular-output ; + +: analysis. ( errors word-histogram message-histogram -- ) + "==== INTERESTING MESSAGES:" print nl + "Total: " write dup values sum . nl + [ + dup second write ": " write third "\n" join write + ] histogram. + nl + "==== WORDS:" print nl + [ write ] histogram. + nl + "==== ERRORS:" print nl + errors. ; + +: log-analysis ( lines word-names -- ) + >r parse-log r> analyze-entries analysis. ; diff --git a/extra/io/logging/authors.txt b/extra/logging/analysis/authors.txt old mode 100644 new mode 100755 similarity index 92% rename from extra/io/logging/authors.txt rename to extra/logging/analysis/authors.txt index 1901f27a24..56f4654064 --- a/extra/io/logging/authors.txt +++ b/extra/logging/analysis/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov diff --git a/extra/logging/analysis/summary.txt b/extra/logging/analysis/summary.txt new file mode 100755 index 0000000000..e614abca96 --- /dev/null +++ b/extra/logging/analysis/summary.txt @@ -0,0 +1 @@ +Analyze logs and produce summaries diff --git a/extra/logging/authors.txt b/extra/logging/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/authors.txt b/extra/logging/insomniac/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/insomniac/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor new file mode 100755 index 0000000000..b065dec9d3 --- /dev/null +++ b/extra/logging/insomniac/insomniac.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.analysis logging.server logging smtp io.sockets +kernel io.files io.streams.string namespaces raptor.cron ; +IN: logging.insomniac + +SYMBOL: insomniac-config + +SYMBOL: insomniac-smtp-host +SYMBOL: insomniac-smtp-port +SYMBOL: insomniac-sender +SYMBOL: insomniac-recipients + +: ?log-analysis ( service word-names -- string/f ) + >r log-path 1 log# dup exists? [ + file-lines r> [ log-analysis ] string-out + ] [ + r> 2drop f + ] if ; + +: with-insomniac-smtp ( quot -- ) + [ + insomniac-smtp-host get [ smtp-host set ] when* + insomniac-smtp-port get [ smtp-port set ] when* + call + ] with-scope ; inline + +: email-subject ( service -- string ) + [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ; + +: (email-log-report) ( service word-names -- ) + [ + over >r + ?log-analysis dup [ + r> email-subject + insomniac-recipients get + insomniac-sender get + send-simple-message + ] [ r> 2drop ] if + ] with-insomniac-smtp ; + +: email-log-report ( service word-names -- ) + (email-log-report) ; + +\ email-log-report NOTICE add-error-logging + +: schedule-insomniac ( service word-names -- ) + { 25 } { 6 } f f f -rot + [ email-log-report ] 2curry schedule ; diff --git a/extra/logging/insomniac/summary.txt b/extra/logging/insomniac/summary.txt new file mode 100755 index 0000000000..ddd21fb5b9 --- /dev/null +++ b/extra/logging/insomniac/summary.txt @@ -0,0 +1 @@ +Task which rotates logs and e-mails summaries diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor new file mode 100755 index 0000000000..71ea247567 --- /dev/null +++ b/extra/logging/logging.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.server sequences namespaces concurrency +words kernel arrays shuffle tools.annotations +prettyprint.config prettyprint debugger io.streams.string +splitting continuations effects arrays.lib parser strings +combinators.lib ; +IN: logging + +SYMBOL: DEBUG +SYMBOL: NOTICE +SYMBOL: WARNING +SYMBOL: ERROR +SYMBOL: CRITICAL + +: log-levels + { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; + +: send-to-log-server ( array string -- ) + add* "log-server" get send ; + +SYMBOL: log-service + +: check-log-message + pick string? + pick word? + pick word? and and + [ "Bad parameters to log-message" throw ] unless ; + +: log-message ( msg word level -- ) + check-log-message + log-service get dup [ + >r >r >r string-lines r> word-name r> word-name r> + 4array "log-message" send-to-log-server + ] [ + 4drop + ] if ; + +: rotate-logs ( -- ) + { } "rotate-logs" send-to-log-server ; + +: close-log-files ( -- ) + { } "close-log-files" send-to-log-server ; + +: with-logging ( service quot -- ) + log-service swap with-variable ; inline + +! Aspect-oriented programming idioms + +message ( obj -- inputs>message ) + dup one-string? [ first ] [ + H{ + { string-limit f } + { line-limit 1 } + { nesting-limit 3 } + { margin 0 } + } clone [ unparse ] bind + ] if ; + +PRIVATE> + +: (define-logging) ( word level quot -- ) + >r >r dup r> r> 2curry annotate ; + +: call-logging-quot ( quot word level -- quot' ) + "called" -rot [ log-message ] 3curry swap compose ; + +: add-logging ( word level -- ) + [ call-logging-quot ] (define-logging) ; + +: log-inputs ( n word level -- ) + log-service get [ + >r >r [ ndup ] keep narray inputs>message + r> r> log-message + ] [ + 3drop + ] if ; inline + +: input# stack-effect effect-in length ; + +: input-logging-quot ( quot word level -- quot' ) + over input# -rot [ log-inputs ] 3curry swap compose ; + +: add-input-logging ( word level -- ) + [ input-logging-quot ] (define-logging) ; + +: (log-error) ( object word level -- ) + log-service get [ + >r >r [ print-error ] string-out r> r> log-message + ] [ + 2drop rethrow + ] if ; + +: log-error ( object word -- ) ERROR (log-error) ; + +: log-critical ( object word -- ) CRITICAL (log-error) ; + +: error-logging-quot ( quot word -- quot' ) + dup stack-effect effect-in length + [ >r log-error r> ndrop ] 2curry + [ recover ] 2curry ; + +: add-error-logging ( word level -- ) + [ over >r input-logging-quot r> error-logging-quot ] + (define-logging) ; + +: LOG: + #! Syntax: name level + CREATE + dup reset-generic + dup scan-word + [ >r >r 1array inputs>message r> r> log-message ] 2curry + define ; parsing diff --git a/extra/logging/parser/authors.txt b/extra/logging/parser/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/parser/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor new file mode 100755 index 0000000000..f1cb7aa17e --- /dev/null +++ b/extra/logging/parser/parser.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser-combinators memoize kernel sequences +logging arrays words strings vectors io io.files +namespaces combinators combinators.lib logging.server ; +IN: logging.parser + +: string-of satisfy [ >string ] <@ ; + +: 'date' + [ CHAR: ] eq? not ] string-of + "[" "]" surrounded-by ; + +: 'log-level' + log-levels [ + [ word-name token ] keep [ nip ] curry <@ + ] map ; + +: 'word-name' + [ " :" member? not ] string-of ; + +SYMBOL: malformed + +: 'malformed-line' + [ drop t ] string-of [ malformed swap 2array ] <@ ; + +: 'log-message' + [ drop t ] string-of [ 1vector ] <@ ; + +MEMO: 'log-line' ( -- parser ) + 'date' " " token <& + 'log-level' " " token <& <&> + 'word-name' ": " token <& <:&> + 'log-message' <:&> + 'malformed-line' <|> ; + +: parse-log-line ( string -- entry ) + 'log-line' parse-1 ; + +: malformed? ( line -- ? ) + first malformed eq? ; + +: multiline? ( line -- ? ) + first first CHAR: - = ; + +: malformed-line + "Warning: malformed log line:" print + second print ; + +: add-multiline ( line -- ) + building get empty? [ + "Warning: log begins with multiline entry" print drop + ] [ + fourth first building get peek fourth push + ] if ; + +: parse-log ( lines -- entries ) + [ + [ + parse-log-line { + { [ dup malformed? ] [ malformed-line ] } + { [ dup multiline? ] [ add-multiline ] } + { [ t ] [ , ] } + } cond + ] each + ] { } make ; diff --git a/extra/logging/parser/summary.txt b/extra/logging/parser/summary.txt new file mode 100755 index 0000000000..cd5c68b156 --- /dev/null +++ b/extra/logging/parser/summary.txt @@ -0,0 +1 @@ +Log parser diff --git a/extra/logging/server/authors.txt b/extra/logging/server/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor new file mode 100755 index 0000000000..cddcea8d70 --- /dev/null +++ b/extra/logging/server/server.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint assocs math.parser +words debugger math combinators concurrency arrays init +math.ranges strings ; +IN: logging.server + +: log-root ( -- string ) + \ log-root get "logs" resource-path or ; + +: log-path ( service -- path ) + log-root swap path+ ; + +: log# ( path n -- path' ) + number>string ".log" append path+ ; + +SYMBOL: log-files + +: open-log-stream ( service -- stream ) + log-path + dup make-directories + 1 log# ; + +: log-stream ( service -- stream ) + log-files get [ open-log-stream ] cache ; + +: (write-message) ( msg word-name level multi? -- ) + [ + "[" write 20 CHAR: - write "] " write + ] [ + "[" write now (timestamp>rfc3339) "] " write + ] if + write bl write ": " write print ; + +: write-message ( msg word-name level -- ) + rot [ empty? not ] subset { + { [ dup empty? ] [ 3drop ] } + { [ dup length 1 = ] [ first -rot f (write-message) ] } + { [ t ] [ + [ first -rot f (write-message) ] 3keep + 1 tail -rot [ t (write-message) ] 2curry each + ] } + } cond ; + +: (log-message) ( msg -- ) + #! msg: { msg word-name level service } + first4 log-stream [ write-message flush ] with-stream* ; + +: try-dispose ( stream -- ) + [ dispose ] curry [ error. ] recover ; + +: close-log-file ( service -- ) + log-files get delete-at* + [ try-dispose ] [ drop ] if ; + +: (close-log-files) ( -- ) + log-files get + dup values [ try-dispose ] each + clear-assoc ; + +: keep-logs 10 ; + +: ?delete-file ( path -- ) + dup exists? [ delete-file ] [ drop ] if ; + +: delete-oldest keep-logs log# ?delete-file ; + +: ?rename-file ( old new -- ) + over exists? [ rename-file ] [ 2drop ] if ; + +: advance-log ( path n -- ) + [ 1- log# ] 2keep log# ?rename-file ; + +: rotate-log ( service -- ) + dup close-log-file + log-path + dup delete-oldest + keep-logs 1 [a,b] [ advance-log ] with each ; + +: (rotate-logs) ( -- ) + (close-log-files) + log-root directory [ drop rotate-log ] assoc-each ; + +: log-server-loop + [ + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-log-files" [ drop (close-log-files) ] } + } case + ] [ error. (close-log-files) ] recover + log-server-loop ; + +: log-server ( -- ) + [ log-server-loop ] spawn "log-server" set-global ; + +[ + H{ } clone log-files set-global + log-server +] "logging" add-init-hook diff --git a/extra/logging/server/summary.txt b/extra/logging/server/summary.txt new file mode 100755 index 0000000000..bebf3465f1 --- /dev/null +++ b/extra/logging/server/summary.txt @@ -0,0 +1 @@ +Distributed concurrency log server diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt new file mode 100755 index 0000000000..dbf29c2112 --- /dev/null +++ b/extra/logging/summary.txt @@ -0,0 +1 @@ +AOP Logging framework with support for log rotation and machine-readable logs diff --git a/extra/raptor/cron/cron.factor b/extra/raptor/cron/cron.factor old mode 100644 new mode 100755 index 8158a03286..e20598d2eb --- a/extra/raptor/cron/cron.factor +++ b/extra/raptor/cron/cron.factor @@ -1,6 +1,6 @@ USING: kernel namespaces threads sequences calendar - combinators.cleave combinators.lib ; + combinators.cleave combinators.lib debugger ; IN: raptor.cron @@ -43,9 +43,9 @@ C: when ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : recurring-job ( when quot -- ) - [ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; + [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; -: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ; +: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor old mode 100644 new mode 100755 index 9a357fdc7d..eda8d7cc1f --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,4 +1,4 @@ -USING: smtp tools.test io.streams.string io.logging threads +USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces ; IN: temporary diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor old mode 100644 new mode 100755 index 77bfb6cd82..211fbbcabd --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces io kernel io.logging io.sockets sequences +USING: namespaces io kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings math.parser random system calendar ; @@ -12,21 +12,18 @@ SYMBOL: smtp-port 25 smtp-port set-global SYMBOL: read-timeout 60000 read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) - [ - "Establishing SMTP connection to " % swap % ":" % # - ] "" make log-message ; +: log-smtp-connection ( host port -- ) 2drop ; + +\ log-smtp-connection NOTICE add-input-logging : with-smtp-connection ( quot -- ) - [ - smtp-host get smtp-port get - 2dup log-smtp-connection - [ - smtp-domain [ host-name or ] change - read-timeout get stdio get set-timeout - call - ] with-stream - ] with-log-stdio ; inline + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream ; inline : crlf "\r\n" write ; @@ -58,20 +55,20 @@ SYMBOL: esmtp t esmtp set-global : quit ( -- ) "QUIT" write crlf ; -: log-response ( string -- ) "SMTP: " swap append log-message ; +LOG: smtp-response DEBUG : check-response ( response -- ) { - { [ dup "220" head? ] [ log-response ] } - { [ dup "235" swap subseq? ] [ log-response ] } - { [ dup "250" head? ] [ log-response ] } - { [ dup "221" head? ] [ log-response ] } - { [ dup "bye" head? ] [ log-response ] } + { [ dup "220" head? ] [ smtp-response ] } + { [ dup "235" swap subseq? ] [ smtp-response ] } + { [ dup "250" head? ] [ smtp-response ] } + { [ dup "221" head? ] [ smtp-response ] } + { [ dup "bye" head? ] [ smtp-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "354" head? ] [ log-response ] } - { [ dup "50" head? ] [ log-response "syntax error" throw ] } - { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } - { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ dup "354" head? ] [ smtp-response ] } + { [ dup "50" head? ] [ smtp-response "syntax error" throw ] } + { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ smtp-response "fatal error" throw ] } { [ t ] [ "unknown error" throw ] } } cond ; @@ -80,7 +77,7 @@ SYMBOL: esmtp t esmtp set-global : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ - drop dup log-response + drop dup smtp-response ] [ swap check-response process-multiline ] if ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index cd0d574083..6dee51cbc0 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -7,23 +7,31 @@ IN: tools.annotations : reset ( word -- ) dup "unannotated-def" word-prop [ [ - dup "unannotated-def" word-prop define + dup dup "unannotated-def" word-prop define ] with-compilation-unit + f "unannotated-def" set-word-prop ] [ drop ] if ; : annotate ( word quot -- ) + over "unannotated-def" word-prop [ + "Cannot annotate a word twice" throw + ] when [ over dup word-def "unannotated-def" set-word-prop >r dup word-def r> call define ] with-compilation-unit ; inline +: word-inputs ( word -- seq ) + stack-effect [ + >r datastack r> effect-in length tail* + ] [ + datastack + ] if* ; + : entering ( str -- ) "/-- Entering: " write dup . - stack-effect [ - >r datastack r> effect-in length tail* stack. - ] [ - .s - ] if* "\\--" print flush ; + word-inputs stack. + "\\--" print flush ; : leaving ( str -- ) "/-- Leaving: " write dup . diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..48de69b025 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "windows." ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] } { [ ".test" ?tail ] [ t ] } + { [ "raptor" ?head ] [ t ] } { [ dup "tools.deploy.app" = ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 110b90f84a..552f5e0977 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting -html.elements ; +html.elements logging ; IN: webapps.file @@ -58,6 +58,8 @@ SYMBOL: page [ [ dup page set run-template-file ] with-scope ] try drop ; +\ run-page DEBUG add-input-logging + : include-page ( filename -- ) "doc-root" get swap path+ run-page ; @@ -69,6 +71,8 @@ SYMBOL: page dup mime-type dup "application/x-factor-server-page" = [ drop serve-fhtml ] [ serve-static ] if ; +\ serve-file NOTICE add-input-logging + : file. ( name dirp -- ) [ "/" append ] when dup       write ; @@ -104,15 +108,15 @@ SYMBOL: page ] if ; : serve-object ( filename -- ) - dup directory? [ serve-directory ] [ serve-file ] if ; + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop "404 not found" httpd-error + ] if ; : file-responder ( -- ) "doc-root" get [ - "argument" get serving-path dup exists? [ - serve-object - ] [ - drop "404 not found" httpd-error - ] if + "argument" get serve-object ] [ "404 doc-root not set" httpd-error ] if ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index b777780e11..a9fd443fe6 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.logging ; +xml.writer prettyprint logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,27 +75,19 @@ SYMBOL: cached-postings SYMBOL: last-update -: fetch-feed ( triple -- feed ) - second - "Fetching " over append log-message - dup download-feed feed-entries - "Done fetching " swap append log-message ; - : ( author entry -- entry' ) clone [ ": " swap entry-title 3append ] keep [ set-entry-title ] keep ; -: ?fetch-feed ( triple -- feed/f ) - [ - fetch-feed - ] [ - swap [ . error. ] to-log-stream f - ] recover ; +: fetch-feed ( url -- feed ) + download-feed feed-entries ; + +\ fetch-feed DEBUG add-error-logging : fetch-blogroll ( blogroll -- entries ) dup 0 - swap [ ?fetch-feed ] parallel-map + swap [ fetch-feed ] parallel-map [ [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) From 6187a1e5e14978eec4a87e8f2ab094b20a9a8e0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:55:31 -0600 Subject: [PATCH 235/317] Improved http.client, bootstrap.image.{download,upload} --- core/bootstrap/image/image.factor | 34 ++++++++++++------- extra/benchmark/bootstrap2/bootstrap2.factor | 4 +-- extra/bootstrap/image/download/authors.txt | 1 + .../bootstrap/image/download/download.factor | 25 ++++++++++++++ extra/bootstrap/image/download/summary.txt | 1 + extra/bootstrap/image/upload/authors.txt | 1 + extra/bootstrap/image/upload/summary.txt | 1 + extra/bootstrap/image/upload/upload.factor | 25 ++++++++++++++ extra/crypto/sha1/sha1.factor | 11 +++--- extra/http/client/client.factor | 27 +++++++-------- extra/io/server/server.factor | 3 +- extra/rss/rss.factor | 2 +- extra/tools/deploy/backend/backend.factor | 7 ++-- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 4 +-- 15 files changed, 102 insertions(+), 46 deletions(-) create mode 100644 extra/bootstrap/image/download/authors.txt create mode 100644 extra/bootstrap/image/download/download.factor create mode 100644 extra/bootstrap/image/download/summary.txt create mode 100644 extra/bootstrap/image/upload/authors.txt create mode 100644 extra/bootstrap/image/upload/summary.txt create mode 100644 extra/bootstrap/image/upload/upload.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 3dadee5193..7452e31cf8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private combinators.private combinators ; IN: bootstrap.image +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + +: boot-image-name ( arch -- string ) + "boot." swap ".image" 3append ; + +: my-boot-image-name ( -- string ) + my-arch boot-image-name ; + +: images ( -- seq ) + { + "x86.32" + "x86.64" + "linux-ppc" "macosx-ppc" + ! "arm" + } ; + le write ] curry each ] if ; -: image-name - "boot." architecture get ".image" 3append resource-path ; - : write-image ( image filename -- ) "Writing image to " write dup write "..." print flush [ (write-image) ] with-stream ; @@ -415,16 +429,10 @@ PRIVATE> begin-image "resource:/core/bootstrap/stage1.factor" run-file end-image - image get image-name write-image + image get + architecture get boot-image-name resource-path + write-image ] with-variable ; -: my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; - : make-images ( -- ) - { - "x86.32" - "x86.64" - "linux-ppc" "macosx-ppc" - ! "arm" - } [ make-image ] each ; + images [ make-image ] each ; diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index bde92a2260..54bc73f4a1 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -1,4 +1,4 @@ -USING: io.files io.launcher system tools.deploy.backend +USING: io.files io.launcher system bootstrap.image namespaces sequences kernel ; IN: benchmark.bootstrap2 @@ -6,7 +6,7 @@ IN: benchmark.bootstrap2 "." resource-path cd [ vm , - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , ] { } make run-process drop ; diff --git a/extra/bootstrap/image/download/authors.txt b/extra/bootstrap/image/download/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/download/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor new file mode 100644 index 0000000000..deed045221 --- /dev/null +++ b/extra/bootstrap/image/download/download.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.download +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io ; + +: url "http://factorcode.org/images/latest/" ; + +: download-checksums ( -- alist ) + url "checksums.txt" append http-get + string-lines [ " " split1 ] { } map>assoc ; + +: need-new-image? ( image -- ? ) + dup exists? + [ dup file>md5str swap download-checksums at = not ] + [ drop t ] if ; + +: download-image ( arch -- ) + boot-image-name dup need-new-image? [ + "Downloading " write dup write "..." print + url swap append download + ] [ + "Boot image up to date" print + drop + ] if ; diff --git a/extra/bootstrap/image/download/summary.txt b/extra/bootstrap/image/download/summary.txt new file mode 100644 index 0000000000..fc0ed97ff1 --- /dev/null +++ b/extra/bootstrap/image/download/summary.txt @@ -0,0 +1 @@ +Smart image downloader utility which first checks MD5 checksum diff --git a/extra/bootstrap/image/upload/authors.txt b/extra/bootstrap/image/upload/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/upload/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/upload/summary.txt b/extra/bootstrap/image/upload/summary.txt new file mode 100644 index 0000000000..85497270a2 --- /dev/null +++ b/extra/bootstrap/image/upload/summary.txt @@ -0,0 +1 @@ +Image upload utility diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor new file mode 100644 index 0000000000..a9f5d1dcd4 --- /dev/null +++ b/extra/bootstrap/image/upload/upload.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.upload +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io namespaces io.launcher math ; + +: destination "slava@factorcode.org:www/images/latest/" ; + +: boot-image-names images [ boot-image-name ] map ; + +: compute-checksums ( -- ) + "checksums.txt" [ + boot-image-names [ dup write bl file>md5str print ] each + ] with-file-out ; + +: upload-images ( -- ) + [ + "scp" , boot-image-names % "checksums.txt" , destination , + ] { } make run-process + wait-for-process zero? [ "Upload failed" throw ] unless ; + +: new-images ( -- ) + make-images compute-checksums upload-images ; + +MAIN: new-images diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 94a51288bb..f6dfbcd031 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -48,14 +48,13 @@ SYMBOL: K ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59) ! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79) : sha1-f ( B C D t -- f_tbcd ) - #! Maybe use dispatch 20 /i { - { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] } - { [ dup 1 = ] [ drop bitxor bitxor ] } - { [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } - { [ dup 3 = ] [ drop bitxor bitxor ] } - } cond ; + { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] } + { 1 [ bitxor bitxor ] } + { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } + { 3 [ bitxor bitxor ] } + } case ; : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8e6d8257a4..109bf17c40 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -47,32 +47,31 @@ DEFER: http-get-stream dispose "location" swap peek-at nip http-get-stream ] when ; +: default-timeout 60 1000 * over set-timeout ; + : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep + default-timeout ] [ ] [ dispose ] cleanup do-redirect ; -: http-get ( url -- code headers string ) - #! Opens a stream for reading from an HTTP URL. - [ - http-get-stream [ stdio get contents ] with-stream - ] with-scope ; +: success? ( code -- ? ) 200 = ; + +: check-response ( code headers stream -- stream ) + nip swap success? + [ dispose "HTTP download failed" throw ] unless ; + +: http-get ( url -- string ) + http-get-stream check-response contents ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; -: default-timeout 60 1000 * over set-timeout ; - -: success? ( code -- ? ) 200 = ; - : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream nip default-timeout swap success? [ - r> stream-copy - ] [ - r> drop dispose "HTTP download failed" throw - ] if ; + >r http-get-stream check-response + r> stream-copy ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 829da27f6e..a23984c207 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -19,7 +19,8 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry concurrency:spawn + >r accept r> [ with-client ] 2curry + concurrency:spawn drop ] 2keep accept-loop ; inline : server-loop ( server quot -- ) diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index be2f648189..0591c60014 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -78,7 +78,7 @@ C: entry : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get-stream rot 200 = [ + http-get-stream rot success? [ nip read-feed ] [ 2drop "Error retrieving newsfeed file" throw diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 95d19712c0..c295f6369d 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -24,12 +24,9 @@ IN: tools.deploy.backend dup duplex-stream-out dispose copy-lines ; -: boot-image-name ( -- string ) - "boot." my-arch ".image" 3append ; - : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. - boot-image-name resource-path exists? + my-boot-image-name resource-path exists? [ my-arch make-image ] unless ; : ?, [ , ] [ drop ] if ; @@ -49,7 +46,7 @@ IN: tools.deploy.backend : staging-command-line ( config -- flags ) [ - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=" over staging-image-name append , diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 19dab4ed1b..55609c72f9 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ; + "http://" "Host" header-param rot 3append http-get compile "();" write flush ; \ compile-url { { "url" v-required } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 2c982306cd..1725c10a44 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -26,6 +26,4 @@ C: result ] "" make ; : search-yahoo ( search num -- seq ) - query http-get 2nip - [ "Search failed" throw ] unless* - string>xml parse-yahoo ; + query http-get string>xml parse-yahoo ; From b08409884e72dc4879942a23c56c10167cf5695f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:03:01 -0600 Subject: [PATCH 236/317] Add try-everything for Ed --- core/vocabs/loader/loader-docs.factor | 5 ---- core/vocabs/loader/loader.factor | 34 +++++++++------------------ extra/tools/browser/browser.factor | 14 ++++++++--- extra/tools/test/test-docs.factor | 2 +- extra/tools/test/test.factor | 6 ++--- 5 files changed, 26 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index f8626f3370..379b300eaa 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,11 +124,6 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: require-all-error -{ $values { "vocabs" "a sequence of vocabularies" } } -{ $description "Throws a " { $link require-all-error } "." } -{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; - HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 352ef9fe02..4fcb74df66 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -160,37 +160,25 @@ SYMBOL: load-help? drop ; ! third "Traceback" swap write-object ; -TUPLE: require-all-error vocabs ; +: load-failures. ( failures -- ) + [ load-error. nl ] each ; -: require-all-error ( vocabs -- ) - [ vocab-name ] map - \ require-all-error construct-boa throw ; - -M: require-all-error summary - drop "The require-all operation failed" ; - -: require-all ( vocabs -- ) - dup length 1 = [ first require ] [ +: require-all ( vocabs -- failures ) + [ [ [ - [ - [ require ] - [ error-continuation get 3array , ] - recover - ] each - ] { } make - dup empty? [ drop ] [ - dup [ load-error. nl ] each - keys require-all-error - ] if - ] with-compiler-errors - ] if ; + [ require ] + [ error-continuation get 3array , ] + recover + ] each + ] { } make + ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all ; + append prune require-all drop ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 48de69b025..87b4ba9939 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -132,11 +132,17 @@ MEMO: all-vocabs-seq ( -- seq ) { [ t ] [ f ] } } cond nip ; -: load-everything ( -- ) +: filter-dangerous ( seq -- seq' ) + [ vocab-name dangerous? not ] subset ; + +: try-everything ( -- failures ) all-vocabs-seq - [ vocab-name dangerous? not ] subset + filter-dangerous require-all ; +: load-everything ( -- ) + try-everything drop ; + : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs @@ -155,7 +161,9 @@ MEMO: all-vocabs-seq ( -- seq ) : load-children ( prefix -- ) all-child-vocabs values concat - require-all ; + filter-dangerous + require-all + drop ; : vocab-status-string ( vocab -- string ) { diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index c027073398..b756f9279e 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -29,7 +29,7 @@ $nl { $subsection run-tests } { $subsection run-all-tests } "The following word prints failures:" -{ $subsection failures. } ; +{ $subsection test-failures. } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0b1a495e90..192a248161 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -80,7 +80,7 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( assoc -- ) +: test-failures. ( assoc -- ) dup [ nl dup empty? [ @@ -104,10 +104,10 @@ M: expected-error summary ] if ; : test ( prefix -- ) - run-tests failures. ; + run-tests test-failures. ; : run-all-tests ( prefix -- failures ) "" run-tests ; : test-all ( -- ) - run-all-tests failures. ; + run-all-tests test-failures. ; From 6bbbd3f9043a4162ce70e11acf3a3afc88bda7c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:06:53 -0600 Subject: [PATCH 237/317] Forgot to call load-failures. --- core/vocabs/loader/loader.factor | 2 +- extra/tools/browser/browser.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 4fcb74df66..a1276341b3 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -178,7 +178,7 @@ SYMBOL: load-help? 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all drop ; + append prune require-all load-failures. ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 87b4ba9939..ae1901ff66 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -163,7 +163,7 @@ MEMO: all-vocabs-seq ( -- seq ) all-child-vocabs values concat filter-dangerous require-all - drop ; + load-failures. ; : vocab-status-string ( vocab -- string ) { From a2e6c372136f35a1d62a8add94293efbd8b52649 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 18:30:20 -0600 Subject: [PATCH 238/317] simplify builder.test --- extra/builder/builder.factor | 9 +++++-- extra/builder/test/test.factor | 48 ++++++++++++++++++++++------------ 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5e992ccc81..caa381ba5d 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,8 +1,8 @@ -USING: kernel io io.files io.launcher hashtables tools.deploy.backend +USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators ; + combinators bootstrap.image ; IN: builder @@ -82,6 +82,11 @@ VAR: stamp ] if + { + "git" "pull" "--no-summary" + "http://dharmatech.onigirihouse.com/factor.git" "master" + } run-process process-status + "/builds/" stamp> append make-directory "/builds/" stamp> append cd diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index fb9c62e2aa..2a867b1fbc 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,28 +7,42 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test +! : do-load ( -- ) +! [ +! [ load-everything ] +! [ require-all-error-vocabs "../load-everything-log" log-object ] +! recover +! ] +! "../load-everything-time" log-runtime ; + : do-load ( -- ) - [ - [ load-everything ] - [ require-all-error-vocabs "../load-everything-log" log-object ] - recover - ] - "../load-everything-time" log-runtime ; + [ try-everything ] "../load-everything-time" log-runtime + dup empty? + [ drop ] + [ "../load-everything-log" log-object ] + if ; + +! : do-tests ( -- ) +! "" child-vocabs +! [ vocab-source-loaded? ] subset +! [ vocab-tests-path ] map +! [ dup [ ?resource-path exists? ] when ] subset +! [ dup run-test ] { } map>assoc +! [ second empty? not ] subset +! dup empty? +! [ drop ] +! [ +! "../failing-tests" +! [ [ nl failures. ] assoc-each ] +! with-stream +! ] +! if ; : do-tests ( -- ) - "" child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - [ dup run-test ] { } map>assoc - [ second empty? not ] subset + run-all-tests keys dup empty? [ drop ] - [ - "../failing-tests" - [ [ nl failures. ] assoc-each ] - with-stream - ] + [ "../failing-tests" log-object ] if ; : do-all ( -- ) do-load do-tests ; From 4dfc151c89c04828d0beabf3a701deeaad48146d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 Feb 2008 19:48:00 -0500 Subject: [PATCH 239/317] Solution to Project Euler problem 79 --- extra/project-euler/079/079.factor | 65 ++++++++++++++++++++++++ extra/project-euler/079/keylog.txt | 50 ++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +- 3 files changed, 117 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/079/079.factor create mode 100644 extra/project-euler/079/keylog.txt diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor new file mode 100644 index 0000000000..d28484c881 --- /dev/null +++ b/extra/project-euler/079/079.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +IN: project-euler.079 + +! http://projecteuler.net/index.php?section=problems&id=79 + +! DESCRIPTION +! ----------- + +! A common security method used for online banking is to ask the user for three +! random characters from a passcode. For example, if the passcode was 531278, +! they may asked for the 2nd, 3rd, and 5th characters; the expected reply would +! be: 317. + +! The text file, keylog.txt, contains fifty successful login attempts. + +! Given that the three characters are always asked for in order, analyse the +! file so as to determine the shortest possible secret passcode of unknown +! length. + + +! SOLUTION +! -------- + +edges ( seq -- seq ) + [ + [ string>digits [ 2 head , ] keep 2 tail* , ] each + ] { } make ; + +: find-source ( seq -- elt ) + dup values swap keys [ prune ] 2apply seq-diff + dup empty? [ "Topological sort failed" throw ] [ first ] if ; + +: remove-source ( seq elt -- seq ) + [ swap member? not ] curry subset ; + +: (topological-sort) ( seq -- ) + dup length 1 > [ + dup find-source dup , remove-source (topological-sort) + ] [ + dup empty? [ drop ] [ first [ , ] each ] if + ] if ; + +PRIVATE> + +: topological-sort ( seq -- seq ) + [ [ (topological-sort) ] { } make ] keep + concat prune dupd seq-diff append ; + +: euler079 ( -- answer ) + source-079 >edges topological-sort 10 swap digits>integer ; + +! [ euler079 ] 100 ave-time +! 2 ms run / 0 ms GC ave time - 100 trials + +! TODO: prune and seq-diff are relatively slow; topological sort could be +! cleaned up and generalized much better, but it works for this problem + +MAIN: euler079 diff --git a/extra/project-euler/079/keylog.txt b/extra/project-euler/079/keylog.txt new file mode 100644 index 0000000000..b6f9903128 --- /dev/null +++ b/extra/project-euler/079/keylog.txt @@ -0,0 +1,50 @@ +319 +680 +180 +690 +129 +620 +762 +689 +762 +318 +368 +710 +720 +710 +629 +168 +160 +689 +716 +731 +736 +729 +316 +729 +729 +710 +769 +290 +719 +680 +318 +389 +162 +289 +162 +718 +729 +319 +790 +680 +890 +362 +319 +760 +316 +729 +380 +319 +728 +716 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 36a9069d77..c3db60c481 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -14,8 +14,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.048 project-euler.052 project-euler.067 project-euler.075 - project-euler.097 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.079 project-euler.097 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Thu, 7 Feb 2008 20:25:03 -0500 Subject: [PATCH 240/317] Fix PE solutions using old math.parser --- extra/project-euler/041/041.factor | 2 +- extra/project-euler/043/043.factor | 6 +++--- extra/project-euler/079/079.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor index 60017f39a1..14084cc01d 100644 --- a/extra/project-euler/041/041.factor +++ b/extra/project-euler/041/041.factor @@ -32,7 +32,7 @@ IN: project-euler.041 : euler041 ( -- answer ) { 7 6 5 4 3 2 1 } all-permutations - [ 10 swap digits>integer ] map [ prime? ] find nip ; + [ 10 digits>integer ] map [ prime? ] find nip ; ! [ euler041 ] 100 ave-time ! 107 ms run / 7 ms GC ave time - 100 trials diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index abe455e273..54d75c6980 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -36,7 +36,7 @@ IN: project-euler.043 integer swap mod zero? ; + [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ; : interesting? ( seq -- ? ) { @@ -53,7 +53,7 @@ PRIVATE> : euler043 ( -- answer ) 1234567890 number>digits all-permutations - [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + [ interesting? ] subset [ 10 digits>integer ] map sum ; ! [ euler043 ] time ! 125196 ms run / 19548 ms GC time @@ -89,7 +89,7 @@ PRIVATE> PRIVATE> : euler043a ( -- answer ) - interesting-pandigitals [ 10 swap digits>integer ] sigma ; + interesting-pandigitals [ 10 digits>integer ] sigma ; ! [ euler043a ] 100 ave-time ! 19 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index d28484c881..f068db77ec 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -54,7 +54,7 @@ PRIVATE> concat prune dupd seq-diff append ; : euler079 ( -- answer ) - source-079 >edges topological-sort 10 swap digits>integer ; + source-079 >edges topological-sort 10 digits>integer ; ! [ euler079 ] 100 ave-time ! 2 ms run / 0 ms GC ave time - 100 trials From 1c3efa89d214ad2b4f9f6b468de2519c6bdbae2c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 19:50:26 -0600 Subject: [PATCH 241/317] builder improvements (download-image, simpler do-all) --- extra/builder/builder.factor | 12 ++++++------ extra/builder/test/test.factor | 24 ------------------------ 2 files changed, 6 insertions(+), 30 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index caa381ba5d..9af79efb29 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,7 +2,7 @@ USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators bootstrap.image ; + combinators bootstrap.image bootstrap.image.download ; IN: builder @@ -70,7 +70,6 @@ VAR: stamp "pull" "--no-summary" "git://factorcode.org/git/factor.git" - ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status @@ -85,7 +84,7 @@ VAR: stamp { "git" "pull" "--no-summary" "http://dharmatech.onigirihouse.com/factor.git" "master" - } run-process process-status + } run-process drop "/builds/" stamp> append make-directory "/builds/" stamp> append cd @@ -112,14 +111,15 @@ VAR: stamp "builder: vm compile" throw ] if - [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ my-arch download-image ] + [ ] [ "builder: image download" email-string ] - recover + cleanup `{ { +arguments+ { ,[ factor-binary ] - ,[ "-i=" boot-image-name append ] + ,[ "-i=" my-boot-image-name append ] "-no-user-init" } } { +stdout+ "../boot-log" } diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 2a867b1fbc..c887c668e6 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,14 +7,6 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test -! : do-load ( -- ) -! [ -! [ load-everything ] -! [ require-all-error-vocabs "../load-everything-log" log-object ] -! recover -! ] -! "../load-everything-time" log-runtime ; - : do-load ( -- ) [ try-everything ] "../load-everything-time" log-runtime dup empty? @@ -22,22 +14,6 @@ IN: builder.test [ "../load-everything-log" log-object ] if ; -! : do-tests ( -- ) -! "" child-vocabs -! [ vocab-source-loaded? ] subset -! [ vocab-tests-path ] map -! [ dup [ ?resource-path exists? ] when ] subset -! [ dup run-test ] { } map>assoc -! [ second empty? not ] subset -! dup empty? -! [ drop ] -! [ -! "../failing-tests" -! [ [ nl failures. ] assoc-each ] -! with-stream -! ] -! if ; - : do-tests ( -- ) run-all-tests keys dup empty? From 48b96a9e5bf8734e7b2fb484f533e668fc6ae6ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:51:37 -0600 Subject: [PATCH 242/317] Documentation updates, tags updates --- extra/asn1/tags.txt | 1 + extra/db/authors.txt | 1 + extra/db/summary.txt | 1 + extra/db/tags.txt | 1 + extra/furnace/tags.txt | 1 + extra/logging/analysis/analysis-docs.factor | 31 +++++ extra/logging/analysis/analysis.factor | 3 +- extra/logging/analysis/tags.txt | 1 + extra/logging/insomniac/insomniac-docs.factor | 44 ++++++ extra/logging/insomniac/insomniac.factor | 23 ++-- extra/logging/insomniac/tags.txt | 1 + extra/logging/logging-docs.factor | 130 ++++++++++++++++++ extra/logging/logging.factor | 26 ++-- extra/logging/parser/parser-docs.factor | 21 +++ extra/logging/parser/tags.txt | 1 + extra/logging/server/server-docs.factor | 4 + extra/logging/server/server.factor | 12 +- extra/logging/server/tags.txt | 1 + extra/logging/summary.txt | 2 +- extra/logging/tags.txt | 1 + 20 files changed, 277 insertions(+), 29 deletions(-) create mode 100644 extra/asn1/tags.txt create mode 100644 extra/db/authors.txt create mode 100644 extra/db/summary.txt create mode 100644 extra/db/tags.txt create mode 100644 extra/furnace/tags.txt create mode 100644 extra/logging/analysis/analysis-docs.factor create mode 100644 extra/logging/analysis/tags.txt create mode 100644 extra/logging/insomniac/insomniac-docs.factor create mode 100644 extra/logging/insomniac/tags.txt create mode 100644 extra/logging/logging-docs.factor create mode 100644 extra/logging/parser/parser-docs.factor create mode 100644 extra/logging/parser/tags.txt create mode 100644 extra/logging/server/server-docs.factor create mode 100644 extra/logging/server/tags.txt create mode 100644 extra/logging/tags.txt diff --git a/extra/asn1/tags.txt b/extra/asn1/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/asn1/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/db/authors.txt b/extra/db/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/db/summary.txt b/extra/db/summary.txt new file mode 100644 index 0000000000..daebf38da6 --- /dev/null +++ b/extra/db/summary.txt @@ -0,0 +1 @@ +Relational database abstraction layer diff --git a/extra/db/tags.txt b/extra/db/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/db/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/furnace/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor new file mode 100644 index 0000000000..2919f2bcd4 --- /dev/null +++ b/extra/logging/analysis/analysis-docs.factor @@ -0,0 +1,31 @@ +USING: help.markup help.syntax assocs logging math ; +IN: logging.analysis + +HELP: analyze-entries +{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Analyzes log entries:" + { $list + { "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." } + { "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." } + { "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." } + } +} ; + +HELP: analysis. +{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; + +HELP: analyze-log +{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +ARTICLE: "logging.analysis" "Log analysis" +"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports." +$nl +"Print log file summary:" +{ $subsection analyze-log } +"Factors:" +{ $subsection analyze-entries } +{ $subsection analysis. } ; + +ABOUT: "logging.analysis" diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index df53a8e70b..b530c09b22 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -11,6 +11,7 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup second ERROR eq? [ dup errors get push ] when + dup second CRITICAL eq? [ dup errors get push ] when 1 over third word-histogram get at+ dup third word-names get member? [ 1 over 1 tail message-histogram get at+ @@ -65,5 +66,5 @@ SYMBOL: message-histogram "==== ERRORS:" print nl errors. ; -: log-analysis ( lines word-names -- ) +: analyze-log ( lines word-names -- ) >r parse-log r> analyze-entries analysis. ; diff --git a/extra/logging/analysis/tags.txt b/extra/logging/analysis/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/analysis/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor new file mode 100644 index 0000000000..64ac3b4ff6 --- /dev/null +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax assocs strings logging +logging.analysis smtp ; +IN: logging.insomniac + +HELP: insomniac-smtp-host +{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; + +HELP: insomniac-smtp-port +{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; + +HELP: insomniac-sender +{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: insomniac-recipients +{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: ?analyze-log +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } +{ $see-also analyze-log } ; + +HELP: email-log-report +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } +{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +HELP: schedule-insomniac +{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ; + +ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." +$nl +"Required configuration parameters:" +{ $subsection insomniac-sender } +{ $subsection insomniac-recipients } +"Optional configuration parameters:" +{ $subsection insomniac-smtp-host } +{ $subsection insomniac-smtp-port } +"E-mailing a one-off report:" +{ $subsection email-log-report } +"E-mailing reports and rotating logs on a daily basis:" +{ $subsection schedule-insomniac } ; + +ABOUT: "logging.insomniac" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index b065dec9d3..d79eca3495 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron ; +kernel io.files io.streams.string namespaces raptor.cron assocs ; IN: logging.insomniac -SYMBOL: insomniac-config - SYMBOL: insomniac-smtp-host SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients -: ?log-analysis ( service word-names -- string/f ) +: ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ log-analysis ] string-out + file-lines r> [ analyze-log ] string-out ] [ r> 2drop f ] if ; @@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients : (email-log-report) ( service word-names -- ) [ over >r - ?log-analysis dup [ + ?analyze-log dup [ r> email-subject insomniac-recipients get insomniac-sender get @@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients ] [ r> 2drop ] if ] with-insomniac-smtp ; +\ (email-log-report) NOTICE add-error-logging + : email-log-report ( service word-names -- ) - (email-log-report) ; + "logging.insomniac" [ (email-log-report) ] with-logging ; -\ email-log-report NOTICE add-error-logging - -: schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot - [ email-log-report ] 2curry schedule ; +: schedule-insomniac ( alist -- ) + { 25 } { 6 } f f f -rot [ + [ email-log-report ] assoc-each rotate-logs + ] 2curry schedule ; diff --git a/extra/logging/insomniac/tags.txt b/extra/logging/insomniac/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/insomniac/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor new file mode 100644 index 0000000000..3b112e0166 --- /dev/null +++ b/extra/logging/logging-docs.factor @@ -0,0 +1,130 @@ +IN: logging +USING: help.markup help.syntax assocs math calendar +logging.server strings words quotations ; + +HELP: DEBUG +{ $description "Log level for debug messages." } ; + +HELP: NOTICE +{ $description "Log level for ordinary messages." } ; + +HELP: ERROR +{ $description "Log level for error messages." } ; + +HELP: CRITICAL +{ $description "Log level for critical errors which require immediate attention." } ; + +ARTICLE: "logging.levels" "Log levels" +"Several log levels are supported, from lowest to highest:" +{ $subsection DEBUG } +{ $subsection NOTICE } +{ $subsection ERROR } +{ $subsection CRITICAL } ; + +ARTICLE: "logging.files" "Log files" +"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:" +{ $subsection with-logging } +"Log messages are written to " { $snippet "log-root/service/1.log" } ", where" +{ $list + { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" } + { { $snippet "service" } " is the service name" } +} +"You can get the log path for a service:" +{ $subsection log-path } +{ $subsection log# } +"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ; + +HELP: log-message +{ $values { "msg" string } { "word" word } { "level" "a log level" } } +{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; + +HELP: add-logging +{ $values { "word" word } } +{ $description "Causes the word to log a message every time it is called." } ; + +HELP: add-input-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-output-logging +{ $values { "word" word } } +{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-error-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values and any errors it throws." +$nl +"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." +$nl +"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ; + +HELP: log-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Logs an error." } ; + +HELP: log-critical +{ $values { "critical" "an critical" } { "word" word } } +{ $description "Logs a critical error." } ; + +HELP: LOG: +{ $syntax "LOG: name level" } +{ $values { "name" "a new word name" } { "level" "a log level" } } +{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ; + +ARTICLE: "logging.messages" "Logging messages" +"Logging messages explicitly:" +{ $subsection log-message } +{ $subsection log-error } +{ $subsection log-critical } +"A utility for defining words which just log and do nothing else:" +{ $subsection POSTPONE: LOG: } +"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:" +{ $subsection add-input-logging } +{ $subsection add-output-logging } +{ $subsection add-error-logging } ; + +HELP: rotate-logs +{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ; + +HELP: close-logs +{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; + +HELP: with-logging +{ $values { "service" "a log service name" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; + +ARTICLE: "logging.rotation" "Log rotation" +"Log files should be rotated periodically to prevent unbounded growth." +{ $subsection rotate-logs } +{ $subsection close-logs } +"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; + +ARTICLE: "logging.server" "Log implementation" +"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." +$nl +"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (log-message) } +"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (rotate-logs) } +"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (close-logs) } ; + +ARTICLE: "logging" "Logging framework" +"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications." +{ $subsection "logging.files" } +{ $subsection "logging.levels" } +{ $subsection "logging.messages" } +{ $subsection "logging.rotation" } +{ $subsection "logging.parser" } +{ $subsection "logging.analysis" } +{ $subsection "logging.insomniac" } +{ $subsection "logging.server" } ; + +ABOUT: "logging" + +! A workaround for circular dependency prohibition +USING: threads vocabs.loader ; +[ + yield + "logging.insomniac" require +] in-thread diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 71ea247567..d4f0bd1fbf 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -39,8 +39,8 @@ SYMBOL: log-service : rotate-logs ( -- ) { } "rotate-logs" send-to-log-server ; -: close-log-files ( -- ) - { } "close-log-files" send-to-log-server ; +: close-logs ( -- ) + { } "close-logs" send-to-log-server ; : with-logging ( service quot -- ) log-service swap with-variable ; inline @@ -56,7 +56,7 @@ SYMBOL: log-service [ dup first string? ] } && nip ; -: inputs>message ( obj -- inputs>message ) +: stack>message ( obj -- inputs>message ) dup one-string? [ first ] [ H{ { string-limit f } @@ -77,9 +77,9 @@ PRIVATE> : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; -: log-inputs ( n word level -- ) +: log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray inputs>message + >r >r [ ndup ] keep narray stack>message r> r> log-message ] [ 3drop @@ -88,11 +88,19 @@ PRIVATE> : input# stack-effect effect-in length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-inputs ] 3curry swap compose ; + over input# -rot [ log-stack ] 3curry swap compose ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; +: output# stack-effect effect-out length ; + +: output-logging-quot ( quot word level -- quot' ) + over output# -rot [ log-stack ] 3curry compose ; + +: add-output-logging ( word level -- ) + [ output-logging-quot ] (define-logging) ; + : (log-error) ( object word level -- ) log-service get [ >r >r [ print-error ] string-out r> r> log-message @@ -100,9 +108,9 @@ PRIVATE> 2drop rethrow ] if ; -: log-error ( object word -- ) ERROR (log-error) ; +: log-error ( error word -- ) ERROR (log-error) ; -: log-critical ( object word -- ) CRITICAL (log-error) ; +: log-critical ( error word -- ) CRITICAL (log-error) ; : error-logging-quot ( quot word -- quot' ) dup stack-effect effect-in length @@ -118,5 +126,5 @@ PRIVATE> CREATE dup reset-generic dup scan-word - [ >r >r 1array inputs>message r> r> log-message ] 2curry + [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor new file mode 100644 index 0000000000..ee995749be --- /dev/null +++ b/extra/logging/parser/parser-docs.factor @@ -0,0 +1,21 @@ +IN: logging.parser +USING: help.markup help.syntax assocs logging math calendar ; + +HELP: parse-log +{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } } +{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" + { $list + { { $snippet "timestamp" } " is a " { $link timestamp } } + { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "word-name" } " is a string" } + { { $snippet "message" } " is a string" } + } +} ; + +ARTICLE: "logging.parser" "Log file parser" +"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs." +$nl +"There is only one primary entry point:" +{ $subsection parse-log } ; + +ABOUT: "logging.parser" diff --git a/extra/logging/parser/tags.txt b/extra/logging/parser/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/parser/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/server/server-docs.factor b/extra/logging/server/server-docs.factor new file mode 100644 index 0000000000..08b99dd1cc --- /dev/null +++ b/extra/logging/server/server-docs.factor @@ -0,0 +1,4 @@ +IN: logging.server +USING: help.syntax ; + +ABOUT: "logging.server" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..0300208e7e 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -50,11 +50,11 @@ SYMBOL: log-files : try-dispose ( stream -- ) [ dispose ] curry [ error. ] recover ; -: close-log-file ( service -- ) +: close-log ( service -- ) log-files get delete-at* [ try-dispose ] [ drop ] if ; -: (close-log-files) ( -- ) +: (close-logs) ( -- ) log-files get dup values [ try-dispose ] each clear-assoc ; @@ -73,13 +73,13 @@ SYMBOL: log-files [ 1- log# ] 2keep log# ?rename-file ; : rotate-log ( service -- ) - dup close-log-file + dup close-log log-path dup delete-oldest keep-logs 1 [a,b] [ advance-log ] with each ; : (rotate-logs) ( -- ) - (close-log-files) + (close-logs) log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop @@ -87,9 +87,9 @@ SYMBOL: log-files receive unclip { { "log-message" [ (log-message) ] } { "rotate-logs" [ drop (rotate-logs) ] } - { "close-log-files" [ drop (close-log-files) ] } + { "close-logs" [ drop (close-logs) ] } } case - ] [ error. (close-log-files) ] recover + ] [ error. (close-logs) ] recover log-server-loop ; : log-server ( -- ) diff --git a/extra/logging/server/tags.txt b/extra/logging/server/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/server/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt index dbf29c2112..42246bbd3e 100755 --- a/extra/logging/summary.txt +++ b/extra/logging/summary.txt @@ -1 +1 @@ -AOP Logging framework with support for log rotation and machine-readable logs +Logging framework with support for log rotation and machine-readable logs diff --git a/extra/logging/tags.txt b/extra/logging/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/tags.txt @@ -0,0 +1 @@ +enterprise From fb67a7621be9e22a85f76a79d8c0ef10d206b06b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:52:40 -0600 Subject: [PATCH 243/317] Cleanup --- extra/logging/server/server.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..601237ba81 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -25,9 +25,11 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; +: multiline-header 20 CHAR: - ; foldable + : (write-message) ( msg word-name level multi? -- ) [ - "[" write 20 CHAR: - write "] " write + "[" write multiline-header write "] " write ] [ "[" write now (timestamp>rfc3339) "] " write ] if From 7cdcac3fc97f33d23344985c376bc043ad3b22e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:09 -0600 Subject: [PATCH 244/317] Add another unit test --- core/compiler/test/optimizer.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 7ee4ebfd1c..987aace00a 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -300,3 +300,4 @@ TUPLE: silly-tuple a b ; [ f ] [ \ sequence \ hashcode* should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From f67ab9a6897ea24982c8049e821740864b6e1f77 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:23 -0600 Subject: [PATCH 245/317] Multi-methods work in progress --- .../multi-methods/multi-methods-tests.factor | 12 ++ extra/multi-methods/multi-methods.factor | 117 ++++++++++++------ 2 files changed, 88 insertions(+), 41 deletions(-) diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index a0769dffda..1c68cbe540 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ; [ fixnum ] [ 3 hook-test ] unit-test 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 827d64b95f..9a74cc65e8 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,12 +3,12 @@ USING: kernel math sequences vectors classes combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units ; +debugger io compiler.units kernel.private effects ; IN: multi-methods -TUPLE: method loc def ; +GENERIC: generic-prologue ( combination -- quot ) -: { set-method-def } \ method construct ; +GENERIC: method-prologue ( combination -- quot ) : maximal-element ( seq quot -- n elt ) dupd [ @@ -25,6 +25,7 @@ TUPLE: method loc def ; [ { { [ 2dup eq? ] [ 0 ] } + { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] } { [ 2dup class< ] [ -1 ] } { [ 2dup swap class< ] [ 1 ] } { [ t ] [ 0 ] } @@ -54,8 +55,37 @@ TUPLE: method loc def ; : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: method-defs ( methods -- methods' ) - [ method-def ] assoc-map ; +: make-method-def ( quot classes generic -- quot ) + [ + swap [ declare ] curry % + "multi-combination" word-prop method-prologue % + % + ] [ ] make ; + +TUPLE: method word def classes generic loc ; + +PREDICATE: word method-body "multi-method" word-prop >boolean ; + +M: method-body stack-effect + "multi-method" word-prop method-generic stack-effect ; + +: method-word-name ( classes generic -- string ) + [ + word-name % + "-(" % [ "," % ] [ word-name % ] interleave ")" % + ] "" make ; + +: ( quot classes generic -- word ) + #! We xref here because the "multi-method" word-prop isn't + #! set yet so crossref? yields f. + [ make-method-def ] 2keep + method-word-name f + dup rot define + dup xref ; + +: ( quot classes generic -- method ) + [ ] 3keep f \ method construct-boa + dup method-word over "multi-method" set-word-prop ; TUPLE: no-method arguments generic ; @@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ; ] if ; : multi-dispatch-quot ( methods generic -- quot ) - >r - [ [ >r multi-predicate r> ] assoc-map ] keep argument-count + >r [ + [ + >r multi-predicate r> method-word 1quotation + ] assoc-map + ] keep argument-count r> [ no-method ] 2curry swap reverse alist>quot ; @@ -98,36 +131,36 @@ M: no-method error. methods congruify-methods sorted-methods keys [ niceify-method ] map stack. ; -GENERIC: perform-combination ( word combination -- quot ) - TUPLE: standard-combination ; -: standard-combination ( methods generic -- quot ) - >r congruify-methods sorted-methods r> multi-dispatch-quot ; +M: standard-combination method-prologue drop [ ] ; -M: standard-combination perform-combination - drop [ methods method-defs ] keep standard-combination ; +M: standard-combination generic-prologue drop [ ] ; + +: make-generic ( generic -- quot ) + dup "multi-combination" word-prop generic-prologue swap + [ methods congruify-methods sorted-methods ] keep + multi-dispatch-quot append ; TUPLE: hook-combination var ; -M: hook-combination perform-combination - hook-combination-var [ get ] curry swap methods - [ method-defs [ [ drop ] swap append ] assoc-map ] keep - standard-combination append ; +M: hook-combination method-prologue + drop [ drop ] ; -: make-generic ( word -- ) - dup dup "multi-combination" word-prop perform-combination - define ; +M: hook-combination generic-prologue + hook-combination-var [ get ] curry ; -: init-methods ( word -- ) - dup "multi-methods" word-prop - H{ } assoc-like - "multi-methods" set-word-prop ; +: update-generic ( word -- ) + dup make-generic define ; : define-generic ( word combination -- ) - dupd "multi-combination" set-word-prop - dup init-methods - make-generic ; + over "multi-combination" word-prop over = [ + 2drop + ] [ + dupd "multi-combination" set-word-prop + dup H{ } clone "multi-methods" set-word-prop + update-generic + ] if ; : define-standard-generic ( word -- ) T{ standard-combination } define-generic ; @@ -146,29 +179,31 @@ M: hook-combination perform-combination : with-methods ( word quot -- ) over >r >r "multi-methods" word-prop - r> call r> make-generic ; inline + r> call r> update-generic ; inline -: add-method ( method classes word -- ) +: define-method ( quot classes generic -- ) + >r [ bootstrap-word ] map r> + [ ] 2keep [ set-at ] with-methods ; -: forget-method ( classes word -- ) +: forget-method ( classes generic -- ) [ delete-at ] with-methods ; -: parse-method ( -- method classes word method-spec ) - parse-definition 2 cut - over >r - >r first2 swap r> -rot - r> first2 swap add* >array ; +: method>spec ( method -- spec ) + dup method-classes swap method-generic add* ; + +: parse-method ( -- quot classes generic ) + parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method >r add-method r> r> + >r parse-method [ define-method ] 2keep add* r> remember-definition ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot add-method ; parsing + scan-word 1array scan-word parse-definition + -rot define-method ; parsing ! Definition protocol. We qualify core generics here USE: qualified @@ -202,7 +237,7 @@ PREDICATE: array method-spec unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method method-loc [ ] [ second where ] ?if ; + dup unclip method [ method-loc ] [ second where ] ?if ; syntax:M: method-spec set-where unclip method set-method-loc ; @@ -211,11 +246,11 @@ syntax:M: method-spec definer drop \ METHOD: \ ; ; syntax:M: method-spec definition - unclip method method-def ; + unclip method dup [ method-def ] when ; syntax:M: method-spec synopsis* dup definer. unclip pprint* pprint* ; syntax:M: method-spec forget* - unclip [ delete-at ] with-methods ; + unclip forget-method ; From 492e569b627ed7826b6fd9b4a946fa7c15e379d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:52 -0600 Subject: [PATCH 246/317] 'about' now requires first --- extra/help/help.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/help/help.factor b/extra/help/help.factor index aefbf2aba2..77b9f699aa 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel namespaces parser prettyprint sequences -words assocs definitions generic quotations effects -slots continuations tuples debugger combinators -vocabs help.stylesheet help.topics help.crossref help.markup -sorting classes ; +words assocs definitions generic quotations effects slots +continuations tuples debugger combinators vocabs help.stylesheet +help.topics help.crossref help.markup sorting classes +vocabs.loader ; IN: help GENERIC: word-help* ( word -- content ) @@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup require dup vocab [ ] [ "No such vocabulary: " swap append throw ] ?if From 52b5c5a0682644327c22d7e10f8fe16d006e67a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:48:51 -0600 Subject: [PATCH 247/317] Reorganize compiler tests --- core/alien/c-types/c-types.factor | 2 + core/alien/compiler/compiler-tests.factor | 356 ++++++++++++++++++ core/compiler/compiler-tests.factor | 28 +- .../curry-tests.factor} | 0 core/compiler/test/curry/curry.factor | 0 .../float-tests.factor} | 0 core/compiler/test/float/float.factor | 0 core/compiler/test/generic.factor | 30 -- core/compiler/test/ifte.factor | 131 ------- .../intrinsics-tests.factor} | 0 .../test/intrinsics/intrinsics.factor | 0 .../redefine-tests.factor} | 0 core/compiler/test/redefine/redefine.factor | 0 core/compiler/test/simple.factor | 71 ---- core/compiler/test/simple/simple-tests.factor | 227 +++++++++++ core/compiler/test/simple/simple.factor | 0 .../stack-trace-tests.factor} | 0 .../test/stack-trace/stack-trace.factor | 0 .../templates-early-tests.factor} | 0 .../templates-early/templates-early.factor | 0 .../templates-tests.factor} | 0 core/compiler/test/templates/templates.factor | 0 .../tuples-tests.factor} | 0 core/compiler/test/tuples/tuples.factor | 0 core/inference/class/class-tests.factor | 10 + core/inference/known-words/known-words.factor | 17 + core/inference/transforms/transforms.factor | 4 +- core/math/bitfields/bitfields-tests.factor | 11 +- core/optimizer/optimizer-tests.factor | 303 +++++++++++++++ core/parser/parser.factor | 2 +- 30 files changed, 936 insertions(+), 256 deletions(-) create mode 100755 core/alien/compiler/compiler-tests.factor mode change 100644 => 100755 core/compiler/compiler-tests.factor rename core/compiler/test/{curry.factor => curry/curry-tests.factor} (100%) create mode 100644 core/compiler/test/curry/curry.factor rename core/compiler/test/{float.factor => float/float-tests.factor} (100%) create mode 100644 core/compiler/test/float/float.factor delete mode 100644 core/compiler/test/generic.factor delete mode 100755 core/compiler/test/ifte.factor rename core/compiler/test/{intrinsics.factor => intrinsics/intrinsics-tests.factor} (100%) create mode 100644 core/compiler/test/intrinsics/intrinsics.factor rename core/compiler/test/{redefine.factor => redefine/redefine-tests.factor} (100%) create mode 100644 core/compiler/test/redefine/redefine.factor delete mode 100755 core/compiler/test/simple.factor create mode 100755 core/compiler/test/simple/simple-tests.factor create mode 100644 core/compiler/test/simple/simple.factor rename core/compiler/test/{stack-trace.factor => stack-trace/stack-trace-tests.factor} (100%) create mode 100644 core/compiler/test/stack-trace/stack-trace.factor rename core/compiler/test/{templates-early.factor => templates-early/templates-early-tests.factor} (100%) create mode 100644 core/compiler/test/templates-early/templates-early.factor rename core/compiler/test/{templates.factor => templates/templates-tests.factor} (100%) create mode 100644 core/compiler/test/templates/templates.factor rename core/compiler/test/{tuples.factor => tuples/tuples-tests.factor} (100%) create mode 100644 core/compiler/test/tuples/tuples.factor mode change 100644 => 100755 core/math/bitfields/bitfields-tests.factor create mode 100755 core/optimizer/optimizer-tests.factor diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 6c46cb946a..ed0721a7ff 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,8 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +: little-endian? ( -- ? ) 1 *char 1 = ; foldable + TUPLE: c-type boxer prep unboxer getter setter diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor new file mode 100755 index 0000000000..c0c3733afa --- /dev/null +++ b/core/alien/compiler/compiler-tests.factor @@ -0,0 +1,356 @@ +IN: temporary +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "hi" 3 ffi_test_2 ] must-fail + +FUNCTION: int ffi_test_3 int x int y int z int t ; +[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; +[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +FUNCTION: char* ffi_test_15 char* x char* y ; + +[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test +[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test +[ 1 2 ffi_test_15 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + data-gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke data-gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke data-gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] unit-test + +FUNCTION: double ffi_test_6 float x float y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test +[ "a" "b" ffi_test_6 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke code-gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +FUNCTION: long ffi_test_22 long x longlong y longlong z ; + +[ 987655432 ] +[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test + +[ 1111 f 123456789 ffi_test_22 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; + +[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test + +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +FUNCTION: test-struct-7 ffi_test_30 ; + +[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test + +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + data-gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] string-out +] unit-test + +: callback-5 + "void" { } "cdecl" [ data-gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +cpu "arm" = [ + [ "testing" ] [ + "testing" callback-5a callback_test_1 + ] unit-test +] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor old mode 100644 new mode 100755 index bd9b26ce6d..7e4e79437d --- a/core/compiler/compiler-tests.factor +++ b/core/compiler/compiler-tests.factor @@ -1,21 +1,7 @@ -USING: io.files tools.test sequences namespaces kernel -compiler.units ; - -{ - "templates-early" - "simple" - "intrinsics" - "float" - "generic" - "ifte" - "templates" - "optimizer" - "redefine" - "stack-trace" - "alien" - "curry" - "tuples" -} -[ "resource:core/compiler/test/" swap ".factor" 3append ] map -[ run-test ] map -[ failures get push-all ] each +IN: temporary +USING: tools.browser tools.test kernel sequences vocabs ; + +"compiler.test" child-vocabs empty? [ + "compiler.test" load-children + "compiler.test" test +] when diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry/curry-tests.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/test/curry/curry-tests.factor diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/float.factor b/core/compiler/test/float/float-tests.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/test/float/float-tests.factor diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/generic.factor b/core/compiler/test/generic.factor deleted file mode 100644 index c54dbd753d..0000000000 --- a/core/compiler/test/generic.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: compiler generic tools.test math kernel words arrays -sequences quotations ; - -GENERIC: single-combination-test - -M: object single-combination-test drop ; -M: f single-combination-test nip ; -M: array single-combination-test drop ; -M: integer single-combination-test drop ; - -[ 2 3 ] [ 2 3 t single-combination-test ] unit-test -[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test -[ 2 f ] [ 2 3 f single-combination-test ] unit-test - -DEFER: single-combination-test-2 - -: single-combination-test-4 - dup [ single-combination-test-2 ] when ; - -: single-combination-test-3 - drop 3 ; - -GENERIC: single-combination-test-2 -M: object single-combination-test-2 single-combination-test-3 ; -M: f single-combination-test-2 single-combination-test-4 ; - -[ 3 ] [ t single-combination-test-2 ] unit-test -[ 3 ] [ 3 single-combination-test-2 ] unit-test -[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor deleted file mode 100755 index 802cad5032..0000000000 --- a/core/compiler/test/ifte.factor +++ /dev/null @@ -1,131 +0,0 @@ -IN: temporary -USING: alien strings compiler tools.test math kernel words -math.private combinators ; - -: dummy-if-1 t [ ] [ ] if ; - -[ ] [ dummy-if-1 ] unit-test - -: dummy-if-2 f [ ] [ ] if ; - -[ ] [ dummy-if-2 ] unit-test - -: dummy-if-3 t [ 1 ] [ 2 ] if ; - -[ 1 ] [ dummy-if-3 ] unit-test - -: dummy-if-4 f [ 1 ] [ 2 ] if ; - -[ 2 ] [ dummy-if-4 ] unit-test - -: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; - -[ 1 ] [ dummy-if-5 ] unit-test - -: dummy-if-6 - dup 1 fixnum<= [ - drop 1 - ] [ - 1 fixnum- dup 1 fixnum- fixnum+ - ] if ; - -[ 17 ] [ 10 dummy-if-6 ] unit-test - -: dead-code-rec - t [ - 3.2 - ] [ - dead-code-rec - ] if ; - -[ 3.2 ] [ dead-code-rec ] unit-test - -: one-rec [ f one-rec ] [ "hi" ] if ; - -[ "hi" ] [ t one-rec ] unit-test - -: after-if-test - t [ ] [ ] if 5 ; - -[ 5 ] [ after-if-test ] unit-test - -DEFER: countdown-b - -: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; -: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; - -[ ] [ 10 countdown-b ] unit-test - -: dummy-when-1 t [ ] when ; - -[ ] [ dummy-when-1 ] unit-test - -: dummy-when-2 f [ ] when ; - -[ ] [ dummy-when-2 ] unit-test - -: dummy-when-3 dup [ dup fixnum* ] when ; - -[ 16 ] [ 4 dummy-when-3 ] unit-test -[ f ] [ f dummy-when-3 ] unit-test - -: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; - -[ 64 f ] [ f 4 dummy-when-4 ] unit-test -[ f t ] [ t f dummy-when-4 ] unit-test - -: dummy-when-5 f [ dup fixnum* ] when ; - -[ f ] [ f dummy-when-5 ] unit-test - -: dummy-unless-1 t [ ] unless ; - -[ ] [ dummy-unless-1 ] unit-test - -: dummy-unless-2 f [ ] unless ; - -[ ] [ dummy-unless-2 ] unit-test - -: dummy-unless-3 dup [ drop 3 ] unless ; - -[ 3 ] [ f dummy-unless-3 ] unit-test -[ 4 ] [ 4 dummy-unless-3 ] unit-test - -! Test cond expansion -[ "even" ] [ - [ - 2 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "odd" ] [ - [ - 3 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "neither" ] [ - [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } - } cond - ] compile-call -] unit-test - -[ 3 ] [ - [ - 3 { - { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } - } cond - ] compile-call -] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics-tests.factor similarity index 100% rename from core/compiler/test/intrinsics.factor rename to core/compiler/test/intrinsics/intrinsics-tests.factor diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine/redefine-tests.factor similarity index 100% rename from core/compiler/test/redefine.factor rename to core/compiler/test/redefine/redefine-tests.factor diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor deleted file mode 100755 index 6f5cb33c1a..0000000000 --- a/core/compiler/test/simple.factor +++ /dev/null @@ -1,71 +0,0 @@ -USING: compiler tools.test kernel kernel.private -combinators.private ; -IN: temporary - -! Test empty word -[ ] [ [ ] compile-call ] unit-test - -! Test literals -[ 1 ] [ [ 1 ] compile-call ] unit-test -[ 31 ] [ [ 31 ] compile-call ] unit-test -[ 255 ] [ [ 255 ] compile-call ] unit-test -[ -1 ] [ [ -1 ] compile-call ] unit-test -[ 65536 ] [ [ 65536 ] compile-call ] unit-test -[ -65536 ] [ [ -65536 ] compile-call ] unit-test -[ "hey" ] [ [ "hey" ] compile-call ] unit-test - -! Calls -: no-op ; - -[ ] [ [ no-op ] compile-call ] unit-test -[ 3 ] [ [ no-op 3 ] compile-call ] unit-test -[ 3 ] [ [ 3 no-op ] compile-call ] unit-test - -: bar 4 ; - -[ 4 ] [ [ bar no-op ] compile-call ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test - -[ ] [ no-op ] unit-test - -! Conditionals - -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test - -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test - -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test - -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test - -! Labels - -: recursive ( ? -- ) [ f recursive ] when ; inline - -[ ] [ t [ recursive ] compile-call ] unit-test - -[ ] [ t recursive ] unit-test - -! Make sure error reporting works - -[ [ dup ] compile-call ] must-fail -[ [ drop ] compile-call ] must-fail - -! Regression - -[ ] [ [ callstack ] compile-call drop ] unit-test - -! Regression - -: empty ; - -[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor new file mode 100755 index 0000000000..3f4f6451a3 --- /dev/null +++ b/core/compiler/test/simple/simple-tests.factor @@ -0,0 +1,227 @@ +USING: compiler tools.test kernel kernel.private +combinators.private math.private math combinators strings +alien arrays ; +IN: temporary + +! Test empty word +[ ] [ [ ] compile-call ] unit-test + +! Test literals +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test + +! Calls +: no-op ; + +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test + +: bar 4 ; + +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test + +[ ] [ no-op ] unit-test + +! Conditionals + +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test + +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test + +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test + +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test + +! Labels + +: recursive ( ? -- ) [ f recursive ] when ; inline + +[ ] [ t [ recursive ] compile-call ] unit-test + +[ ] [ t recursive ] unit-test + +! Make sure error reporting works + +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail + +! Regression + +[ ] [ [ callstack ] compile-call drop ] unit-test + +! Regression + +: empty ; + +[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test + +: dummy-if-1 t [ ] [ ] if ; + +[ ] [ dummy-if-1 ] unit-test + +: dummy-if-2 f [ ] [ ] if ; + +[ ] [ dummy-if-2 ] unit-test + +: dummy-if-3 t [ 1 ] [ 2 ] if ; + +[ 1 ] [ dummy-if-3 ] unit-test + +: dummy-if-4 f [ 1 ] [ 2 ] if ; + +[ 2 ] [ dummy-if-4 ] unit-test + +: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; + +[ 1 ] [ dummy-if-5 ] unit-test + +: dummy-if-6 + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup 1 fixnum- fixnum+ + ] if ; + +[ 17 ] [ 10 dummy-if-6 ] unit-test + +: dead-code-rec + t [ + 3.2 + ] [ + dead-code-rec + ] if ; + +[ 3.2 ] [ dead-code-rec ] unit-test + +: one-rec [ f one-rec ] [ "hi" ] if ; + +[ "hi" ] [ t one-rec ] unit-test + +: after-if-test + t [ ] [ ] if 5 ; + +[ 5 ] [ after-if-test ] unit-test + +DEFER: countdown-b + +: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; +: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; + +[ ] [ 10 countdown-b ] unit-test + +: dummy-when-1 t [ ] when ; + +[ ] [ dummy-when-1 ] unit-test + +: dummy-when-2 f [ ] when ; + +[ ] [ dummy-when-2 ] unit-test + +: dummy-when-3 dup [ dup fixnum* ] when ; + +[ 16 ] [ 4 dummy-when-3 ] unit-test +[ f ] [ f dummy-when-3 ] unit-test + +: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; + +[ 64 f ] [ f 4 dummy-when-4 ] unit-test +[ f t ] [ t f dummy-when-4 ] unit-test + +: dummy-when-5 f [ dup fixnum* ] when ; + +[ f ] [ f dummy-when-5 ] unit-test + +: dummy-unless-1 t [ ] unless ; + +[ ] [ dummy-unless-1 ] unit-test + +: dummy-unless-2 f [ ] unless ; + +[ ] [ dummy-unless-2 ] unit-test + +: dummy-unless-3 dup [ drop 3 ] unless ; + +[ 3 ] [ f dummy-unless-3 ] unit-test +[ 4 ] [ 4 dummy-unless-3 ] unit-test + +! Test cond expansion +[ "even" ] [ + [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "odd" ] [ + [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "neither" ] [ + [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond + ] compile-call +] unit-test + +[ 3 ] [ + [ + 3 { + { [ dup fixnum? ] [ ] } + { [ t ] [ drop t ] } + } cond + ] compile-call +] unit-test + +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; +M: array single-combination-test drop ; +M: integer single-combination-test drop ; + +[ 2 3 ] [ 2 3 t single-combination-test ] unit-test +[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test +[ 2 f ] [ 2 3 f single-combination-test ] unit-test + +DEFER: single-combination-test-2 + +: single-combination-test-4 + dup [ single-combination-test-2 ] when ; + +: single-combination-test-3 + drop 3 ; + +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +[ 3 ] [ t single-combination-test-2 ] unit-test +[ 3 ] [ 3 single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/simple/simple.factor b/core/compiler/test/simple/simple.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace-tests.factor similarity index 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/test/stack-trace/stack-trace-tests.factor diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early/templates-early-tests.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/test/templates-early/templates-early-tests.factor diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates/templates-tests.factor similarity index 100% rename from core/compiler/test/templates.factor rename to core/compiler/test/templates/templates-tests.factor diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/tuples.factor b/core/compiler/test/tuples/tuples-tests.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/test/tuples/tuples-tests.factor diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3bd90a3aca..17cc3d3cf8 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -263,3 +263,13 @@ cell-bits 32 = [ \ fixnum-shift inlined? ] unit-test ] when + +[ t ] [ + [ B{ 1 0 } *short 0 number= ] + \ number= inlined? +] unit-test + +[ t ] [ + [ B{ 1 0 } *short 0 = ] + \ number= inlined? +] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6be3899acd..69e331a9bf 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -414,64 +414,81 @@ t over set-effect-terminated? \ make-flushable \ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell make-flushable \ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell make-flushable \ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 make-flushable \ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 make-flushable \ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 make-flushable \ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 make-flushable \ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 make-flushable \ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 make-flushable \ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 make-flushable \ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 make-flushable \ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float make-flushable \ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double make-flushable \ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell make-flushable \ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop \ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string make-flushable \ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien make-flushable \ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string make-flushable \ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien make-flushable \ alien-address { alien } { integer } "inferred-effect" set-word-prop \ alien-address make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index ad2bacc789..b1b56ca1a1 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform -\ flags [ flags [ ] curry ] 1 define-transform +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform ! Tuple operations : [get-slots] ( slots -- quot ) diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index c382d3352d..a10c0566f8 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,4 +1,4 @@ -USING: math math.bitfields tools.test kernel ; +USING: math math.bitfields tools.test kernel words ; IN: temporary [ 0 ] [ { } bitfield ] unit-test @@ -6,3 +6,12 @@ IN: temporary [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test [ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +[ t ] [ \ foo compiled? ] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor new file mode 100755 index 0000000000..232eb5a83a --- /dev/null +++ b/core/optimizer/optimizer-tests.factor @@ -0,0 +1,303 @@ +USING: arrays compiler generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable ; +IN: temporary + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +: construct-empty-bug construct-empty ; + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d54bf1c1f4..486c589134 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ; : ( text -- lexer ) 0 { set-lexer-text set-lexer-line } lexer construct - dup lexer-text empty? [ dup next-line ] unless ; + dup next-line ; : location ( -- loc ) file get lexer get lexer-line 2dup and From 59cc83c29614f33bd177ebfb2d8f40fd12fbffb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:05 -0600 Subject: [PATCH 248/317] Fix bugs in tools.test --- extra/tools/test/test.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 192a248161..2cbdc3d7c7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -81,7 +81,7 @@ M: expected-error summary "Traceback" swap third write-object ; : test-failures. ( assoc -- ) - dup [ + [ nl dup empty? [ drop @@ -90,15 +90,15 @@ M: expected-error summary "==== FAILING TESTS:" print [ swap vocab-heading. - [ nl failure. nl ] each + [ failure. nl ] each ] assoc-each ] if ] [ - drop "==== NOTHING TO TEST" print - ] if ; + "==== NOTHING TO TEST" print + ] if* ; : run-tests ( prefix -- failures ) - child-vocabs dup empty? [ f ] [ + child-vocabs dup empty? [ drop f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; From 6df325c16830f55c925fede788e997d8e4288099 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:30 -0600 Subject: [PATCH 249/317] Moved little-endian? to alien.c-types --- extra/io/unix/select/select.factor | 2 -- 1 file changed, 2 deletions(-) mode change 100644 => 100755 extra/io/unix/select/select.factor diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor old mode 100644 new mode 100755 index c28686d2f2..06e257a610 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for ! byte order differences on big endian platforms -: little-endian? 1 *char 1 = ; foldable - : munge ( i -- i' ) little-endian? [ BIN: 11000 bitxor ] unless ; inline From b14197fadcb607ffc84f9f05531c11e567cd0561 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:49 -0600 Subject: [PATCH 250/317] Remove obsolete files --- core/compiler/test/alien.factor | 356 ---------------------------- core/compiler/test/optimizer.factor | 303 ----------------------- 2 files changed, 659 deletions(-) delete mode 100755 core/compiler/test/alien.factor delete mode 100755 core/compiler/test/optimizer.factor diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor deleted file mode 100755 index 4adb1c234b..0000000000 --- a/core/compiler/test/alien.factor +++ /dev/null @@ -1,356 +0,0 @@ -IN: temporary -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -FUNCTION: int ffi_test_2 int x int y ; -[ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] must-fail - -FUNCTION: int ffi_test_3 int x int y int z int t ; -[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; -[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail -[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -FUNCTION: char* ffi_test_15 char* x char* y ; - -[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test -[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] must-fail - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -FUNCTION: tiny ffi_test_17 int x ; - -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test - -[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] must-infer-as - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] must-fail - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; - -{ 3 1 } [ indirect-test-2 ] must-infer-as - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke data-gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] unit-test - -FUNCTION: double ffi_test_6 float x float y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] must-fail - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke code-gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -FUNCTION: long ffi_test_22 long x longlong y longlong z ; - -[ 987655432 ] -[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test - -[ 1111 f 123456789 ffi_test_22 ] must-fail - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; - -[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test - -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -FUNCTION: test-struct-7 ffi_test_30 ; - -[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test - -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; - -FUNCTION: double ffi_test_32 test-struct-8 x int y ; - -[ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y - 3 ffi_test_32 -] unit-test - -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; - -FUNCTION: double ffi_test_33 test-struct-9 x int y ; - -[ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y - 3 ffi_test_33 -] unit-test - -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_34 test-struct-10 x int y ; - -[ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y - 3 ffi_test_34 -] unit-test - -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_35 test-struct-11 x int y ; - -[ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; - -: make-struct-12 - "test-struct-12" - [ set-test-struct-12-x ] keep ; - -FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; - -[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out -] unit-test - -: callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -cpu "arm" = [ - [ "testing" ] [ - "testing" callback-5a callback_test_1 - ] unit-test -] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor deleted file mode 100755 index 987aace00a..0000000000 --- a/core/compiler/test/optimizer.factor +++ /dev/null @@ -1,303 +0,0 @@ -USING: arrays compiler generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable ; -IN: temporary - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -: construct-empty-bug construct-empty ; - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From 7adb07bcc4354c8f32befc3cfce5242c6b11687e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:11:47 -0600 Subject: [PATCH 251/317] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f04811b72a..538ed847f0 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From 3f38bf18ec98e02af5a42422d167bc8122053b89 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:14:08 -0600 Subject: [PATCH 252/317] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index 538ed847f0..16a2e65a90 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From d41bfc64f1686af2a53fb9be984b8324763aee28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 17:00:42 -0600 Subject: [PATCH 253/317] Minor tests fix --- extra/tools/test/test.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2cbdc3d7c7..0b5e436e44 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,9 +61,14 @@ M: expected-error summary dup vocab-source-loaded? [ vocab-tests-path dup [ dup ?resource-path exists? [ - [ "temporary" forget-vocab ] with-compilation-unit + [ + "temporary" forget-vocab + ] with-compilation-unit dup run-file - [ dup forget-source ] with-compilation-unit + [ + dup forget-source + "temporary" forget-vocab + ] with-compilation-unit ] when ] when ] when drop ; From 5570f367a631dddd2e0f42078baa15641ed12567 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:09:59 -0600 Subject: [PATCH 254/317] builder: build-status variable --- extra/builder/builder.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) mode change 100755 => 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 index 9af79efb29..1c5f5ff3fd --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -59,8 +59,12 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : build ( -- ) + "running" build-status set-global + datestamp >stamp "/builds/factor" cd @@ -98,6 +102,8 @@ VAR: stamp { "make" "clean" } run-process drop + ! "vm" build-status set-global + `{ { +arguments+ { "make" ,[ target ] } } { +stdout+ "../compile-log" } @@ -116,6 +122,8 @@ VAR: stamp [ "builder: image download" email-string ] cleanup + ! "bootstrap" build-status set-global + `{ { +arguments+ { ,[ factor-binary ] @@ -133,6 +141,8 @@ VAR: stamp "builder: bootstrap" throw ] if + ! "test" build-status set-global + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop "../load-everything-log" exists? @@ -143,6 +153,8 @@ VAR: stamp [ "builder: failing tests" "../failing-tests" email-file ] when + ! "ready" build-status set-global + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 7b07ababba5a9f95d17fa9c67fbfe006d97916cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:16:12 -0600 Subject: [PATCH 255/317] add builder.server --- extra/builder/server/server.factor | 68 ++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 extra/builder/server/server.factor diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor new file mode 100644 index 0000000000..672de1e47d --- /dev/null +++ b/extra/builder/server/server.factor @@ -0,0 +1,68 @@ + +USING: kernel continuations namespaces threads match bake concurrency builder ; + +IN: builder.server + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ [ build ] in-thread ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread +! ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build-server ( -- ) + receive + { + { + "start" + [ + build-status get "idle" = + build-status get f = + or + [ + [ [ build ] [ drop ] recover "idle" build-status set-global ] + in-thread + ] + when + ] + } + + { + { ?from ?tag "status" } + [ `{ ?tag ,[ build-status get ] } ?from send ] + } + } + match-cond + build-server ; + From d7af06c75ae454e15097108af22f9544a7e6a7ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:13:05 -0600 Subject: [PATCH 256/317] Remove obsolete scripts --- misc/integration/deploy-size-test.factor | 28 ------- misc/integration/macosx-deploy.factor | 24 ------ misc/integration/macosx.sh | 43 ----------- misc/integration/test.sh | 93 ------------------------ misc/integration/unix-arm.sh | 10 --- misc/integration/unix-ppc.sh | 10 --- misc/integration/unix-x86.32.sh | 21 ------ misc/integration/unix-x86.64.sh | 10 --- misc/integration/x11-deploy.factor | 8 -- 9 files changed, 247 deletions(-) delete mode 100644 misc/integration/deploy-size-test.factor delete mode 100644 misc/integration/macosx-deploy.factor delete mode 100644 misc/integration/macosx.sh delete mode 100644 misc/integration/test.sh delete mode 100644 misc/integration/unix-arm.sh delete mode 100644 misc/integration/unix-ppc.sh delete mode 100644 misc/integration/unix-x86.32.sh delete mode 100644 misc/integration/unix-x86.64.sh delete mode 100644 misc/integration/x11-deploy.factor diff --git a/misc/integration/deploy-size-test.factor b/misc/integration/deploy-size-test.factor deleted file mode 100644 index 91cdaba293..0000000000 --- a/misc/integration/deploy-size-test.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: tools.deploy sequences io.files io.launcher io -kernel concurrency prettyprint ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-world" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - dup - "deploy-log/" over append - [ deploy ] with-stream - dup file-length 1024 /f - 2array -] parallel-map . diff --git a/misc/integration/macosx-deploy.factor b/misc/integration/macosx-deploy.factor deleted file mode 100644 index f1e6e7fe06..0000000000 --- a/misc/integration/macosx-deploy.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: tools.deploy.app sequences io.files io.launcher io -kernel concurrency ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - "deploy-log/" over append - [ deploy.app ] with-stream -] parallel-each diff --git a/misc/integration/macosx.sh b/misc/integration/macosx.sh deleted file mode 100644 index dafe9524c6..0000000000 --- a/misc/integration/macosx.sh +++ /dev/null @@ -1,43 +0,0 @@ -CPU=$1 - -if [ "$CPU" = "x86.32" ]; then - TARGET="macosx-x86" -elif [ "$CPU" = "ppc" ]; then - TARGET="macosx-ppc" - CPU = "macosx-ppc" -else - echo "Specify a CPU" - exit 1 -fi - -EXE=factor - -bash misc/integration/test.sh \ - $EXE \ - $CPU \ - $TARGET \ - no \ - no \ - no \ - "X11=1" \ - "-ui-backend=x11" \ - "-x11" || exit 1 - -echo "Testing deployment" -$EXE "misc/integration/x11-deploy.factor" -run=none $VM_LOG $BOOT_LOG /tmp/factor-$$ - - $EXE -i=$IMAGE \ - /tmp/factor-$$ \ - -run=none \ - >$LOAD_LOG $TEST_LOG $BENCHMARK_LOG [ deploy ] with-stream From 52d91bf0bc0a568ae4d561890cd0082b3410b387 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:15:29 -0600 Subject: [PATCH 257/317] Add try-process word --- extra/benchmark/bootstrap2/bootstrap2.factor | 2 +- extra/bootstrap/image/upload/upload.factor | 3 +-- extra/editors/emacs/emacs.factor | 2 +- extra/editors/textmate/textmate.factor | 2 +- extra/io/launcher/launcher-docs.factor | 10 ++++++++++ extra/io/launcher/launcher.factor | 9 +++++++++ extra/logging/parser/parser.factor | 10 +++++++--- extra/tools/deploy/backend/backend.factor | 5 ++++- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 9 files changed, 36 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/bootstrap/image/upload/upload.factor diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index 54bc73f4a1..f57e92e5e0 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -9,6 +9,6 @@ IN: benchmark.bootstrap2 "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , - ] { } make run-process drop ; + ] { } make try-process ; MAIN: bootstrap-benchmark diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor old mode 100644 new mode 100755 index a9f5d1dcd4..3b5ab4cb77 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ "scp" , boot-image-names % "checksums.txt" , destination , - ] { } make run-process - wait-for-process zero? [ "Upload failed" throw ] unless ; + ] { } make try-process ; : new-images ( -- ) make-images compute-checksums upload-images ; diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor index 31e0761043..966c4f368e 100755 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -8,7 +8,7 @@ IN: editors.emacs "--no-wait" , "+" swap number>string append , , - ] { } make run-process drop ; + ] { } make try-process ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor index 0145ccae81..12d45aa192 100755 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -5,6 +5,6 @@ IN: editors.textmate : textmate-location ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - run-process drop ; + try-process ; [ textmate-location ] edit-hook set-global diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4979f135ac..e414d98d65 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process-failed +{ $values { "code" "an exit status" } } +{ $description "Throws a " { $link process-failed } " error." } +{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ; + +HELP: try-process +{ $values { "desc" "a launch descriptor" } } +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -175,6 +184,7 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +{ $subsection try-process } "Stopping processes:" { $subsection kill-process } "Redirecting standard input and output to a pipe:" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f2ed59a591..7044004218 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +TUPLE: process-failed code ; + +: process-failed ( code -- * ) + process-failed construct-boa throw ; + +: try-process ( desc -- ) + run-process wait-for-process dup zero? + [ drop ] [ process-failed ] if ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f1cb7aa17e..f9bf97a442 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -2,13 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files -namespaces combinators combinators.lib logging.server ; +namespaces combinators combinators.lib logging.server +calendar ; IN: logging.parser : string-of satisfy [ >string ] <@ ; +SYMBOL: multiline + : 'date' - [ CHAR: ] eq? not ] string-of + multiline-header token [ drop multiline ] <@ + [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> "[" "]" surrounded-by ; : 'log-level' @@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser ) first malformed eq? ; : multiline? ( line -- ? ) - first first CHAR: - = ; + first multiline eq? ; : malformed-line "Warning: malformed log line:" print diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index c295f6369d..2439ef8636 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,7 +22,10 @@ IN: tools.deploy.backend +stdout+ +stderr+ set ] H{ } make-assoc dup duplex-stream-out dispose - copy-lines ; + dup copy-lines + process-stream-process wait-for-process zero? [ + "Deployment failed" throw + ] unless ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 1bbf198ea0..eb1a4af4a7 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process drop ; + { "touch" } swap add try-process ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process drop ; + { "rm" "-rf" } swap add try-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; From 20649302fa59634b8bf3fc5aa99f72b94f2d2c10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:35 -0600 Subject: [PATCH 258/317] Fix a couple of issues with futures --- extra/concurrency/concurrency-tests.factor | 14 +++++++--- extra/concurrency/concurrency.factor | 30 +++++++++++++--------- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index b6f62d1779..1a19ce7096 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -112,9 +112,9 @@ SYMBOL: value ! The following unit test blocks forever if the ! exception does not propogate. Uncomment when ! this is fixed (via a timeout). -! [ -! [ "this should propogate" throw ] future ?future -! ] must-fail +[ + [ "this should propogate" throw ] future ?future +] must-fail [ ] [ [ "this should not propogate" throw ] future drop @@ -127,4 +127,10 @@ SYMBOL: value [ f ] [ [ "testing unregistering on error" throw ] spawn 100 sleep process-pid get-process -] unit-test \ No newline at end of file +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index cf44ab125c..e4972c9030 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,29 +264,35 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; +TUPLE: future value processes ; + +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return #! a 'future' on the stack. The future can later be queried with #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - [ self send ] compose spawn ; + \ future construct-empty [ + [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - process-mailbox mailbox-get ; - -: parallel-map ( seq quot -- newseq ) - #! Spawn a process to apply quot to each element of seq, - #! joining the results into a sequence at the end. - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - #! Spawn a process to apply quot to each element of seq, - #! and waits for all processes to complete. - [ f ] compose parallel-map drop ; + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; TUPLE: promise fulfilled? value processes ; From f05cf861eb032f3215690557f16cda2bf4f57394 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:47 -0600 Subject: [PATCH 259/317] Fix USING: in io.launcher --- extra/io/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7044004218..4a6bbf46fb 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads -continuations ; +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility From f45f6879ab04d4d115ee91b21493471592971fb9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 23:28:06 -0600 Subject: [PATCH 260/317] Makefile: winnt target downloads dlls --- Makefile | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 05a185f643..9776027a59 100755 --- a/Makefile +++ b/Makefile @@ -123,7 +123,15 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -winnt-x86-32: +freetype6.dll: + wget http://factorcode.org/dlls/freetype6.dll + chmod 755 freetype6.dll + +zlib1.dll: + wget http://factorcode.org/dlls/zlib1.dll + chmod 755 zlib1.dll + +winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 winnt-x86-64: From d65bde09d1a0f6eca0511826eb60d7b493232e25 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:14 -0600 Subject: [PATCH 261/317] Fix bootstrap --- core/alien/c-types/c-types.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ed0721a7ff..fbd49cedbb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,9 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +DEFER: +DEFER: *char + : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type From cb2dc00762edf5101c3a5689f541cfec39a72252 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:24 -0600 Subject: [PATCH 262/317] Add MAIN: to bootstrap.image.download --- extra/bootstrap/image/download/download.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index deed045221..df559f49da 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -23,3 +23,7 @@ bootstrap.image sequences io ; "Boot image up to date" print drop ] if ; + +: download-my-image ( -- ) my-arch download-image ; + +MAIN: download-my-image From 6f0e64bb4cb5843174c67df58bdd6c5bb5639a76 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:30 -0600 Subject: [PATCH 263/317] Add some tags --- extra/concurrency/distributed/tags.txt | 1 + extra/cpu/8080/emulator/tags.txt | 2 +- extra/cpu/8080/tags.txt | 2 +- extra/cryptlib/tags.txt | 1 + extra/http/server/tags.txt | 1 + extra/ldap/tags.txt | 1 + extra/openssl/tags.txt | 1 + extra/smtp/tags.txt | 1 + extra/xml-rpc/tags.txt | 1 + extra/xml/tags.txt | 1 + 10 files changed, 10 insertions(+), 2 deletions(-) diff --git a/extra/concurrency/distributed/tags.txt b/extra/concurrency/distributed/tags.txt index f4274299b1..50cfa263f6 100644 --- a/extra/concurrency/distributed/tags.txt +++ b/extra/concurrency/distributed/tags.txt @@ -1 +1,2 @@ +enterprise extensions diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/emulator/tags.txt +++ b/extra/cpu/8080/emulator/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/tags.txt +++ b/extra/cpu/8080/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cryptlib/tags.txt b/extra/cryptlib/tags.txt index bb863cf9a0..b88f9848cd 100644 --- a/extra/cryptlib/tags.txt +++ b/extra/cryptlib/tags.txt @@ -1 +1,2 @@ +enterprise bindings diff --git a/extra/http/server/tags.txt b/extra/http/server/tags.txt index ebb39bcce3..b0881a9ec0 100644 --- a/extra/http/server/tags.txt +++ b/extra/http/server/tags.txt @@ -1,2 +1,3 @@ +enterprise network web diff --git a/extra/ldap/tags.txt b/extra/ldap/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/ldap/tags.txt +++ b/extra/ldap/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/openssl/tags.txt b/extra/openssl/tags.txt index 59ccdd65e6..93e252c19e 100644 --- a/extra/openssl/tags.txt +++ b/extra/openssl/tags.txt @@ -1,2 +1,3 @@ +enterprise network bindings diff --git a/extra/smtp/tags.txt b/extra/smtp/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/smtp/tags.txt +++ b/extra/smtp/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/xml-rpc/tags.txt b/extra/xml-rpc/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml-rpc/tags.txt +++ b/extra/xml-rpc/tags.txt @@ -1 +1,2 @@ +enterprise web diff --git a/extra/xml/tags.txt b/extra/xml/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml/tags.txt +++ b/extra/xml/tags.txt @@ -1 +1,2 @@ +enterprise web From fdac73a4d74a05306293fddebcd39142313b3887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:15:29 -0600 Subject: [PATCH 264/317] Oops --- extra/concurrency/concurrency.factor | 33 ++++++++++++++-------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index e4972c9030..b46439b583 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,12 +264,7 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future value processes ; - -: notify-future ( value future -- ) - tuck set-future-value - dup future-processes [ schedule-thread ] each - f swap set-future-processes ; +TUPLE: future status value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return @@ -277,22 +272,28 @@ TUPLE: future value processes ; #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - \ future construct-empty [ + [ [ - >r [ t 2array ] compose [ f 2array ] recover r> - notify-future - ] 2curry spawn drop - ] keep ; + t + ] compose + ] spawn drop + [ self send ] compose spawn ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - dup future-value [ - first2 [ throw ] unless - ] [ - dup [ future-processes push stop ] curry callcc0 ?future - ] ?if ; + process-mailbox mailbox-get ; + +: parallel-map ( seq quot -- newseq ) + #! Spawn a process to apply quot to each element of seq, + #! joining the results into a sequence at the end. + [ curry future ] curry map [ ?future ] map ; + +: parallel-each ( seq quot -- ) + #! Spawn a process to apply quot to each element of seq, + #! and waits for all processes to complete. + [ f ] compose parallel-map drop ; TUPLE: promise fulfilled? value processes ; From 122be5b48ec22a69dd1afd0d2f441aacb9e4ed97 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 9 Feb 2008 00:17:24 -0800 Subject: [PATCH 265/317] Added set-fullscreen? and fullscreen? hooks along with their cocoa implementations. --- extra/cocoa/cocoa.factor | 1 + extra/ui/backend/backend.factor | 4 ++++ extra/ui/cocoa/cocoa.factor | 14 +++++++++++++- extra/ui/gadgets/worlds/worlds-docs.factor | 9 +++++++++ 4 files changed, 27 insertions(+), 1 deletion(-) diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index cbc6c9d762..c94984f00b 100755 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -58,6 +58,7 @@ SYMBOL: super-sent-messages "NSPasteboard" "NSResponder" "NSSavePanel" + "NSScreen" "NSView" "NSWindow" "NSWorkspace" diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index a0646f35b0..cc1f5f7d05 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -7,6 +7,10 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) +HOOK: set-fullscreen? ui-backend ( ? world -- ) + +HOOK: fullscreen? ui-backend ( world -- ? ) + HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 1e46544180..184e6fd856 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cocoa cocoa.application command-line +USING: math arrays cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend @@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents M: cocoa-ui-backend set-title ( string world -- ) world-handle second swap -> setTitle: ; +: enter-fullscreen ( world -- ) + world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; + +: exit-fullscreen ( world -- ) + world-handle first f -> exitFullScreenModeWithOptions: ; + +M: cocoa-ui-backend set-fullscreen? ( ? world -- ) + swap [ enter-fullscreen ] [ exit-fullscreen ] if ; + +M: cocoa-ui-backend fullscreen? ( world -- ? ) + world-handle first -> isInFullScreenMode zero? not ; + : auto-position ( world -- ) dup world-loc { 0 0 } = [ world-handle second -> center diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index a47717329d..8a64750751 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,6 +13,15 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; +HELP: set-fullscreen? +{ $values { "?" "a boolean" } { "world" world } } +{ $description "Sets and unsets fullscreen mode for the world." } +{ $notes "Find a world using " { $link find-world } "." } ; + +HELP: fullscreen? +{ $values { "world" world } { "?" "a boolean" } } +{ $description "Queries the world to see if it is running in fullscreen mode." } ; + HELP: raise-window { $values { "world" world } } { $description "Makes the native window containing the given world the front-most window." } From 7fbbe94d80c473c94f5b11f558cda2f5977d78d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:19:26 -0600 Subject: [PATCH 266/317] FEP work in progress --- vm/debug.c | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/vm/debug.c b/vm/debug.c index 5b4320b5e9..01e1ab0f43 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting) CELL length = array_capacity(array); CELL i; + if(length > 10) + length = 10; + for(i = 0; i < length; i++) { printf(" "); @@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type) if(type == -1 || type_of(obj) == type) { printf("%lx ",obj); - print_nested_obj(obj,3); + print_nested_obj(obj,1); printf("\n"); } } @@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type) gc_off = false; } +CELL obj; +CELL look_for; + +void find_references_step(CELL *scan) +{ + if(look_for == *scan) + { + printf("%lx ",obj); + print_nested_obj(obj,1); + printf("\n"); + } +} + +void find_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + CELL obj_; + while((obj_ = next_object()) != F) + { + obj = obj_; + do_slots(obj_,find_references_step); + } + + /* end scan */ + gc_off = false; +} + void factorbug(void) { reset_stdio(); From e9a63d7a2c2d080e778a3f3e8bd4b99d2867588f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:10:52 -0600 Subject: [PATCH 267/317] Arrggh --- extra/concurrency/concurrency.factor | 34 ++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b46439b583..3c8011cc6b 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,26 +264,36 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future status value processes ; +TUPLE: future value processes ; +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return - #! a 'future' on the stack. The future can later be queried with - #! ?future. If the quotation has completed the result will be returned. - #! If not, the process will block until the quotation completes. - #! 'quot' must have stack effect ( -- X ). + #! Spawn a process to call the quotation and immediately return. + \ future construct-empty [ [ [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; t ] compose ] spawn drop [ self send ] compose spawn ; - -: ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. - process-mailbox mailbox-get ; + + : ?future ( future -- result ) + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; : parallel-map ( seq quot -- newseq ) #! Spawn a process to apply quot to each element of seq, From 3121e740f2838d6d29ef0e1291fd8da670bb2416 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:12:14 -0600 Subject: [PATCH 268/317] Fix typo --- core/continuations/continuations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2977d02c6f..7cf15394ef 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -169,7 +169,7 @@ HELP: rethrow HELP: throw-restarts { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." } +{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } { $examples "Try invoking one of the two restarts which are offered after the below code throws an error:" { $code From 25c64c8ac713cc94bf706124900f3658e3e34167 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:13:06 -0600 Subject: [PATCH 269/317] Arrghh!!! --- extra/concurrency/concurrency.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 3c8011cc6b..50abee8418 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -280,15 +280,11 @@ TUPLE: future value processes ; notify-future ] 2curry spawn drop ] keep ; - t - ] compose - ] spawn drop - [ self send ] compose spawn ; : ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. dup future-value [ first2 [ throw ] unless ] [ From a21781e3807d1c89cba88989cb694e65d81d0ee3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:14:37 -0600 Subject: [PATCH 270/317] Concurrency fix --- extra/concurrency/concurrency.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 50abee8418..a8e0bc6eeb 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -270,11 +270,10 @@ TUPLE: future value processes ; tuck set-future-value dup future-processes [ schedule-thread ] each f swap set-future-processes ; - + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. \ future construct-empty [ - [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future From 5ca99b0105c82b881ccb023fee8b502e5a2651ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:15 -0600 Subject: [PATCH 271/317] Fix 'class' in early bootstrap --- core/classes/classes.factor | 4 +++- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 151429bf69..345676e106 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -20,7 +20,9 @@ PREDICATE: class tuple-class : classes ( -- seq ) classclass ( n -- class ) builtins get nth ; +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8cf83b0ba7..21a7857646 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ; : math-vtable* ( picker max quot -- quot ) [ rot , \ tag , - [ >r [ type>class ] map r> map % ] { } make , + [ >r [ bootstrap-type>class ] map r> map % ] { } make , \ dispatch , ] [ ] make ; inline diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 88f6a05bc2..7f4f423d8b 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -97,7 +97,7 @@ TUPLE: no-method object generic ; [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) - type>class [ hi-tag bootstrap-word ] unless* ; + bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; : group-methods ( assoc -- vtable ) #! Input is a predicate -> method association. From ee912c5996e9342d921c51051cd71001d94b2048 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:40 -0600 Subject: [PATCH 272/317] Walker cleanup --- extra/ui/tools/walker/walker.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 4740ff86d4..a23345d214 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ; : walker-active? ( walker -- ? ) walker-interpreter interpreter-continuation >boolean ; -: walker-command ( gadget quot -- ) - over walker-active? [ with-walker ] [ 2drop ] if ; inline - : save-interpreter ( walker -- ) dup walker-interpreter interpreter-continuation clone swap walker-history push ; -: com-step ( walker -- ) - dup save-interpreter [ step ] walker-command ; +: walker-command ( gadget quot -- ) + over walker-active? [ + over save-interpreter + with-walker + ] [ 2drop ] if ; inline -: com-into ( walker -- ) - dup save-interpreter [ step-into ] walker-command ; +: com-step ( walker -- ) [ step ] walker-command ; -: com-out ( walker -- ) - dup save-interpreter [ step-out ] walker-command ; +: com-into ( walker -- ) [ step-into ] walker-command ; + +: com-out ( walker -- ) [ step-out ] walker-command ; : com-back ( walker -- ) dup walker-history From ef63333980d03f963bb50b076ec52c10923cbcff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 18:12:07 -0600 Subject: [PATCH 273/317] Fix another bug with futures --- extra/concurrency/concurrency-tests.factor | 5 +++++ extra/concurrency/concurrency.factor | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index 1a19ce7096..8908506d51 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -133,4 +133,9 @@ SYMBOL: value [ 3 3 ] [ [ 3 ] future dup ?future swap ?future +] unit-test + +! Another race +[ 3 ] [ + [ 3 yield ] future ?future ] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index a8e0bc6eeb..1c5f6322a8 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -273,14 +273,14 @@ TUPLE: future value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. - \ future construct-empty [ + f V{ } clone \ future construct-boa [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future ] 2curry spawn drop ] keep ; - - : ?future ( future -- result ) + +: ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. From f655a25762173982ee894d61f7ca755524127aa1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:08:47 -0600 Subject: [PATCH 274/317] Fixing compiler test --- core/bootstrap/compiler/compiler.factor | 11 +++++++++++ core/compiler/test/simple/simple-tests.factor | 4 +++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..2b278ac458 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -77,3 +77,14 @@ nl [ compiled-usages recompile ] recompile-hook set-global " done" print flush + +! Load empty test vocabs +USE: compiler.test.curry +USE: compiler.test.float +USE: compiler.test.intrinsics +USE: compiler.test.redefine +USE: compiler.test.simple +USE: compiler.test.stack-trace +USE: compiler.test.templates +USE: compiler.test.templates-early +USE: compiler.test.tuples diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor index 3f4f6451a3..743fb713d9 100755 --- a/core/compiler/test/simple/simple-tests.factor +++ b/core/compiler/test/simple/simple-tests.factor @@ -1,6 +1,6 @@ USING: compiler tools.test kernel kernel.private combinators.private math.private math combinators strings -alien arrays ; +alien arrays memory ; IN: temporary ! Test empty word @@ -48,6 +48,8 @@ IN: temporary [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test + ! Labels : recursive ( ? -- ) [ f recursive ] when ; inline From 93e10566bef56950add23087e64af1e3da3f2575 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:12:00 -0600 Subject: [PATCH 275/317] Simpler compilation of dispatch --- core/cpu/architecture/architecture.factor | 4 +- core/cpu/ppc/architecture/architecture.factor | 23 +++++------ core/cpu/x86/architecture/architecture.factor | 39 ++++++++++--------- core/generator/generator.factor | 29 +++++++++----- 4 files changed, 50 insertions(+), 45 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4da22ff38a..4bb10b23a2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- ) ! Test if vreg is 'f' or not HOOK: %jump-t compiler-backend ( label -- ) -HOOK: %call-dispatch compiler-backend ( -- label ) - -HOOK: %jump-dispatch compiler-backend ( -- ) +HOOK: %dispatch compiler-backend ( -- ) HOOK: %dispatch-label compiler-backend ( word -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 7444c21a8c..1daf3ac622 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ; M: ppc-backend %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -: (%dispatch) ( len -- ) - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here - "offset" operand "n" operand 1 SRAWI - 11 11 "offset" operand ADD - 11 dup rot cells LWZ ; - -M: ppc-backend %call-dispatch ( word-table# -- ) - [ 7 (%dispatch) (%call)