From 02a9e1eb14c379a69af834399963fd95f7075d7d Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Thu, 4 Oct 2007 11:51:17 -0500 Subject: [PATCH 01/41] Fix the io and ui backends so it bootstraps and the ui starts --- extra/io/windows/nt/backend/backend.factor | 5 ++++- extra/ui/windows/windows.factor | 2 +- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 5eac9d6751..1700f725e8 100644 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -5,6 +5,9 @@ windows.errors windows.kernel32 prettyprint strings splitting io.files windows.winsock ; IN: io.windows.nt.backend +: .. global [ . flush ] bind ; +: .S global [ .s flush ] bind ; + : unicode-prefix ( -- seq ) "\\\\?\\" ; inline @@ -92,7 +95,7 @@ C: GetQueuedCompletionStatusParams : lookup-callback ( GetQueuedCompletion-args -- callback ) GetQueuedCompletionStatusParams-lpOverlapped* *void* - \ io-hash get-global delete-at drop ; + \ io-hash get-global delete-at* drop ; : wait-for-io ( timeout -- continuation/f ) wait-for-overlapped diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index 50367f6bd6..a320c7ccd0 100644 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -456,7 +456,7 @@ M: windows-ui-backend ui init-win32-ui start-ui event-loop - ] [ cleanup-win32-ui ] cleanup + ] [ cleanup-win32-ui ] [ ] cleanup ] ui-running ; T{ windows-ui-backend } ui-backend set-global From c0e72118fd272085907e90a5e0f421e6ef4d4940 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Thu, 4 Oct 2007 11:53:12 -0500 Subject: [PATCH 02/41] Add vim swap files to .gitignore (foo/bar/.baz.factor.swp) Remove -fomit-frame-pointer from Windows optimized compiles because it causes incorrect code Add -fomit-frame-pointer to Config.unix --- .gitignore | 1 + Makefile | 2 +- vm/Config.unix | 4 ++++ 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 6a748023af..b80837f4e2 100644 --- a/.gitignore +++ b/.gitignore @@ -14,3 +14,4 @@ factor .DS_Store .gdb_history *.*.marks +.*.swp diff --git a/Makefile b/Makefile index 11563a0698..378f96deae 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 -fomit-frame-pointer $(SITE_CFLAGS) + CFLAGS += -O3 $(SITE_CFLAGS) endif ifdef CONFIG diff --git a/vm/Config.unix b/vm/Config.unix index 831b3378d8..bcea3aef77 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -1,3 +1,7 @@ +#ifndef DEBUG +C_FLAGS += -fomit-frame-pointer +#endif + EXE_SUFFIX = DLL_PREFIX = lib DLL_EXTENSION = .a From d3f637abf0688a3f85a9a53fc4ff2b7054d9602a Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Thu, 4 Oct 2007 11:56:12 -0500 Subject: [PATCH 03/41] dllexport symbols in cpu-x86.*.S --- vm/cpu-x86.32.S | 3 +++ vm/cpu-x86.64.S | 3 +++ vm/cpu-x86.S | 9 +++++++++ 3 files changed, 15 insertions(+) diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 6233b4a14f..0e144c5a11 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -44,3 +44,6 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ #include "cpu-x86.S" + +.section .drectve +.ascii " -export:set_callstack" diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 4e8faa18de..55792cc205 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -36,3 +36,6 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ #include "cpu-x86.S" + +.section .drectve +.ascii " -export:set_callstack" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 7c9ab4e2cc..6096f034f0 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -63,3 +63,12 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): pop XT_REG pop XT_REG JUMP_QUOT /* Call the quotation */ + +.section .drectve +.ascii " -export:c_to_factor" +.ascii " -export:undefined" +.ascii " -export:docol_profiling" +.ascii " -export:primitive_call" +.ascii " -export:primitive_execute" +.ascii " -export:throw_impl" +.ascii " -export:lazy_jit_compile" From 51595cc78e239bfd5008f1f8ad6a468aaffa6fd1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:34:34 -0400 Subject: [PATCH 04/41] New call-clear primitive --- core/bootstrap/primitives.factor | 1 + core/kernel/kernel-docs.factor | 5 +++++ core/threads/threads.factor | 2 +- vm/errors.c | 6 ++++++ vm/errors.h | 1 + vm/primitives.c | 1 + 6 files changed, 15 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a1e7a84cae..838fe3251c 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -270,6 +270,7 @@ H{ } clone update-map set { "innermost-frame-quot" "kernel.private" } { "innermost-frame-scan" "kernel.private" } { "set-innermost-frame-quot" "kernel.private" } + { "call-clear" "kernel" } } dup length [ >r first2 r> make-primitive ] 2each diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index bbfd15ce53..5251f2b231 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -338,6 +338,11 @@ $nl { $code "2 [ 2 + 3 * ] call" "2 2 + 3 *" } } ; +HELP: call-clear ( quot -- ) +{ $values { "quot" callable } } +{ $description "Calls a quotation with an empty call stack. If the quotation returns, Factor will exit.." } +{ $notes "Used to implement " { $link "threads" } "." } ; + HELP: slip { $values { "quot" quotation } { "x" object } } { $description "Calls a quotation while hiding the top of the stack." } ; diff --git a/core/threads/threads.factor b/core/threads/threads.factor index c76118d14c..ee249c70a7 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -51,7 +51,7 @@ PRIVATE> >r schedule-thread r> [ V{ } set-catchstack { } set-retainstack - [ print-error ] recover stop + [ [ print-error ] recover stop ] call-clear ] (throw) ] curry callcc0 ; diff --git a/vm/errors.c b/vm/errors.c index 88659e4654..b8f7a2c52a 100644 --- a/vm/errors.c +++ b/vm/errors.c @@ -137,3 +137,9 @@ DEFINE_PRIMITIVE(throw) uncurry(dpop()); throw_impl(dpop(),stack_chain->callstack_top); } + +DEFINE_PRIMITIVE(call_clear) +{ + uncurry(dpop()); + throw_impl(dpop(),stack_chain->callstack_bottom); +} diff --git a/vm/errors.h b/vm/errors.h index cef4505a82..5295197f40 100644 --- a/vm/errors.h +++ b/vm/errors.h @@ -35,6 +35,7 @@ void not_implemented_error(void); F_FASTCALL void undefined_error(CELL word, F_STACK_FRAME *callstack_top); DECLARE_PRIMITIVE(throw); +DECLARE_PRIMITIVE(call_clear); INLINE void type_check(CELL type, CELL tagged) { diff --git a/vm/primitives.c b/vm/primitives.c index 6e7b67ba61..649b7294f9 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -193,4 +193,5 @@ void *primitives[] = { primitive_innermost_stack_frame_quot, primitive_innermost_stack_frame_scan, primitive_set_innermost_stack_frame_quot, + primitive_call_clear, }; From 1c1e6a7af0a89b5b0ca8bc850035d887f2855fd5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:34:49 -0400 Subject: [PATCH 05/41] Fix vector implementation bug --- core/vectors/vectors-tests.factor | 6 +++++- core/vectors/vectors.factor | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index ea44df4b06..4215185793 100644 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -1,6 +1,6 @@ USING: arrays kernel kernel.private math namespaces sequences sequences.private strings tools.test vectors -continuations random growable ; +continuations random growable classes ; IN: temporary [ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test @@ -93,3 +93,7 @@ IN: temporary [ t ] [ 100 >array dup >vector >array >r reverse r> = ] unit-test + +[ fixnum ] [ 1 >bignum V{ } new length class ] unit-test + +[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test diff --git a/core/vectors/vectors.factor b/core/vectors/vectors.factor index 2973431650..661ef9ddc8 100644 --- a/core/vectors/vectors.factor +++ b/core/vectors/vectors.factor @@ -14,7 +14,7 @@ M: vector like dup array? [ dup length array>vector ] [ >vector ] if ] unless ; -M: vector new drop [ f ] keep array>vector ; +M: vector new drop [ f ] keep >fixnum array>vector ; M: vector equal? over vector? [ sequence= ] [ 2drop f ] if ; From 5bc73cc5afcb9a5ae36a5ec9eec2a3fab68d5ff4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:36:24 -0400 Subject: [PATCH 06/41] Fix string buffer implementation bug --- core/sbufs/sbufs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/sbufs/sbufs.factor b/core/sbufs/sbufs.factor index 4ed47b20a3..3753be7729 100644 --- a/core/sbufs/sbufs.factor +++ b/core/sbufs/sbufs.factor @@ -9,7 +9,7 @@ IN: sbufs M: sbuf set-nth-unsafe underlying >r >r >fixnum r> >fixnum r> set-char-slot ; -M: sbuf new drop [ 0 ] keep string>sbuf ; +M: sbuf new drop [ 0 ] keep >fixnum string>sbuf ; : >sbuf ( seq -- sbuf ) SBUF" " clone-like ; inline From 43c83bb4e094b9aca338390631e3ff9a92868e30 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:37:11 -0400 Subject: [PATCH 07/41] Fixing unit tests --- extra/asn1/asn1-tests.factor | 2 +- extra/channels/channels-tests.factor | 2 +- extra/channels/remote/remote-tests.factor | 3 ++- extra/concurrency/concurrency-tests.factor | 2 +- extra/coroutines/coroutines.factor | 2 +- extra/crypto/timing/timing-tests.factor | 2 +- extra/destructors/destructors-tests.factor | 2 +- extra/inverse/inverse-tests.factor | 3 ++- extra/io/mmap/mmap-tests.factor | 3 ++- extra/koszul/koszul-tests.factor | 4 ++-- extra/math/analysis/analysis-tests.factor | 3 ++- extra/math/matrices/elimination/elimination-tests.factor | 2 +- .../numerical-integration/numerical-integration-tests.factor | 3 ++- extra/math/polynomials/polynomials-tests.factor | 2 +- extra/sequences/lib/lib-tests.factor | 2 +- extra/serialize/serialize-tests.factor | 3 ++- extra/units/imperial/imperial-tests.factor | 2 +- extra/units/si/si-tests.factor | 3 ++- extra/units/units-tests.factor | 3 ++- 19 files changed, 28 insertions(+), 20 deletions(-) diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor index 822f89cf88..1277090ec7 100644 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -1,4 +1,4 @@ -USING: asn1 asn1.ldap io.streams.string tools.test ; +USING: asn1 asn1.ldap io io.streams.string tools.test ; [ 6 ] [ "\u0002\u0001\u0006" [ asn-syntax read-ber ] with-stream diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 4b79f209aa..5c339d3406 100644 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: kernel tools.test math channels channels.private -sequences threads ; +sequences threads sorting ; IN: temporary { 3 t } [ diff --git a/extra/channels/remote/remote-tests.factor b/extra/channels/remote/remote-tests.factor index 939b0518a5..58a70fbf62 100644 --- a/extra/channels/remote/remote-tests.factor +++ b/extra/channels/remote/remote-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005 Chris Double. All Rights Reserved. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel tools.test math assocs channels channels.remote ; +USING: kernel tools.test math assocs channels channels.remote +channels.remote.private ; IN: temporary { t } [ diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index ded0996706..a9d4b39854 100644 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -3,7 +3,7 @@ ! USING: kernel concurrency threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations ; +match quotations concurrency.private ; IN: temporary [ V{ 1 2 3 } ] [ diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor index 2a84894e67..36c786e41a 100644 --- a/extra/coroutines/coroutines.factor +++ b/extra/coroutines/coroutines.factor @@ -40,5 +40,5 @@ TUPLE: coroutine resumecc exitcc ; : coterminate ( v -- ) current-coro get - f over set-coroutine-resumecc + [ ] over set-coroutine-resumecc coroutine-exitcc continue-with ; diff --git a/extra/crypto/timing/timing-tests.factor b/extra/crypto/timing/timing-tests.factor index 9fafa73297..1337ccca8a 100644 --- a/extra/crypto/timing/timing-tests.factor +++ b/extra/crypto/timing/timing-tests.factor @@ -1,4 +1,4 @@ -USING: crypto.timing kernel tools.test ; +USING: crypto.timing kernel tools.test system math ; IN: temporary [ t ] [ millis [ ] 1000 with-timing millis swap - 1000 >= ] unit-test diff --git a/extra/destructors/destructors-tests.factor b/extra/destructors/destructors-tests.factor index 526c6722ea..a6ef2dc4be 100644 --- a/extra/destructors/destructors-tests.factor +++ b/extra/destructors/destructors-tests.factor @@ -1,4 +1,4 @@ -USING: destructors kernel tools.test ; +USING: destructors kernel tools.test continuations ; IN: temporary TUPLE: dummy-obj destroyed? ; diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 176be093b3..8374caa9ff 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,4 +1,5 @@ -USING: inverse tools.test arrays math kernel sequences ; +USING: inverse tools.test arrays math kernel sequences +math.functions ; [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test [ { 3 4 } [ dup 2array ] undo ] unit-test-fails diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index b35efac9be..729882deeb 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,4 +1,5 @@ -USING: io io.mmap kernel tools.test ; +USING: io io.mmap io.files kernel tools.test continuations +sequences ; IN: temporary [ "mmap-test-file.txt" resource-path delete-file ] catch drop diff --git a/extra/koszul/koszul-tests.factor b/extra/koszul/koszul-tests.factor index 3f5cc0ee36..d72314fc4d 100644 --- a/extra/koszul/koszul-tests.factor +++ b/extra/koszul/koszul-tests.factor @@ -7,7 +7,7 @@ IN: temporary { { 1 } { 2 3 } { 4 5 6 } { 7 8 } { } } graded ] unit-test -SYMBOLS: x1 x2 x3 x4 z1 z2 ; +SYMBOLS: x1 x2 x3 x4 x5 x6 z1 z2 ; [ H{ { { x1 } 3 } } ] [ x1 3 wedge ] unit-test @@ -23,7 +23,7 @@ x3 x4 wedge z2 d= ! Unimodular example boundaries get clear-assoc -SYMBOLS: x y z ; +SYMBOLS: x y w z ; x y wedge z d= y z wedge x d= diff --git a/extra/math/analysis/analysis-tests.factor b/extra/math/analysis/analysis-tests.factor index 7ef869cfbd..0ed66a569c 100644 --- a/extra/math/analysis/analysis-tests.factor +++ b/extra/math/analysis/analysis-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math math.functions tools.test ; +USING: kernel math math.functions tools.test math.analysis +math.constants ; IN: temporary : eps diff --git a/extra/math/matrices/elimination/elimination-tests.factor b/extra/math/matrices/elimination/elimination-tests.factor index b9fedf564f..d6fb2957e1 100644 --- a/extra/math/matrices/elimination/elimination-tests.factor +++ b/extra/math/matrices/elimination/elimination-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: kernel math.matrices math.matrices.elimination -tools.test ; +tools.test sequences ; [ { diff --git a/extra/math/numerical-integration/numerical-integration-tests.factor b/extra/math/numerical-integration/numerical-integration-tests.factor index ce7f679eb1..33b6e78571 100644 --- a/extra/math/numerical-integration/numerical-integration-tests.factor +++ b/extra/math/numerical-integration/numerical-integration-tests.factor @@ -1,4 +1,5 @@ -USING: kernel math.numerical-integration ; +USING: kernel math.numerical-integration tools.test math +math.constants math.functions ; IN: temporary [ 50 ] [ 0 10 [ ] integrate-simpson ] unit-test diff --git a/extra/math/polynomials/polynomials-tests.factor b/extra/math/polynomials/polynomials-tests.factor index 80375c3b23..4d0cdf8c8b 100644 --- a/extra/math/polynomials/polynomials-tests.factor +++ b/extra/math/polynomials/polynomials-tests.factor @@ -1,5 +1,5 @@ IN: temporary -USING: kernel math tools.test ; +USING: kernel math math.polynomials tools.test ; ! Tests [ { 0 1 } ] [ { 0 1 0 0 } ptrim ] unit-test diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index a342391e70..e457139bcd 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -1,4 +1,4 @@ -USING: kernel sequences.lib ; +USING: kernel sequences.lib math math.functions tools.test ; [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor index b312ce3af3..f40499f534 100644 --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. ! USING: tools.test kernel serialize io io.streams.string math -alien arrays byte-arrays sequences math prettyprint ; +alien arrays byte-arrays sequences math prettyprint parser +classes math.constants ; IN: temporary TUPLE: serialize-test a b ; diff --git a/extra/units/imperial/imperial-tests.factor b/extra/units/imperial/imperial-tests.factor index 2c41fe5866..def13bd784 100644 --- a/extra/units/imperial/imperial-tests.factor +++ b/extra/units/imperial/imperial-tests.factor @@ -1,4 +1,4 @@ -USING: kernel math tools.test units.imperial ; +USING: kernel math tools.test units.imperial inverse ; IN: temporary [ 1 ] [ 12 inches [ feet ] undo ] unit-test diff --git a/extra/units/si/si-tests.factor b/extra/units/si/si-tests.factor index 0fe4a6e66a..85d2bd3317 100644 --- a/extra/units/si/si-tests.factor +++ b/extra/units/si/si-tests.factor @@ -1,4 +1,5 @@ -USING: kernel tools.test units.si inverse ; +USING: kernel tools.test units.si inverse math.constants +math.functions units.imperial ; IN: temporary [ t ] [ 1 m 100 cm = ] unit-test diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 831d68d412..72c3b108ea 100644 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -1,4 +1,5 @@ -USING: arrays kernel math sequences tools.test units.si units ; +USING: arrays kernel math sequences tools.test units.si +units.imperial units inverse ; IN: temporary [ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test From 48d8d60c7c57ad34c027c665aae5ef47ac2958da Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:37:47 -0400 Subject: [PATCH 08/41] Clean up and update tools.deploy --- extra/tools/deploy/app/app.factor | 4 +- extra/tools/deploy/config/config-docs.factor | 105 ++++++++ extra/tools/deploy/config/config.factor | 53 ++++ extra/tools/deploy/deploy-docs.factor | 99 +------- extra/tools/deploy/deploy.factor | 247 +------------------ extra/tools/deploy/shaker/shaker.factor | 194 +++++++++++++++ 6 files changed, 365 insertions(+), 337 deletions(-) create mode 100644 extra/tools/deploy/config/config-docs.factor create mode 100644 extra/tools/deploy/config/config.factor create mode 100644 extra/tools/deploy/shaker/shaker.factor diff --git a/extra/tools/deploy/app/app.factor b/extra/tools/deploy/app/app.factor index df33581c98..3672c9a586 100644 --- a/extra/tools/deploy/app/app.factor +++ b/extra/tools/deploy/app/app.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.files io.launcher kernel namespaces sequences -system cocoa.plists cocoa.application tools.deploy assocs -hashtables prettyprint ; +system cocoa.plists cocoa.application tools.deploy +tools.deploy.config assocs hashtables prettyprint ; IN: tools.deploy.app : mkdir ( path -- ) diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor new file mode 100644 index 0000000000..6f683f9c44 --- /dev/null +++ b/extra/tools/deploy/config/config-docs.factor @@ -0,0 +1,105 @@ +USING: help.markup help.syntax words alien.c-types assocs +kernel ; +IN: tools.deploy.config + +ARTICLE: "deploy-config" "Deployment configuration" +"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:" +{ $subsection default-config } +"The deployment configuration can be read and written with a pair of words:" +{ $subsection deploy-config } +{ $subsection set-deploy-config } +"A utility word is provided to load the configuration, change a flag, and store it back to disk:" +{ $subsection set-deploy-flag } ; + +ARTICLE: "deploy-flags" "Deployment flags" +"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:" +{ $subsection deploy-math? } +{ $subsection deploy-compiled? } +{ $subsection deploy-io? } +{ $subsection deploy-ui? } +"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" +{ $subsection strip-globals? } +{ $subsection strip-word-props? } +{ $subsection strip-word-names? } +{ $subsection strip-dictionary? } +{ $subsection strip-debugger? } +{ $subsection strip-prettyprint? } +{ $subsection strip-c-types? } ; + +ARTICLE: "prepare-deploy" "Preparing to deploy an application" +"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." +{ $subsection "deploy-config" } +{ $subsection "deploy-flags" } ; + +ABOUT: "prepare-deploy" + +HELP: strip-globals? +{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace." +$nl +"On by default. Disable this if the heuristics strip out required variables." } ; + +HELP: strip-word-props? +{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary." +$nl +"On by default. Disable this if the heuristics strip out required word properties." } ; + +HELP: strip-word-names? +{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary." +$nl +"On by default. Disable this if your program calls " { $link word-name } "." } ; + +HELP: strip-dictionary? +{ $description "Deploy flag. If set, the deploy tool strips unused words." +$nl +"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ; + +HELP: strip-debugger? +{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM." +$nl +"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ; + +HELP: strip-prettyprint? +{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter." +$nl +"On by default. Disable this if your program uses the prettyprinter." } ; + +HELP: strip-c-types? +{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table." +$nl +"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link } ", " { $link } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ; + +HELP: deploy-math? +{ $description "Deploy flag. If set, the deployed image will contain the full number tower." +$nl +"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ; + +HELP: deploy-compiled? +{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible." +$nl +"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; + +HELP: deploy-ui? +{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image." +$nl +"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ; + +HELP: deploy-io? +{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image." +$nl +"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ; + +HELP: default-config +{ $values { "assoc" assoc } } +{ $description "Outputs the default deployment configuration." } ; + +HELP: deploy-config +{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } +{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ; + +HELP: set-deploy-config +{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } } +{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ; + +HELP: set-deploy-flag +{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } } +{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ; diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor new file mode 100644 index 0000000000..832f9f4a1a --- /dev/null +++ b/extra/tools/deploy/config/config.factor @@ -0,0 +1,53 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: vocabs.loader io.files io kernel sequences assocs +splitting parser prettyprint ; +IN: tools.deploy.config + +SYMBOL: strip-globals? +SYMBOL: strip-word-props? +SYMBOL: strip-word-names? +SYMBOL: strip-dictionary? +SYMBOL: strip-debugger? +SYMBOL: strip-prettyprint? +SYMBOL: strip-c-types? + +SYMBOL: deploy-math? +SYMBOL: deploy-compiled? +SYMBOL: deploy-io? +SYMBOL: deploy-ui? + +SYMBOL: deploy-vm +SYMBOL: deploy-image + +: default-config ( -- assoc ) + V{ + { strip-prettyprint? t } + { strip-globals? t } + { strip-word-props? t } + { strip-word-names? t } + { strip-dictionary? t } + { strip-debugger? t } + { strip-c-types? t } + { deploy-math? t } + { deploy-compiled? t } + { deploy-io? f } + { deploy-ui? f } + ! default value for deploy.app + { "stop-after-last-window?" t } + } clone ; + +: deploy-config-path ( vocab -- string ) + vocab-dir "deploy.factor" path+ ; + +: deploy-config ( vocab -- assoc ) + default-config swap + dup deploy-config-path vocab-file-contents + parse-fresh dup empty? [ drop ] [ first union ] if ; + +: set-deploy-config ( assoc vocab -- ) + >r unparse-use string-lines r> + dup deploy-config-path set-vocab-file-contents ; + +: set-deploy-flag ( value key vocab -- ) + [ deploy-config [ set-at ] keep ] keep set-deploy-config ; diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index 1f25f68ff9..29e0da1f5c 100644 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -2,30 +2,6 @@ USING: help.markup help.syntax words alien.c-types assocs kernel ; IN: tools.deploy -ARTICLE: "deploy-config" "Deployment configuration" -"The deployment configuration is a key/value mapping stored in the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If this file does not exist, the default deployment configuration is used:" -{ $subsection default-config } -"The deployment configuration can be read and written with a pair of words:" -{ $subsection deploy-config } -{ $subsection set-deploy-config } -"A utility word is provided to load the configuration, change a flag, and store it back to disk:" -{ $subsection set-deploy-flag } ; - -ARTICLE: "deploy-flags" "Deployment flags" -"There are two types of flags. The first set controls the major subsystems which are to be included in the deployment image:" -{ $subsection deploy-math? } -{ $subsection deploy-compiled? } -{ $subsection deploy-io? } -{ $subsection deploy-ui? } -"The second set of flags controls the level of stripping to be performed on the deployment image; there is a trade-off between image size, and retaining functionality which is required by the application:" -{ $subsection strip-globals? } -{ $subsection strip-word-props? } -{ $subsection strip-word-names? } -{ $subsection strip-dictionary? } -{ $subsection strip-debugger? } -{ $subsection strip-prettyprint? } -{ $subsection strip-c-types? } ; - ARTICLE: "tools.deploy" "Stand-alone image deployment" "The stand-alone image deployment tool takes a vocabulary and generates an image, which when passed to the VM, runs the vocabulary's " { $link POSTPONE: MAIN: } " hook." $nl @@ -33,85 +9,12 @@ $nl { $code "\"hello-world\" deploy" } "This generates an image file named " { $snippet "hello-world.image" } ". Now we can start this image from the operating system's command line (see " { $link "runtime-cli-args" } "):" { $code "./factor -i=hello-world.image" "Hello world" } -"In order to deploy an application as a stand-alone image, the application's vocabulary must first be given a " { $link POSTPONE: MAIN: } " hook. Then, a " { $emphasis "deployment configuration" } " must be created." -{ $subsection "deploy-config" } -{ $subsection "deploy-flags" } + "Once the necessary deployment flags have been set, a deployment image can be generated:" { $subsection deploy } ; ABOUT: "tools.deploy" -HELP: strip-globals? -{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed variables from the global namespace." -$nl -"On by default. Disable this if the heuristics strip out required variables." } ; - -HELP: strip-word-props? -{ $description "Deploy flag. If set, the deploy tool applies various heuristics to strip out un-needed word properties from words in the dictionary." -$nl -"On by default. Disable this if the heuristics strip out required word properties." } ; - -HELP: strip-word-names? -{ $description "Deploy flag. If set, the deploy tool strips word names from words in the dictionary." -$nl -"On by default. Disable this if your program calls " { $link word-name } "." } ; - -HELP: strip-dictionary? -{ $description "Deploy flag. If set, the deploy tool strips unused words." -$nl -"On by default. Disable this if your program calls " { $link lookup } " to look up words by name, or needs to parse code at run-time." } ; - -HELP: strip-debugger? -{ $description "Deploy flag. If set, the deploy tool strips the verbose error reporting facility; any errors thrown by the program will start the low-level debugger in the VM." -$nl -"On by default. Disable this if you need to debug a problem which only occurs when your program is running deployed." } ; - -HELP: strip-prettyprint? -{ $description "Deploy flag. If set, the deploy tool strips variables used by the prettyprinter." -$nl -"On by default. Disable this if your program uses the prettyprinter." } ; - -HELP: strip-c-types? -{ $description "Deploy flag. If set, the deploy tool strips out the " { $link c-types } " table." -$nl -"On by default. Disable this if your program calls " { $link c-type } ", " { $link heap-size } ", " { $link } ", " { $link } ", " { $link malloc-object } ", or " { $link malloc-array } " with a C type name which is not a literal pushed directly at the call site. In this situation, the compiler is unable to fold away the C type lookup, and thus must use the global table at runtime." } ; - -HELP: deploy-math? -{ $description "Deploy flag. If set, the deployed image will contain the full number tower." -$nl -"On by default. Most programs require the number tower, in particular, any program deployed with " { $link deploy-compiled? } " set." } ; - -HELP: deploy-compiled? -{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible." -$nl -"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ; - -HELP: deploy-ui? -{ $description "Deploy flag. If set, the Factor UI will be included in the deployed image." -$nl -"Off by default. Programs wishing to use the UI must be deployed with this flag on." } ; - -HELP: deploy-io? -{ $description "Deploy flag. If set, support for non-blocking I/O and networking will be included in the deployed image." -$nl -"Off by default. Programs wishing to use non-blocking I/O or networking must be deployed with this flag on." } ; - -HELP: default-config -{ $values { "assoc" assoc } } -{ $description "Outputs the default deployment configuration." } ; - -HELP: deploy-config -{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } -{ $description "Loads a vocabulary's deployment configuration from the " { $snippet "deploy.factor" } " file in the vocabulary's directory. If the file does not exist, the " { $link default-config } " is output." } ; - -HELP: set-deploy-config -{ $values { "assoc" assoc } { "vocab" "a vocabulary specifier" } } -{ $description "Stores a vocabulary's deployment configuration to the " { $snippet "deploy.factor" } " file in the vocabulary's directory." } ; - -HELP: set-deploy-flag -{ $values { "value" object } { "key" object } { "vocab" "a vocabulary specifier" } } -{ $description "Modifies an entry in a vocabulary's deployment configuration on disk." } ; - HELP: deploy* { $values { "vm" "a pathname string" } { "image" "a pathname string" } { "vocab" "a vocabulary specifier" } { "config" assoc } } { $description "Deploys " { $snippet "vocab" } ", which must have a " { $link POSTPONE: MAIN: } " hook, using the specified VM and configuration. The deployed image is saved as " { $snippet "image" } "." } diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index dfa31ed06d..9a7f99a99d 100644 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,255 +5,30 @@ assocs kernel vocabs words sequences memory io system arrays continuations math definitions mirrors splitting parser classes inspector layouts vocabs.loader prettyprint.config prettyprint debugger io.streams.c io.streams.duplex io.files io.backend -quotations io.launcher words.private ; +quotations io.launcher words.private tools.deploy.config ; IN: tools.deploy -SYMBOL: strip-globals? -SYMBOL: strip-word-props? -SYMBOL: strip-word-names? -SYMBOL: strip-dictionary? -SYMBOL: strip-debugger? -SYMBOL: strip-prettyprint? -SYMBOL: strip-c-types? - -SYMBOL: deploy-math? -SYMBOL: deploy-compiled? -SYMBOL: deploy-io? -SYMBOL: deploy-ui? - -SYMBOL: deploy-vm -SYMBOL: deploy-image - -: default-config ( -- assoc ) - V{ - { strip-prettyprint? t } - { strip-globals? t } - { strip-word-props? t } - { strip-word-names? t } - { strip-dictionary? t } - { strip-debugger? t } - { strip-c-types? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } - { deploy-ui? f } - ! default value for deploy.app - { "stop-after-last-window?" t } - } clone ; - -: deploy-config-path ( vocab -- string ) - vocab-dir "deploy.factor" path+ ; - -: deploy-config ( vocab -- assoc ) - default-config swap - dup deploy-config-path vocab-file-contents - parse-fresh dup empty? [ drop ] [ first union ] if ; - -: set-deploy-config ( assoc vocab -- ) - >r unparse-use string-lines r> - dup deploy-config-path set-vocab-file-contents ; - -: set-deploy-flag ( value key vocab -- ) - [ deploy-config [ set-at ] keep ] keep set-deploy-config ; - r V{ } set-datastack r> - V{ } set-retainstack - V{ } set-callstack - V{ } set-namestack - V{ } set-catchstack - "Saving final image" show - [ save-image-and-exit ] call ; - -SYMBOL: deploy-vocab - -: set-boot-quot* ( word -- ) - [ - \ boot , - init-hooks get values concat % - , - "io.backend" init-hooks get at [ \ flush , ] when - ] [ ] make "Boot quotation: " write dup . flush - set-boot-quot ; - -: retained-globals ( -- seq ) - [ - builtins , - io-backend , - - strip-dictionary? get [ - { - builtins - dictionary - inspector-hook - lexer-factory - load-vocab-hook - num-tags - num-types - tag-bits - tag-mask - tag-numbers - typemap - vocab-roots - } % - ] unless - - strip-prettyprint? get [ - { - tab-size - margin - } % - ] unless - - strip-c-types? get not deploy-ui? get or [ - "c-types" "alien.c-types" lookup , - ] when - - deploy-ui? get [ - "ui" child-vocabs - "cocoa" child-vocabs - deploy-vocab get child-vocabs 3append - global keys [ word? ] subset - swap [ >r word-vocabulary r> member? ] curry - subset % - ] when - ] { } make dup . ; - -: normalize-strip-flags - strip-prettyprint? get [ - strip-word-names? off - ] unless - strip-dictionary? get [ - strip-prettyprint? off - strip-word-names? off - strip-word-props? off - ] unless ; - -: strip ( -- ) - normalize-strip-flags - strip-cocoa - strip-debugger - strip-init-hooks - deploy-vocab get vocab-main set-boot-quot* - retained-props >r - retained-globals strip-environment - r> strip-words ; - -: (deploy) ( final-image vocab config -- ) - #! Does the actual work of a deployment in the slave - #! stage2 image - [ - [ - deploy-vocab set - parse-hook get >r - parse-hook off - deploy-vocab get require - r> call - strip - finish-deploy - ] [ - print-error flush 1 exit - ] recover - ] bind ; - -: do-deploy ( -- ) - "output-image" get - "deploy-vocab" get - "Deploying " write dup write "..." print - dup deploy-config dup . - (deploy) ; - : (copy-lines) ( stream -- stream ) dup stream-readln [ print flush (copy-lines) ] when* ; : copy-lines ( stream -- ) [ (copy-lines) ] [ stream-close ] [ ] cleanup ; +: boot-image-name ( -- string ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + : stage2 ( vm flags -- ) [ - "\"" % swap % "\" -i=boot." % cpu % ".image" % + "\"" % swap % "\" -i=boot." % + boot-image-name + % ".image" % [ " " % % ] each ] "" make - dup print copy-lines ; + dup print + dup duplex-stream-out stream-close + copy-lines ; : profile-string ( config -- string ) { @@ -283,5 +58,3 @@ PRIVATE> : deploy ( vocab -- ) vm over ".image" append rot dup deploy-config deploy* ; - -MAIN: do-deploy diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor new file mode 100644 index 0000000000..9eabf1a67e --- /dev/null +++ b/extra/tools/deploy/shaker/shaker.factor @@ -0,0 +1,194 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces continuations.private kernel.private init +assocs kernel vocabs words sequences memory io system arrays +continuations math definitions mirrors splitting parser classes +inspector layouts vocabs.loader prettyprint.config prettyprint +debugger io.streams.c io.streams.duplex io.files io.backend +quotations words.private tools.deploy.config ; +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 fwrite stdout fflush ; + +: strip-init-hooks ( -- ) + "Stripping startup hooks" show + "command-line" init-hooks get delete-at ; + +: strip-debugger ( -- ) + strip-debugger? get [ + "Stripping debugger" show + "resource:extra/tools/deploy/strip-debugger.factor" + run-file + ] when ; + +: strip-cocoa ( -- ) + "cocoa" vocab [ + "Stripping unused Cocoa methods" show + "resource:extra/tools/deploy/strip-cocoa.factor" + run-file + ] when ; + +: strip-assoc ( retained-keys assoc -- newassoc ) + swap [ nip member? ] curry assoc-subset ; + +: strip-word-names ( words -- ) + "Stripping word names" show + [ f over set-word-name f swap set-word-vocabulary ] each ; + +: strip-word-defs ( words -- ) + "Stripping unoptimized definitions from optimized words" show + [ compiled? ] subset [ [ ] swap set-word-def ] each ; + +: strip-word-props ( retain-props words -- ) + "Stripping word properties" show + [ + [ word-props strip-assoc f assoc-like ] keep + set-word-props + ] curry* each ; + +: retained-props ( -- seq ) + [ + "class" , + "metaclass" , + "slot-names" , + deploy-ui? get [ + "gestures" , + "commands" , + { "+nullary+" "+listener+" "+description+" } + [ "ui.commands" lookup , ] each + ] when + ] { } make ; + +: strip-words ( props -- ) + [ word? ] instances + strip-word-props? get [ tuck strip-word-props ] [ nip ] if + strip-word-names? get [ dup strip-word-names ] when + strip-word-defs ; + +USING: bit-arrays byte-arrays io.streams.nested ; + +: strip-classes ( -- ) + "Stripping classes" show + io-backend get [ + c-reader forget + c-writer forget + ] when + { style-stream mirror enum } [ forget ] each ; + +: strip-environment ( retain-globals -- ) + "Stripping environment" show + strip-globals? get [ + global strip-assoc 21 setenv + ] [ drop ] if ; + +: finish-deploy ( final-image -- ) + "Finishing up" show + >r { } set-datastack r> + { } set-retainstack + V{ } set-namestack + V{ } set-catchstack + "Saving final image" show + [ save-image-and-exit ] call-clear ; + +SYMBOL: deploy-vocab + +: set-boot-quot* ( word -- ) + [ + \ boot , + init-hooks get values concat % + , + "io.backend" init-hooks get at [ \ flush , ] when + ] [ ] make "Boot quotation: " write dup . flush + set-boot-quot ; + +: retained-globals ( -- seq ) + [ + builtins , + io-backend , + + strip-dictionary? get [ + { + builtins + dictionary + inspector-hook + lexer-factory + load-vocab-hook + num-tags + num-types + tag-bits + tag-mask + tag-numbers + typemap + vocab-roots + } % + ] unless + + strip-prettyprint? get [ + { + tab-size + margin + } % + ] unless + + strip-c-types? get not deploy-ui? get or [ + "c-types" "alien.c-types" lookup , + ] when + + deploy-ui? get [ + "ui" child-vocabs + "cocoa" child-vocabs + deploy-vocab get child-vocabs 3append + global keys [ word? ] subset + swap [ >r word-vocabulary r> member? ] curry + subset % + ] when + ] { } make dup . ; + +: normalize-strip-flags + strip-prettyprint? get [ + strip-word-names? off + ] unless + strip-dictionary? get [ + strip-prettyprint? off + strip-word-names? off + strip-word-props? off + ] unless ; + +: strip ( -- ) + normalize-strip-flags + strip-cocoa + strip-debugger + strip-init-hooks + deploy-vocab get vocab-main set-boot-quot* + retained-props >r + retained-globals strip-environment + r> strip-words ; + +: (deploy) ( final-image vocab config -- ) + #! Does the actual work of a deployment in the slave + #! stage2 image + [ + [ + deploy-vocab set + parse-hook get >r + parse-hook off + deploy-vocab get require + r> [ call ] when* + strip + finish-deploy + ] [ + print-error flush 1 exit + ] recover + ] bind ; + +: do-deploy ( -- ) + "output-image" get + "deploy-vocab" get + "Deploying " write dup write "..." print + dup deploy-config dup . + (deploy) ; + +MAIN: do-deploy From e967f98afd1795aee1f0deb58ef06e02338d56a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:38:54 -0400 Subject: [PATCH 09/41] Update deploy.factor files --- extra/bunny/deploy.factor | 2 +- extra/color-picker/deploy.factor | 2 +- extra/factory/deploy.factor | 2 +- extra/gesture-logger/deploy.factor | 2 +- extra/golden-section/deploy.factor | 2 +- extra/hello-ui/deploy.factor | 2 +- extra/hello-world/deploy.factor | 2 +- extra/maze/deploy.factor | 2 +- extra/nehe/deploy.factor | 2 +- extra/tetris/deploy.factor | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index b94a1deea0..889bae3d12 100644 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor index f3426fb503..ebce45177b 100644 --- a/extra/color-picker/deploy.factor +++ b/extra/color-picker/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/factory/deploy.factor b/extra/factory/deploy.factor index f7f40266d0..84dd43b7e1 100644 --- a/extra/factory/deploy.factor +++ b/extra/factory/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-globals? f } { strip-word-props? f } diff --git a/extra/gesture-logger/deploy.factor b/extra/gesture-logger/deploy.factor index a4531a9e8e..5e412987f0 100644 --- a/extra/gesture-logger/deploy.factor +++ b/extra/gesture-logger/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? f } diff --git a/extra/golden-section/deploy.factor b/extra/golden-section/deploy.factor index 733ba5cadd..318d03ee4c 100644 --- a/extra/golden-section/deploy.factor +++ b/extra/golden-section/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 9e21e5ba8a..db728d1eda 100644 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index f039c5f0a1..1fa0e20503 100644 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor index a85c82de7f..31818c30c3 100644 --- a/extra/maze/deploy.factor +++ b/extra/maze/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? f } diff --git a/extra/nehe/deploy.factor b/extra/nehe/deploy.factor index 4a3c7efd80..b464d735ce 100644 --- a/extra/nehe/deploy.factor +++ b/extra/nehe/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor index b73b99ee7e..61fd0a545c 100644 --- a/extra/tetris/deploy.factor +++ b/extra/tetris/deploy.factor @@ -1,4 +1,4 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; V{ { strip-word-props? t } { strip-word-names? t } From 5fdee1a6112b970afd232fb0ede9f5faa053f015 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:39:59 -0400 Subject: [PATCH 10/41] Less consing of quotations --- extra/cocoa/messages/messages.factor | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index c1543868e1..83f7217615 100644 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -3,7 +3,8 @@ USING: alien alien.c-types alien.compiler arrays assocs combinators compiler inference.transforms kernel math namespaces parser prettyprint prettyprint.sections -quotations sequences strings words cocoa.runtime io macros ; +quotations sequences strings words cocoa.runtime io macros +memoize ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -20,10 +21,8 @@ IN: cocoa.messages SYMBOL: message-senders SYMBOL: super-message-senders -global [ - message-senders [ H{ } assoc-like ] change - super-message-senders [ H{ } assoc-like ] change -] bind +message-senders global [ H{ } assoc-like ] change-at +super-message-senders global [ H{ } assoc-like ] change-at : cache-stub ( method function hash -- ) [ @@ -56,14 +55,14 @@ TUPLE: selector name object ; SYMBOL: selectors -H{ } clone selectors set-global +selectors global [ H{ } assoc-like ] change-at : cache-selector ( string -- selector ) selectors get-global [ ] cache ; SYMBOL: objc-methods -H{ } clone objc-methods set-global +objc-methods global [ H{ } assoc-like ] change-at : lookup-method ( selector -- method ) dup objc-methods get at @@ -74,7 +73,7 @@ H{ } clone objc-methods set-global \ >r >quotation -rot \ r> >quotation 3append ; -: make-prepare-send ( selector method super? -- quot ) +MEMO: make-prepare-send ( selector method super? -- quot ) [ [ \ , ] when swap cache-selector , \ selector , @@ -82,11 +81,10 @@ H{ } clone objc-methods set-global swap second length 2 - make-dip ; MACRO: (send) ( selector super? -- quot ) - [ - >r dup lookup-method r> - [ make-prepare-send % ] 2keep - super-message-senders message-senders ? get at , - ] [ ] make ; + >r dup lookup-method r> + [ make-prepare-send ] 2keep + super-message-senders message-senders ? get at + [ slip execute ] 2curry ; : send ( args... receiver selector -- return... ) f (send) ; inline From f06bca825aec8c9af621eedc8e701f1b2c1ca7e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:40:46 -0400 Subject: [PATCH 11/41] Update stage2 bootstrap --- core/bootstrap/stage2.factor | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 298e905595..728c4d44f6 100644 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -29,6 +29,13 @@ IN: bootstrap.stage2 wince? [ "windows.ce" require ] when winnt? [ "windows.nt" require ] when + "deploy-vocab" get [ + "stage2: deployment mode" print + ] [ + "listener" require + "none" require + ] if + [ ! Compile everything if compiler is loaded all-words [ changed-word ] each @@ -54,11 +61,8 @@ IN: bootstrap.stage2 f error-continuation set-global "deploy-vocab" get [ - "tools.deploy" run + "tools.deploy.shaker" run ] [ - "listener" require - "none" require - [ boot do-init-hooks From 8e985d6c6f31e58e488e5bbcf5a96ad08ec6a2c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 13:55:22 -0400 Subject: [PATCH 12/41] Units unit test fix --- extra/units/units-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 72c3b108ea..28ab9ab7c4 100644 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -1,5 +1,5 @@ USING: arrays kernel math sequences tools.test units.si -units.imperial units inverse ; +units.imperial units inverse math.functions ; IN: temporary [ T{ dimensioned f 3 { m } { } } ] [ 3 m ] unit-test From d86d83fdbb4cf3a1c4df503914ca5cd1c19c1624 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 17:09:15 -0400 Subject: [PATCH 13/41] Fix mod-inv --- core/math/functions/functions-tests.factor | 2 ++ core/math/functions/functions.factor | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/core/math/functions/functions-tests.factor b/core/math/functions/functions-tests.factor index 17104e7d89..16bd8c809e 100644 --- a/core/math/functions/functions-tests.factor +++ b/core/math/functions/functions-tests.factor @@ -72,3 +72,5 @@ IN: temporary [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test + +[ 2 10 mod-inv ] unit-test-fails diff --git a/core/math/functions/functions.factor b/core/math/functions/functions.factor index b0f81d4584..c0bcd35551 100644 --- a/core/math/functions/functions.factor +++ b/core/math/functions/functions.factor @@ -50,7 +50,7 @@ M: integer (^) tuck gcd 1 = [ dup 0 < [ + ] [ nip ] if ] [ - [ "Non-trivial divisor found" throw ] unless + "Non-trivial divisor found" throw ] if ; foldable : ^mod ( x y n -- z ) From b23e109447fcd70a826496f7683c62267468d22b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 18:09:22 -0400 Subject: [PATCH 14/41] Clean up Windows support --- Makefile | 2 +- core/cpu/x86/architecture/architecture.factor | 1 + vm/Config.unix | 4 ---- vm/cpu-x86.32.S | 3 --- vm/cpu-x86.64.S | 3 --- vm/cpu-x86.S | 12 ++++-------- 6 files changed, 6 insertions(+), 19 deletions(-) diff --git a/Makefile b/Makefile index 378f96deae..11563a0698 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 $(SITE_CFLAGS) + CFLAGS += -O3 -fomit-frame-pointer $(SITE_CFLAGS) endif ifdef CONFIG diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 0309df052b..1ca4fe032a 100644 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -66,6 +66,7 @@ M: x86-backend %prepare-alien-invoke #! all roots. "stack_chain" f temp-reg v>operand %alien-global temp-reg v>operand [] stack-reg MOV + temp-reg v>operand [] cell SUB temp-reg v>operand 2 cells [+] ds-reg MOV temp-reg v>operand 3 cells [+] rs-reg MOV ; diff --git a/vm/Config.unix b/vm/Config.unix index bcea3aef77..831b3378d8 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -1,7 +1,3 @@ -#ifndef DEBUG -C_FLAGS += -fomit-frame-pointer -#endif - EXE_SUFFIX = DLL_PREFIX = lib DLL_EXTENSION = .a diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 0e144c5a11..6233b4a14f 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -44,6 +44,3 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ #include "cpu-x86.S" - -.section .drectve -.ascii " -export:set_callstack" diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 55792cc205..4e8faa18de 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -36,6 +36,3 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi ret /* return _with new stack_ */ #include "cpu-x86.S" - -.section .drectve -.ascii " -export:set_callstack" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 6096f034f0..e912c65df6 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -64,11 +64,7 @@ DEF(FASTCALL void,lazy_jit_compile,(CELL quot)): pop XT_REG JUMP_QUOT /* Call the quotation */ -.section .drectve -.ascii " -export:c_to_factor" -.ascii " -export:undefined" -.ascii " -export:docol_profiling" -.ascii " -export:primitive_call" -.ascii " -export:primitive_execute" -.ascii " -export:throw_impl" -.ascii " -export:lazy_jit_compile" +#ifdef WINDOWS + .section .drectve + .ascii " -export:c_to_factor" +#endif From e92567537798735fda2fcf049ff2858a3dc4eef1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 18:54:46 -0400 Subject: [PATCH 15/41] x86 backend fixes --- core/cpu/x86/32/bootstrap.factor | 1 - core/cpu/x86/64/bootstrap.factor | 1 - core/cpu/x86/bootstrap.factor | 4 ++-- 3 files changed, 2 insertions(+), 4 deletions(-) diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 289ae0c213..32d07797e7 100644 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -13,6 +13,5 @@ IN: bootstrap.x86 : scan-reg EBX ; : xt-reg ECX ; : fixnum>slot@ arg0 1 SAR ; -: next-frame@ -44 ; "resource:core/cpu/x86/bootstrap.factor" run-file diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index 00db1ac119..9d3fa8849f 100644 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -13,6 +13,5 @@ IN: bootstrap.x86 : scan-reg RBX ; : xt-reg RCX ; : fixnum>slot@ ; -: next-frame@ -88 ; "resource:core/cpu/x86/bootstrap.factor" run-file diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index a8c1b9a8f2..5976c86d58 100644 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -8,10 +8,10 @@ big-endian off 1 jit-code-format set -: scan-save stack-reg 3 bootstrap-cells [+] ; - : stack-frame-size 8 bootstrap-cells ; +: scan-save stack-reg stack-frame-size 3 bootstrap-cells - [+] ; + [ arg0 arg0 quot-array@ [+] MOV ! load array scan-reg arg0 scan@ [+] LEA ! initialize scan pointer From 1f3ca10e8e8cd9a8cd05817eab8538345c5685dc Mon Sep 17 00:00:00 2001 From: Slava Date: Sat, 6 Oct 2007 20:58:33 -0400 Subject: [PATCH 16/41] Improve FEP callstack display --- vm/debug.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/vm/debug.c b/vm/debug.c index 07c67422c7..bd71960754 100644 --- a/vm/debug.c +++ b/vm/debug.c @@ -102,6 +102,8 @@ void print_stack_frame(F_STACK_FRAME *frame) { print_obj(frame_executing(frame)); printf("\n"); + print_obj(frame_scan(frame)); + printf("\n"); } void print_callstack(void) From 20d81509dfc387b144218bf68a4a8f173577e539 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 20:16:34 -0400 Subject: [PATCH 17/41] Another x86 fix --- core/cpu/x86/bootstrap.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 5976c86d58..8e371ee823 100644 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -10,7 +10,7 @@ big-endian off : stack-frame-size 8 bootstrap-cells ; -: scan-save stack-reg stack-frame-size 3 bootstrap-cells - [+] ; +: scan-save stack-reg 3 bootstrap-cells [+] ; [ arg0 arg0 quot-array@ [+] MOV ! load array @@ -79,9 +79,9 @@ big-endian off [ load-branch - stack-reg [] scan-reg MOV ! save scan pointer + scan-save scan-reg MOV ! save scan pointer xt-reg CALL ! call quotation - scan-reg stack-reg [] MOV ! restore scan pointer + scan-reg scan-save MOV ! restore scan pointer ] { } make jit-if-call set [ From b07986d0d09fa125c7984f15134dac0c88392af2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 20:49:48 -0400 Subject: [PATCH 18/41] Once again, -fomit-frame-pointer on Windows is causing problems --- Makefile | 2 +- vm/Config.unix | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 11563a0698..378f96deae 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,7 @@ CFLAGS = -Wall ifdef DEBUG CFLAGS += -g else - CFLAGS += -O3 -fomit-frame-pointer $(SITE_CFLAGS) + CFLAGS += -O3 $(SITE_CFLAGS) endif ifdef CONFIG diff --git a/vm/Config.unix b/vm/Config.unix index 831b3378d8..6400f4782d 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -1,3 +1,7 @@ +#ifndef DEBUG + C_FLAGS += -fomit-frame-pointer +#endif + EXE_SUFFIX = DLL_PREFIX = lib DLL_EXTENSION = .a From 038cbed6e6ed890573347bdc46a507762afef00a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 22:52:55 -0400 Subject: [PATCH 19/41] Inhibit assignment re-ordering --- vm/callstack.c | 5 +++++ vm/callstack.h | 2 ++ vm/primitives.h | 9 ++++++--- 3 files changed, 13 insertions(+), 3 deletions(-) diff --git a/vm/callstack.c b/vm/callstack.c index 901b1bbb0b..271c7d9aa1 100644 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -6,6 +6,11 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) stack_chain->callstack_bottom = callstack_bottom; } +__attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top) +{ + stack_chain->callstack_top = callstack_top; +} + void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator) { F_STACK_FRAME *frame = (F_STACK_FRAME *)bottom - 1; diff --git a/vm/callstack.h b/vm/callstack.h index 4d1dac9ffd..ff68a8ba26 100644 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -1,4 +1,5 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); +__attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) @@ -8,6 +9,7 @@ void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator); void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame); CELL frame_executing(F_STACK_FRAME *frame); +CELL frame_scan(F_STACK_FRAME *frame); CELL frame_type(F_STACK_FRAME *frame); DECLARE_PRIMITIVE(callstack); diff --git a/vm/primitives.h b/vm/primitives.h index 2c0040f13f..811b473acd 100644 --- a/vm/primitives.h +++ b/vm/primitives.h @@ -16,19 +16,22 @@ Becomes F_FASTCALL void primitive_name(CELL word, F_STACK_FRAME *callstack_top) { - stack_chain->callstack_top = callstack_top; + save_callstack_top(callstack_top); ... CODE ... } On x86, F_FASTCALL expands into a GCC declaration which forces the two parameters to be passed in registers. This simplifies the quotation compiler -and support code in cpu-x86.S. */ +and support code in cpu-x86.S. + +We do the assignment of stack_chain->callstack_top in a ``noinline'' function +to inhibit assignment re-ordering. */ #define DEFINE_PRIMITIVE(name) \ INLINE void primitive_##name##_impl(void); \ \ F_FASTCALL void primitive_##name(CELL word, F_STACK_FRAME *callstack_top) \ { \ - stack_chain->callstack_top = callstack_top; \ + save_callstack_top(callstack_top); \ primitive_##name##_impl(); \ } \ \ From 37e591e12f339f620973ad9a0a140830139a8266 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 23:01:41 -0400 Subject: [PATCH 20/41] Use F_FASTCALL for save_callstack_top --- vm/callstack.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/callstack.c b/vm/callstack.c index 271c7d9aa1..5c3ab0ea79 100644 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -6,7 +6,7 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom) stack_chain->callstack_bottom = callstack_bottom; } -__attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top) +F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top) { stack_chain->callstack_top = callstack_top; } From 7b12b5e649f2b16751e11742c165650a46d1c17a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 23:12:52 -0400 Subject: [PATCH 21/41] VM fixes --- vm/callstack.h | 2 +- vm/os-windows-nt.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/callstack.h b/vm/callstack.h index ff68a8ba26..564dea9738 100644 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -1,5 +1,5 @@ F_FASTCALL void save_callstack_bottom(F_STACK_FRAME *callstack_bottom); -__attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top); +F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *callstack_top); #define FIRST_STACK_FRAME(stack) (F_STACK_FRAME *)((stack) + 1) diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index 8f7513a32a..f6aa314819 100644 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -29,7 +29,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) CONTEXT *c = (CONTEXT*)pe->ContextRecord; if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void*)c->Esp; + signal_callstack_top = (void *)(c->Esp - CELLS); else signal_callstack_top = NULL; From 2b13c74dfa79bb9a968a2bf859f2d53e27628754 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 23:26:43 -0400 Subject: [PATCH 22/41] Third time lucky --- vm/callstack.c | 10 ++++++++++ vm/callstack.h | 1 + vm/errors.c | 7 ++++++- vm/os-windows-nt.c | 2 +- 4 files changed, 18 insertions(+), 2 deletions(-) diff --git a/vm/callstack.c b/vm/callstack.c index 5c3ab0ea79..4461d39b1c 100644 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -40,6 +40,16 @@ F_CALLSTACK *allot_callstack(CELL size) return callstack; } +F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom) +{ + F_STACK_FRAME *frame = bottom - 1; + + while(frame >= top) + frame = frame_successor(frame); + + return frame + 1; +} + /* We ignore the topmost frame, the one calling 'callstack', so that set-callstack doesn't get stuck in an infinite loop. diff --git a/vm/callstack.h b/vm/callstack.h index 564dea9738..4033820184 100644 --- a/vm/callstack.h +++ b/vm/callstack.h @@ -5,6 +5,7 @@ F_FASTCALL __attribute__((noinline)) void save_callstack_top(F_STACK_FRAME *call typedef void (*CALLSTACK_ITER)(F_STACK_FRAME *frame); +F_STACK_FRAME *fix_callstack_top(F_STACK_FRAME *top, F_STACK_FRAME *bottom); void iterate_callstack(CELL top, CELL bottom, CALLSTACK_ITER iterator); void iterate_callstack_object(F_CALLSTACK *stack, CALLSTACK_ITER iterator); F_STACK_FRAME *frame_successor(F_STACK_FRAME *frame); diff --git a/vm/errors.c b/vm/errors.c index b8f7a2c52a..27663f1193 100644 --- a/vm/errors.c +++ b/vm/errors.c @@ -35,7 +35,12 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) Errors thrown from Factor code, or signal handlers, pass the actual stack pointer at the time, since the saved pointer is not necessarily up to date at that point. */ - if(!callstack_top) + if(callstack_top) + { + callstack_top = fix_callstack_top( + stack_chain->callstack_bottom,callstack_top); + } + else callstack_top = stack_chain->callstack_top; throw_impl(userenv[BREAK_ENV],callstack_top); diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index f6aa314819..9a54b895b8 100644 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -29,7 +29,7 @@ long exception_handler(PEXCEPTION_POINTERS pe) CONTEXT *c = (CONTEXT*)pe->ContextRecord; if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void *)(c->Esp - CELLS); + signal_callstack_top = (void *)c->Esp; else signal_callstack_top = NULL; From ba6648f526bf2bfb2c8b95a76599d85ee56664dc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Oct 2007 23:47:06 -0400 Subject: [PATCH 23/41] Fix argument order issue --- vm/errors.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/errors.c b/vm/errors.c index 27663f1193..1472283c51 100644 --- a/vm/errors.c +++ b/vm/errors.c @@ -37,8 +37,8 @@ void throw_error(CELL error, F_STACK_FRAME *callstack_top) not necessarily up to date at that point. */ if(callstack_top) { - callstack_top = fix_callstack_top( - stack_chain->callstack_bottom,callstack_top); + callstack_top = fix_callstack_top(callstack_top, + stack_chain->callstack_bottom); } else callstack_top = stack_chain->callstack_top; From 8be253c47fed9439c70b962b10fec5580f1704a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Oct 2007 23:01:26 -0500 Subject: [PATCH 24/41] Fix RSA Fix crypto unit tests --- extra/crypto/{ => rc4}/rc4.factor | 25 +++++---- extra/crypto/rsa.factor | 26 ---------- extra/crypto/rsa/rsa-tests.factor | 2 +- extra/crypto/rsa/rsa.factor | 52 ++++++++++++------- extra/crypto/test/rsa.factor | 7 --- extra/crypto/xor.factor | 9 ---- .../{test/xor.factor => xor/xor-tests.factor} | 5 +- extra/crypto/xor/xor.factor | 8 +++ 8 files changed, 60 insertions(+), 74 deletions(-) rename extra/crypto/{ => rc4}/rc4.factor (66%) delete mode 100644 extra/crypto/rsa.factor delete mode 100644 extra/crypto/test/rsa.factor delete mode 100644 extra/crypto/xor.factor rename extra/crypto/{test/xor.factor => xor/xor-tests.factor} (85%) create mode 100644 extra/crypto/xor/xor.factor diff --git a/extra/crypto/rc4.factor b/extra/crypto/rc4/rc4.factor similarity index 66% rename from extra/crypto/rc4.factor rename to extra/crypto/rc4/rc4.factor index 24f523189f..b730c4b7fe 100644 --- a/extra/crypto/rc4.factor +++ b/extra/crypto/rc4/rc4.factor @@ -1,23 +1,24 @@ -USING: kernel math sequences namespaces math-contrib ; -IN: crypto-internals +USING: kernel math sequences namespaces ; +IN: crypto.rc4 ! http://en.wikipedia.org/wiki/RC4_%28cipher%29 + : rc4 ( key -- ) - [ key set ] keep - length l set - ksa - 0 i set - 0 j set ; + [ + [ key set ] keep + length l set + ksa + 0 i set + 0 j set + ] with-scope ; diff --git a/extra/crypto/rsa.factor b/extra/crypto/rsa.factor deleted file mode 100644 index e082e431fa..0000000000 --- a/extra/crypto/rsa.factor +++ /dev/null @@ -1,26 +0,0 @@ -USING: kernel math namespaces math-contrib errors ; - -IN: crypto -SYMBOL: d -SYMBOL: p -SYMBOL: q -SYMBOL: n -SYMBOL: m -SYMBOL: ee - -! e = public key, d = private key, n = public modulus -TUPLE: rsa e d n ; - -! n bits -: generate-rsa-keypair ( bitlen -- ) - [ - 2 /i generate-two-unique-primes [ q set p set ] 2keep [ * n set ] 2keep - [ 1- ] 2apply * m set - 65537 ee set - m get ee get mod-inv m get + d set - ee get d get n get - ] with-scope ; - -: rsa-encrypt ( message rsa -- encrypted ) [ rsa-e ] keep rsa-n ^mod ; -: rsa-decrypt ( encrypted rsa -- message ) [ rsa-d ] keep rsa-n ^mod ; - diff --git a/extra/crypto/rsa/rsa-tests.factor b/extra/crypto/rsa/rsa-tests.factor index 10ff28a8b8..7de6bed76f 100644 --- a/extra/crypto/rsa/rsa-tests.factor +++ b/extra/crypto/rsa/rsa-tests.factor @@ -3,5 +3,5 @@ USING: kernel math namespaces crypto.rsa tools.test ; [ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test [ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test [ 123456789 ] [ 130 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test -[ 123 ] [ 17 2753 3233 123 over rsa-encrypt swap rsa-decrypt ] unit-test +[ 123 ] [ 3233 2753 17 123 over rsa-encrypt swap rsa-decrypt ] unit-test diff --git a/extra/crypto/rsa/rsa.factor b/extra/crypto/rsa/rsa.factor index ad5822b24c..ffb2a64b76 100644 --- a/extra/crypto/rsa/rsa.factor +++ b/extra/crypto/rsa/rsa.factor @@ -2,28 +2,44 @@ USING: math.miller-rabin kernel math math.functions namespaces sequences ; IN: crypto.rsa -SYMBOL: d -SYMBOL: p -SYMBOL: q -SYMBOL: n -SYMBOL: m -SYMBOL: ee +! The private key is the only secret. -! e = public key, d = private key, n = public modulus -TUPLE: rsa e d n ; +! p,q are two random primes of numbits/2 +! phi = (p-1)(q-1) +! modulus = p*q +! public = 65537 +! private = public modinv phi + +TUPLE: rsa modulus private-key public-key ; C: rsa -! n bits + + : generate-rsa-keypair ( numbits -- ) - [ - 2 /i 2 unique-primes first2 [ q set p set ] 2keep [ * n set ] 2keep - [ 1- ] 2apply * m set - 65537 ee set - m get ee get mod-inv m get + d set - ee get d get n get - ] with-scope ; + modulus-phi + public-key over mod-inv + + public-key ; -: rsa-encrypt ( message rsa -- encrypted ) [ rsa-e ] keep rsa-n ^mod ; -: rsa-decrypt ( encrypted rsa -- message ) [ rsa-d ] keep rsa-n ^mod ; +: rsa-encrypt ( message rsa -- encrypted ) + [ rsa-public-key ] keep rsa-modulus ^mod ; +: rsa-decrypt ( encrypted rsa -- message ) + [ rsa-private-key ] keep rsa-modulus ^mod ; \ No newline at end of file diff --git a/extra/crypto/test/rsa.factor b/extra/crypto/test/rsa.factor deleted file mode 100644 index cddad58897..0000000000 --- a/extra/crypto/test/rsa.factor +++ /dev/null @@ -1,7 +0,0 @@ -USING: kernel math test namespaces crypto ; - -[ 123456789 ] [ 128 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test -[ 123456789 ] [ 129 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test -[ 123456789 ] [ 130 generate-rsa-keypair 123456789 over rsa-encrypt swap rsa-decrypt ] unit-test -[ 123 ] [ 17 2753 3233 123 over rsa-encrypt swap rsa-decrypt ] unit-test - diff --git a/extra/crypto/xor.factor b/extra/crypto/xor.factor deleted file mode 100644 index a2b3161d4b..0000000000 --- a/extra/crypto/xor.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: errors kernel math sequences ; -IN: crypto - -TUPLE: no-xor-key ; - -: xor-crypt ( key seq -- seq ) - over empty? [ throw ] when - [ length ] keep - [ >r over mod-nth r> bitxor ] 2map nip ; diff --git a/extra/crypto/test/xor.factor b/extra/crypto/xor/xor-tests.factor similarity index 85% rename from extra/crypto/test/xor.factor rename to extra/crypto/xor/xor-tests.factor index 2a77cf0e64..a0b764cc03 100644 --- a/extra/crypto/test/xor.factor +++ b/extra/crypto/xor/xor-tests.factor @@ -1,4 +1,5 @@ -USING: crypto errors kernel test strings ; +USING: continuations crypto.xor kernel strings tools.test ; +IN: temporary ! No key [ T{ no-xor-key f } ] [ [ "" dup xor-crypt ] catch ] unit-test @@ -7,7 +8,7 @@ USING: crypto errors kernel test strings ; [ T{ no-xor-key f } ] [ [ "" "asdf" dupd xor-crypt xor-crypt ] catch ] unit-test ! a xor a = 0 -[ { 0 0 0 0 0 0 0 } ] [ "abcdefg" dup xor-crypt ] unit-test +[ "\0\0\0\0\0\0\0" ] [ "abcdefg" dup xor-crypt ] unit-test [ { 15 15 15 15 } ] [ { 10 10 10 10 } { 5 5 5 5 } xor-crypt ] unit-test diff --git a/extra/crypto/xor/xor.factor b/extra/crypto/xor/xor.factor new file mode 100644 index 0000000000..0713e19843 --- /dev/null +++ b/extra/crypto/xor/xor.factor @@ -0,0 +1,8 @@ +USING: crypto.common kernel math sequences ; +IN: crypto.xor + +TUPLE: no-xor-key ; + +: xor-crypt ( key seq -- seq ) + over empty? [ no-xor-key construct-empty throw ] when + dup length rot [ mod-nth bitxor ] curry 2map ; From 3ea8227d6cdf2e2d2f0e5189cc965f752c9ee7de Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 6 Oct 2007 23:05:06 -0500 Subject: [PATCH 25/41] PPC images do not follow the 32/64 bit naming convention wget the windows dlls on windows nt --- misc/install.sh | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/misc/install.sh b/misc/install.sh index 10c0bfc0df..baf05192ec 100755 --- a/misc/install.sh +++ b/misc/install.sh @@ -5,7 +5,7 @@ set +e # Case insensitive string comparison shopt -s nocaseglob -shopt -s nocasematch +#shopt -s nocasematch ensure_program_installed() { echo -n "Checking for $1..." @@ -47,7 +47,9 @@ case $uname_s in *CYGWIN_NT*) OS=windows-nt;; *CYGWIN*) OS=windows-nt;; *darwin*) OS=macosx;; + *Darwin*) OS=macosx;; *linux*) OS=linux;; + *Linux*) OS=linux;; esac # Architecture @@ -107,4 +109,12 @@ rm $BOOT_IMAGE.* > /dev/null 2>&1 wget http://factorcode.org/images/latest/$BOOT_IMAGE check_ret wget +if [[ $OS == windows-nt ]] ; then + wget http://factorcode.org/dlls/freetype6.dll + check_ret + wget http://factorcode.org/dlls/zlib1.dla + check_ret +fi + + ./$FACTOR_BINARY -i=$BOOT_IMAGE From 3d1c3b95737caa83dc5632506c6e9d3917c92ee1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Oct 2007 00:12:02 -0400 Subject: [PATCH 26/41] Hardcore unit tests added --- core/kernel/kernel-tests.factor | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index a2bb8307de..ecc1b1c19a 100644 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -1,6 +1,6 @@ USING: arrays byte-arrays kernel kernel.private math memory namespaces sequences tools.test math.private quotations -continuations prettyprint io.streams.string ; +continuations prettyprint io.streams.string debugger ; IN: temporary [ 0 ] [ f size ] unit-test @@ -15,19 +15,36 @@ IN: temporary [ { "kernel-error" 11 f f } ] [ [ clear drop ] catch ] unit-test +[ ] [ :c ] unit-test + [ { "kernel-error" 13 f f } ] [ [ { } set-retainstack r> ] catch ] unit-test +[ ] [ :c ] unit-test + : overflow-d 3 overflow-d ; [ { "kernel-error" 12 f f } ] [ [ overflow-d ] catch ] unit-test +[ ] [ :c ] unit-test + +: (overflow-d-alt) 3 ; + +: overflow-d-alt (overflow-d-alt) overflow-d-alt ; + +[ { "kernel-error" 12 f f } ] +[ [ overflow-d-alt ] catch ] unit-test + +[ ] [ [ :c ] string-out drop ] unit-test + : overflow-r 3 >r overflow-r ; [ { "kernel-error" 14 f f } ] [ [ overflow-r ] catch ] unit-test +[ ] [ :c ] unit-test + ! : overflow-c overflow-c 3 ; ! ! [ { "kernel-error" 16 f f } ] @@ -45,9 +62,17 @@ IN: temporary [ 6 ] [ f 6 or ] unit-test [ slip ] unit-test-fails +[ ] [ :c ] unit-test + [ 1 slip ] unit-test-fails +[ ] [ :c ] unit-test + [ 1 2 slip ] unit-test-fails +[ ] [ :c ] unit-test + [ 1 2 3 slip ] unit-test-fails +[ ] [ :c ] unit-test + [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test @@ -76,3 +101,4 @@ IN: temporary [ ] [ callstack set-callstack ] unit-test [ 3drop datastack ] unit-test-fails +[ ] [ :c ] unit-test From 17a807176841ee66ed9a6271ccb3c461903a0522 Mon Sep 17 00:00:00 2001 From: "U-C4\\Administrator" Date: Sat, 6 Oct 2007 23:50:13 -0500 Subject: [PATCH 27/41] Fix a stack effect in sockets Fix unit tests --- extra/io/windows/nt/sockets/sockets.factor | 3 +-- extra/io/windows/windows-tests.factor | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) mode change 100644 => 100755 extra/io/windows/windows-tests.factor diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 181732089d..28df61eb27 100644 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -48,7 +48,7 @@ TUPLE: ConnectEx-args port : check-connect-error ( ConnectEx -- ) ConnectEx-args-port duplex-stream-in get-overlapped-result drop ; -: connect-continuation ( duplex-stream ConnectEx -- ) +: connect-continuation ( ConnectEx -- ) [ ConnectEx-args-port duplex-stream-in save-callback ] keep check-connect-error ; @@ -154,7 +154,6 @@ M: windows-nt-io ( addrspec -- server ) ] keep ] with-destructors ; - M: windows-nt-io ( addrspec -- datagram ) [ [ diff --git a/extra/io/windows/windows-tests.factor b/extra/io/windows/windows-tests.factor old mode 100644 new mode 100755 index 09c043cc68..3c3684ad3c --- a/extra/io/windows/windows-tests.factor +++ b/extra/io/windows/windows-tests.factor @@ -1,4 +1,4 @@ -USING: kernel ; +USING: io.files kernel tools.test ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-dir ] unit-test From 806e5d19d9a43e832e3e0db06ac881c5bc22a3cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Oct 2007 18:15:48 -0400 Subject: [PATCH 28/41] Add unit test --- core/sbufs/sbufs-tests.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/core/sbufs/sbufs-tests.factor b/core/sbufs/sbufs-tests.factor index c0b03b7076..b8d5b3e3fc 100644 --- a/core/sbufs/sbufs-tests.factor +++ b/core/sbufs/sbufs-tests.factor @@ -1,5 +1,5 @@ USING: kernel math namespaces sequences sbufs strings -tools.test ; +tools.test classes ; IN: temporary [ 5 ] [ "Hello" >sbuf length ] unit-test @@ -18,3 +18,7 @@ IN: temporary ] unit-test [ SBUF" x" ] [ 1 CHAR: x >bignum over push ] unit-test + +[ fixnum ] [ 1 >bignum SBUF" " new length class ] unit-test + +[ fixnum ] [ 1 >bignum [ ] SBUF" " map-as length class ] unit-test From 554507cf008309fef40dc26c3dd0249c86feb3d7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Oct 2007 18:16:17 -0400 Subject: [PATCH 29/41] Found another place to use MEMO: in extra/cocoa --- extra/cocoa/messages/messages.factor | 11 ++--------- 1 file changed, 2 insertions(+), 9 deletions(-) diff --git a/extra/cocoa/messages/messages.factor b/extra/cocoa/messages/messages.factor index 83f7217615..91c4262312 100644 --- a/extra/cocoa/messages/messages.factor +++ b/extra/cocoa/messages/messages.factor @@ -43,7 +43,7 @@ super-message-senders global [ H{ } assoc-like ] change-at TUPLE: selector name object ; -: ( name -- sel ) f \ selector construct-boa ; +MEMO: ( name -- sel ) f \ selector construct-boa ; : selector ( selector -- alien ) dup selector-object expired? [ @@ -53,13 +53,6 @@ TUPLE: selector name object ; selector-object ] if ; -SYMBOL: selectors - -selectors global [ H{ } assoc-like ] change-at - -: cache-selector ( string -- selector ) - selectors get-global [ ] cache ; - SYMBOL: objc-methods objc-methods global [ H{ } assoc-like ] change-at @@ -76,7 +69,7 @@ objc-methods global [ H{ } assoc-like ] change-at MEMO: make-prepare-send ( selector method super? -- quot ) [ [ \ , ] when - swap cache-selector , \ selector , + swap , \ selector , ] [ ] make swap second length 2 - make-dip ; From d7c6ead7ee53b5e41ba947ae47f92cb6067da4fe Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 7 Oct 2007 18:17:14 -0400 Subject: [PATCH 30/41] Fix walker bug and implement step-into for quotations --- core/continuations/continuations.factor | 1 + extra/ui/tools/walker/walker-tests.factor | 17 ++++++++++++++++- extra/ui/tools/walker/walker.factor | 4 +++- 3 files changed, 20 insertions(+), 2 deletions(-) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 5d23cd734b..f7349855dd 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -197,3 +197,4 @@ GENERIC: (step-into) ( obj -- ) M: wrapper (step-into) wrapped break ; M: object (step-into) break ; +M: callable (step-into) \ break add* break ; diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index 50da02262b..7ca8b8f2e9 100644 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -1,7 +1,8 @@ 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 ; +ui.gadgets.packs vectors ui.tools tools.interpreter +tools.interpreter.debug ; IN: temporary [ ] [ "walker" set ] unit-test @@ -51,3 +52,17 @@ IN: temporary swap second \ inspect eq? and ] unit-test ] with-scope + +[ + f 2array 1vector windows set + + [ ] [ + [ 2 3 break 4 ] quot>cont f swap 2array walker call-tool + ] unit-test + + [ ] [ walker get-tool com-continue ] unit-test + + [ ] [ yield ] unit-test + + [ t ] [ walker get-tool walker-active? ] unit-test +] with-scope diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 40138cc50d..2ec4cd7dd6 100644 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -65,7 +65,9 @@ M: walker call-tool* ( continuation walker -- ) ] if ; : com-continue ( walker -- ) - dup walker-interpreter step-all reset-walker ; + #! Reset walker first, in case step-all ends up calling + #! the walker again. + dup walker-interpreter swap reset-walker step-all ; : walker-help "ui-walker" help-window ; From c67c694f2915a703a0072b150b693bdb51329451 Mon Sep 17 00:00:00 2001 From: Marie-Pascal Date: Mon, 8 Oct 2007 01:04:24 -0400 Subject: [PATCH 31/41] Fix typo --- vm/Config.unix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.unix b/vm/Config.unix index 6400f4782d..73934d7f41 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -1,5 +1,5 @@ #ifndef DEBUG - C_FLAGS += -fomit-frame-pointer + CFLAGS += -fomit-frame-pointer #endif EXE_SUFFIX = From 48304f53b5e08ed96b3630876e7db351050bc9f3 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 8 Oct 2007 14:51:47 -0500 Subject: [PATCH 32/41] combinators.lib: 2bi --- extra/combinators/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 1b69ae5509..9c46c129af 100644 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -28,6 +28,10 @@ IN: combinators.lib : tetra ( obj quot quot quot quot -- val val val val ) >r >r pick >r bi r> r> r> bi ; inline +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 0f8e62ee3a8e116ad274ca41365549624a69aeab Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 8 Oct 2007 14:52:54 -0500 Subject: [PATCH 33/41] Get some cfdg models to compile --- extra/cfdg/models/aqua-star/aqua-star.factor | 13 +++++++------ .../cfdg/models/game1-turn6/game1-turn6.factor | 17 ++++++++--------- extra/cfdg/models/snowflake/snowflake.factor | 4 ++-- 3 files changed, 17 insertions(+), 17 deletions(-) diff --git a/extra/cfdg/models/aqua-star/aqua-star.factor b/extra/cfdg/models/aqua-star/aqua-star.factor index ee42b9a370..062f10b292 100644 --- a/extra/cfdg/models/aqua-star/aqua-star.factor +++ b/extra/cfdg/models/aqua-star/aqua-star.factor @@ -6,12 +6,13 @@ IN: cfdg.models.aqua-star : tentacle ( -- ) iterate? [ - { [ circle - [ .23 y .99 s .002 b tentacle ] do ] - [ circle - [ .17 y 2 r .99 s .002 b tentacle ] do ] - [ circle - [ .12 y -2 r .99 s .001 b tentacle ] do ] } random call + { { 1 [ circle + [ .23 y .99 s .002 b tentacle ] do ] } + { 1 [ circle + [ .17 y 2 r .99 s .002 b tentacle ] do ] } + { 1 [ circle + [ .12 y -2 r .99 s .001 b tentacle ] do ] } } + call-random-weighted ] when ; : anemone ( -- ) diff --git a/extra/cfdg/models/game1-turn6/game1-turn6.factor b/extra/cfdg/models/game1-turn6/game1-turn6.factor index 6289c35985..c00f95233c 100644 --- a/extra/cfdg/models/game1-turn6/game1-turn6.factor +++ b/extra/cfdg/models/game1-turn6/game1-turn6.factor @@ -1,5 +1,4 @@ - USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate mortar random-weighted cfdg ; @@ -24,17 +23,17 @@ IN: cfdg.models.game1-turn6 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.022 [ [ 90 flip 50 hue start ] do ] } } -random-weighted* call + { { 1 [ f-squares + [ 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 ; : start ( -- ) -[ spiral ] do -[ 120 r spiral ] do -[ 240 r spiral ] do ; + [ spiral ] do + [ 120 r spiral ] do + [ 240 r spiral ] do ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/cfdg/models/snowflake/snowflake.factor b/extra/cfdg/models/snowflake/snowflake.factor index e42c297581..eb1936101a 100644 --- a/extra/cfdg/models/snowflake/snowflake.factor +++ b/extra/cfdg/models/snowflake/snowflake.factor @@ -11,8 +11,8 @@ iterate? [ { 0.03 [ square [ 60 r spike ] do [ -60 r spike ] do - [ 0.95 y 0.97 s spike ] do ] } - } random-weighted* call + [ 0.95 y 0.97 s spike ] do ] } } + call-random-weighted ] when ; : snowflake ( -- ) From e4eb181ab002511f9cf22e3aa05e2f6caa327e6b Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 8 Oct 2007 15:00:01 -0500 Subject: [PATCH 34/41] Add springies --- extra/springies/models/2snake/2snake.factor | 123 ++++++++++ extra/springies/models/ball/ball.factor | 255 ++++++++++++++++++++ extra/springies/springies.factor | 246 +++++++++++++++++++ extra/springies/ui/ui.factor | 61 +++++ 4 files changed, 685 insertions(+) create mode 100644 extra/springies/models/2snake/2snake.factor create mode 100644 extra/springies/models/ball/ball.factor create mode 100644 extra/springies/springies.factor create mode 100644 extra/springies/ui/ui.factor diff --git a/extra/springies/models/2snake/2snake.factor b/extra/springies/models/2snake/2snake.factor new file mode 100644 index 0000000000..cb772594e2 --- /dev/null +++ b/extra/springies/models/2snake/2snake.factor @@ -0,0 +1,123 @@ + +USING: kernel namespaces arrays sequences math math.vectors random + springies springies.ui ; + +IN: springies.models.2snake + +: model ( -- ) + +{ } clone >nodes +{ } clone >springs +0.001 >time-slice +gravity off + +1 19.0 328.0 0.0 0.0 1.0 1.0 mass +2 36.0 328.0 0.0 0.0 1.0 1.0 mass +3 54.0 328.0 0.0 0.0 1.0 1.0 mass +4 72.0 328.0 0.0 0.0 1.0 1.0 mass +5 90.0 328.0 0.0 0.0 1.0 1.0 mass +6 108.0 328.0 0.0 0.0 1.0 1.0 mass +7 126.0 328.0 0.0 0.0 1.0 1.0 mass +8 144.0 328.0 0.0 0.0 1.0 1.0 mass +9 162.0 328.0 0.0 0.0 1.0 1.0 mass +10 180.0 328.0 0.0 0.0 1.0 1.0 mass +11 198.0 328.0 0.0 0.0 1.0 1.0 mass +12 216.0 328.0 0.0 0.0 1.0 1.0 mass +13 234.0 328.0 0.0 0.0 1.0 1.0 mass +14 252.0 328.0 0.0 0.0 1.0 1.0 mass +15 270.0 328.0 0.0 0.0 1.0 1.0 mass +16 288.0 328.0 0.0 0.0 1.0 1.0 mass +17 306.0 328.0 0.0 0.0 1.0 1.0 mass +18 324.0 328.0 0.0 0.0 1.0 1.0 mass +19 342.0 328.0 0.0 0.0 1.0 1.0 mass +20 360.0 328.0 0.0 0.0 1.0 1.0 mass +21 378.0 328.0 0.0 0.0 1.0 1.0 mass +22 396.0 328.0 0.0 0.0 1.0 1.0 mass +23 414.0 328.0 0.0 0.0 1.0 1.0 mass +24 432.0 328.0 0.0 0.0 1.0 1.0 mass +25 450.0 328.0 0.0 0.0 1.0 1.0 mass +26 468.0 328.0 0.0 0.0 1.0 1.0 mass +27 504.0 328.0 0.0 0.0 1.0 1.0 mass +28 486.0 328.0 0.0 0.0 1.0 1.0 mass +29 522.0 328.0 0.0 0.0 1.0 1.0 mass +30 540.0 328.0 0.0 0.0 1.0 1.0 mass +31 558.0 328.0 0.0 0.0 1.0 1.0 mass +32 576.0 328.0 0.0 0.0 1.0 1.0 mass +33 594.0 328.0 0.0 0.0 1.0 1.0 mass +34 612.0 328.0 0.0 0.0 1.0 1.0 mass +35 630.0 328.0 0.0 0.0 1.0 1.0 mass +1 1 2 200.0 1.500000 18.0 spng +2 3 2 200.0 1.500000 18.0 spng +3 3 4 200.0 1.500000 18.0 spng +4 4 5 200.0 1.500000 18.0 spng +5 5 6 200.0 1.500000 18.0 spng +6 6 7 200.0 1.500000 18.0 spng +7 7 8 200.0 1.500000 18.0 spng +8 8 9 200.0 1.500000 18.0 spng +9 9 10 200.0 1.500000 18.0 spng +10 10 11 200.0 1.500000 18.0 spng +11 11 12 200.0 1.500000 18.0 spng +12 12 13 200.0 1.500000 18.0 spng +13 13 14 200.0 1.500000 18.0 spng +14 14 15 200.0 1.500000 18.0 spng +15 15 16 200.0 1.500000 18.0 spng +16 16 17 200.0 1.500000 18.0 spng +17 17 18 200.0 1.500000 18.0 spng +18 18 19 200.0 1.500000 18.0 spng +19 19 20 200.0 1.500000 18.0 spng +20 20 21 200.0 1.500000 18.0 spng +21 21 22 200.0 1.500000 18.0 spng +22 22 23 200.0 1.500000 18.0 spng +23 23 24 200.0 1.500000 18.0 spng +24 24 25 200.0 1.500000 18.0 spng +25 25 26 200.0 1.500000 18.0 spng +26 26 28 200.0 1.500000 18.0 spng +27 28 27 200.0 1.500000 18.0 spng +28 27 29 200.0 1.500000 18.0 spng +29 29 30 200.0 1.500000 18.0 spng +30 30 31 200.0 1.500000 18.0 spng +31 31 32 200.0 1.500000 18.0 spng +32 32 33 200.0 1.500000 18.0 spng +33 33 34 200.0 1.500000 18.0 spng +34 34 35 200.0 1.500000 18.0 spng +35 1 3 200.0 1.500000 36.0 spng +36 2 4 200.0 1.500000 36.0 spng +37 3 5 200.0 1.500000 36.0 spng +38 4 6 200.0 1.500000 36.0 spng +39 5 7 200.0 1.500000 36.0 spng +40 6 8 200.0 1.500000 36.0 spng +41 7 9 200.0 1.500000 36.0 spng +42 8 10 200.0 1.500000 36.0 spng +43 9 11 200.0 1.500000 36.0 spng +44 10 12 200.0 1.500000 36.0 spng +45 11 13 200.0 1.500000 36.0 spng +46 12 14 200.0 1.500000 36.0 spng +47 13 15 200.0 1.500000 36.0 spng +48 14 16 200.0 1.500000 36.0 spng +49 15 17 200.0 1.500000 36.0 spng +50 16 18 200.0 1.500000 36.0 spng +51 17 19 200.0 1.500000 36.0 spng +52 18 20 200.0 1.500000 36.0 spng +53 19 21 200.0 1.500000 36.0 spng +54 20 22 200.0 1.500000 36.0 spng +55 21 23 200.0 1.500000 36.0 spng +56 22 24 200.0 1.500000 36.0 spng +57 23 25 200.0 1.500000 36.0 spng +58 24 26 200.0 1.500000 36.0 spng +59 25 28 200.0 1.500000 36.0 spng +60 26 27 200.0 1.500000 36.0 spng +61 28 29 200.0 1.500000 36.0 spng +62 27 30 200.0 1.500000 36.0 spng +63 29 31 200.0 1.500000 36.0 spng +64 30 32 200.0 1.500000 36.0 spng +65 31 33 200.0 1.500000 36.0 spng +66 32 34 200.0 1.500000 36.0 spng +67 33 35 200.0 1.500000 36.0 spng + +nodes> [ 400 random -200 + 400 random -200 + 2array swap set-node-vel ] each ; + +USING: threads ui ; + +: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ; + +MAIN: go \ No newline at end of file diff --git a/extra/springies/models/ball/ball.factor b/extra/springies/models/ball/ball.factor new file mode 100644 index 0000000000..48314c9fb3 --- /dev/null +++ b/extra/springies/models/ball/ball.factor @@ -0,0 +1,255 @@ + +USING: kernel namespaces sequences springies springies.ui ; + +IN: springies.models.ball + +: model ( -- ) + +{ } clone >nodes +{ } clone >springs +0.01 >time-slice +gravity on + +1 325.191871 140.872641 40.832215 -5.301529 1.0 1.0 mass +2 313.933994 149.011616 55.240875 5.026852 1.0 1.0 mass +3 309.133386 162.523019 72.798059 5.594199 1.0 1.0 mass +4 312.887152 176.436760 83.754277 -1.370025 1.0 1.0 mass +5 321.660596 187.895952 91.634021 -8.308630 1.0 1.0 mass +6 335.256132 192.503856 94.772924 -18.985044 1.0 1.0 mass +7 348.254504 188.731936 92.657963 -29.982110 1.0 1.0 mass +8 359.050972 180.780059 86.668616 -39.817638 1.0 1.0 mass +9 363.685639 167.752177 76.554871 -47.987107 1.0 1.0 mass +10 360.449954 154.092353 57.992242 -48.045772 1.0 1.0 mass +11 352.201411 142.382665 41.200547 -39.924209 1.0 1.0 mass +12 338.754859 137.460615 32.306364 -22.707784 1.0 1.0 mass +13 312.911184 114.835962 8.342965 5.878311 1.0 1.0 mass +14 290.521818 132.872407 33.212103 28.391710 1.0 1.0 mass +15 281.048450 160.314206 66.319674 32.935324 1.0 1.0 mass +16 287.450075 188.730522 93.898071 21.966741 1.0 1.0 mass +17 305.987715 211.206959 112.571044 5.089593 1.0 1.0 mass +18 333.289699 220.830317 121.166705 -17.204713 1.0 1.0 mass +19 361.089678 214.901909 117.183695 -41.776506 1.0 1.0 mass +20 382.690515 197.005784 101.789802 -63.980298 1.0 1.0 mass +21 392.095364 170.108402 75.453780 -78.414351 1.0 1.0 mass +22 386.286391 142.033621 41.812216 -77.402424 1.0 1.0 mass +23 368.355658 119.326317 12.658676 -58.885262 1.0 1.0 mass +24 341.159901 109.253775 -0.645459 -27.346079 1.0 1.0 mass +25 300.792976 88.652764 -23.770230 17.788258 1.0 1.0 mass +26 266.917041 116.942125 11.387083 52.603190 1.0 1.0 mass +27 252.824303 157.992984 59.144863 62.163730 1.0 1.0 mass +28 261.812599 201.245775 103.542171 47.141708 1.0 1.0 mass +29 290.323965 234.792944 133.016945 18.136362 1.0 1.0 mass +30 330.805232 249.331769 145.899409 -16.478401 1.0 1.0 mass +31 373.715232 241.181453 141.068680 -55.103677 1.0 1.0 mass +32 406.314817 213.217096 116.087430 -90.844012 1.0 1.0 mass +33 420.647493 172.661774 73.304028 -110.880720 1.0 1.0 mass +34 412.375908 129.697207 24.072484 -106.129512 1.0 1.0 mass +35 384.555754 95.915740 -16.565355 -77.142380 1.0 1.0 mass +36 344.134757 80.886540 -34.250916 -30.871105 1.0 1.0 mass +37 288.774590 62.672780 -55.431084 28.821437 1.0 1.0 mass +38 244.055965 100.457489 -9.756397 76.701354 1.0 1.0 mass +39 224.574635 156.693148 53.845562 91.755892 1.0 1.0 mass +40 235.856891 213.935639 112.462316 73.437061 1.0 1.0 mass +41 273.697931 257.991035 152.320671 33.701056 1.0 1.0 mass +42 329.129445 277.782400 170.727571 -15.899371 1.0 1.0 mass +43 386.065290 267.474982 165.436658 -68.761273 1.0 1.0 mass +44 429.946314 229.605765 132.087682 -116.795195 1.0 1.0 mass +45 449.164590 174.189613 73.084826 -143.228528 1.0 1.0 mass +46 438.674101 117.351918 9.340834 -136.225613 1.0 1.0 mass +47 401.586435 72.955570 -42.523445 -98.317857 1.0 1.0 mass +48 346.207804 52.561279 -67.447974 -34.980297 1.0 1.0 mass +1 1 2 150.0 2.0 14.0 spng +2 2 3 150.0 2.0 14.0 spng +3 3 4 150.0 2.0 14.0 spng +4 4 5 150.0 2.0 14.0 spng +5 5 6 150.0 2.0 14.0 spng +6 6 7 150.0 2.0 14.0 spng +7 7 8 150.0 2.0 14.0 spng +8 8 9 150.0 2.0 14.0 spng +9 9 10 150.0 2.0 14.0 spng +10 10 11 150.0 2.0 14.0 spng +11 11 12 150.0 2.0 14.0 spng +12 12 1 150.0 2.0 14.0 spng +13 13 14 150.0 2.0 28.0 spng +14 14 15 150.0 2.0 28.0 spng +15 15 16 150.0 2.0 28.0 spng +16 16 17 150.0 2.0 28.0 spng +17 17 18 150.0 2.0 28.0 spng +18 18 19 150.0 2.0 28.0 spng +19 19 20 150.0 2.0 28.0 spng +20 20 21 150.0 2.0 28.0 spng +21 21 22 150.0 2.0 28.0 spng +22 22 23 150.0 2.0 28.0 spng +23 23 24 150.0 2.0 28.0 spng +24 24 13 150.0 2.0 28.0 spng +25 25 26 150.0 2.0 44.0 spng +26 26 27 150.0 2.0 43.0 spng +27 27 28 150.0 2.0 44.0 spng +28 28 29 150.0 2.0 44.0 spng +29 29 30 150.0 2.0 43.0 spng +30 30 31 150.0 2.0 44.0 spng +31 31 32 150.0 2.0 43.0 spng +32 32 33 150.0 2.0 43.0 spng +33 33 34 150.0 2.0 44.0 spng +34 34 35 150.0 2.0 44.0 spng +35 35 36 150.0 2.0 43.0 spng +36 36 25 150.0 2.0 44.0 spng +37 37 38 150.0 2.0 58.0 spng +38 38 39 150.0 2.0 59.0 spng +39 39 40 150.0 2.0 58.0 spng +40 40 41 150.0 2.0 58.0 spng +41 41 42 150.0 2.0 59.0 spng +42 42 43 150.0 2.0 58.0 spng +43 43 44 150.0 2.0 58.0 spng +44 44 45 150.0 2.0 59.0 spng +45 45 46 150.0 2.0 58.0 spng +46 46 47 150.0 2.0 58.0 spng +47 47 48 150.0 2.0 59.0 spng +48 48 37 150.0 2.0 58.0 spng +49 1 13 150.0 2.0 29.0 spng +50 2 14 150.0 2.0 28.0 spng +51 3 15 150.0 2.0 28.0 spng +52 4 16 150.0 2.0 29.0 spng +53 5 17 150.0 2.0 28.0 spng +54 6 18 150.0 2.0 28.0 spng +55 7 19 150.0 2.0 29.0 spng +56 8 20 150.0 2.0 28.0 spng +57 9 21 150.0 2.0 28.0 spng +58 10 22 150.0 2.0 29.0 spng +59 11 23 150.0 2.0 28.0 spng +60 12 24 150.0 2.0 28.0 spng +61 13 25 150.0 2.0 29.0 spng +62 14 26 150.0 2.0 28.0 spng +63 15 27 150.0 2.0 28.0 spng +64 16 28 150.0 2.0 29.0 spng +65 17 29 150.0 2.0 28.0 spng +66 18 30 150.0 2.0 28.0 spng +67 19 31 150.0 2.0 29.0 spng +68 20 32 150.0 2.0 28.0 spng +69 21 33 150.0 2.0 28.0 spng +70 22 34 150.0 2.0 29.0 spng +71 23 35 150.0 2.0 28.0 spng +72 24 36 150.0 2.0 28.0 spng +73 25 37 150.0 2.0 29.0 spng +74 26 38 150.0 2.0 28.0 spng +75 27 39 150.0 2.0 28.0 spng +76 28 40 150.0 2.0 29.0 spng +77 29 41 150.0 2.0 28.0 spng +78 30 42 150.0 2.0 28.0 spng +79 31 43 150.0 2.0 29.0 spng +80 32 44 150.0 2.0 28.0 spng +81 33 45 150.0 2.0 28.0 spng +82 34 46 150.0 2.0 29.0 spng +83 35 47 150.0 2.0 28.0 spng +84 36 48 150.0 2.0 28.0 spng +85 1 14 150.0 2.0 35.0 spng +86 2 15 150.0 2.0 35.0 spng +87 3 16 150.0 2.0 34.0 spng +88 4 17 150.0 2.0 35.0 spng +89 5 18 150.0 2.0 35.0 spng +90 6 19 150.0 2.0 34.0 spng +91 7 20 150.0 2.0 35.0 spng +92 8 21 150.0 2.0 35.0 spng +93 9 22 150.0 2.0 34.0 spng +94 10 23 150.0 2.0 35.0 spng +95 11 24 150.0 2.0 35.0 spng +96 12 13 150.0 2.0 34.0 spng +97 13 26 150.0 2.0 46.0 spng +98 14 27 150.0 2.0 45.0 spng +99 15 28 150.0 2.0 45.0 spng +100 16 29 150.0 2.0 46.0 spng +101 17 30 150.0 2.0 45.0 spng +102 18 31 150.0 2.0 45.0 spng +103 19 32 150.0 2.0 45.0 spng +104 20 33 150.0 2.0 45.0 spng +105 21 34 150.0 2.0 45.0 spng +106 22 35 150.0 2.0 46.0 spng +107 23 36 150.0 2.0 45.0 spng +108 24 25 150.0 2.0 45.0 spng +109 25 38 150.0 2.0 58.0 spng +110 26 39 150.0 2.0 58.0 spng +111 27 40 150.0 2.0 58.0 spng +112 28 41 150.0 2.0 58.0 spng +113 29 42 150.0 2.0 58.0 spng +114 30 43 150.0 2.0 58.0 spng +115 31 44 150.0 2.0 58.0 spng +116 32 45 150.0 2.0 58.0 spng +117 33 46 150.0 2.0 58.0 spng +118 34 47 150.0 2.0 58.0 spng +119 35 48 150.0 2.0 58.0 spng +120 36 37 150.0 2.0 58.0 spng +121 1 24 150.0 2.0 35.0 spng +122 2 13 150.0 2.0 34.0 spng +123 3 14 150.0 2.0 35.0 spng +124 4 15 150.0 2.0 35.0 spng +125 5 16 150.0 2.0 34.0 spng +126 6 17 150.0 2.0 35.0 spng +127 7 18 150.0 2.0 35.0 spng +128 8 19 150.0 2.0 34.0 spng +129 9 20 150.0 2.0 35.0 spng +130 10 21 150.0 2.0 35.0 spng +131 11 22 150.0 2.0 34.0 spng +132 12 23 150.0 2.0 35.0 spng +133 13 36 150.0 2.0 46.0 spng +134 14 25 150.0 2.0 45.0 spng +135 15 26 150.0 2.0 45.0 spng +136 16 27 150.0 2.0 46.0 spng +137 17 28 150.0 2.0 45.0 spng +138 18 29 150.0 2.0 45.0 spng +139 19 30 150.0 2.0 46.0 spng +140 20 31 150.0 2.0 45.0 spng +141 21 32 150.0 2.0 45.0 spng +142 22 33 150.0 2.0 46.0 spng +143 23 34 150.0 2.0 45.0 spng +144 24 35 150.0 2.0 45.0 spng +145 25 48 150.0 2.0 58.0 spng +146 26 37 150.0 2.0 58.0 spng +147 27 38 150.0 2.0 58.0 spng +148 28 39 150.0 2.0 58.0 spng +149 29 40 150.0 2.0 58.0 spng +150 30 41 150.0 2.0 58.0 spng +151 31 42 150.0 2.0 58.0 spng +152 32 43 150.0 2.0 58.0 spng +153 33 44 150.0 2.0 58.0 spng +154 34 45 150.0 2.0 58.0 spng +155 35 46 150.0 2.0 58.0 spng +156 36 47 150.0 2.0 58.0 spng +157 10 4 150.0 2.0 52.331631 spng +158 7 1 150.0 2.0 52.436772 spng +159 12 6 150.0 2.0 54.680698 spng +160 5 11 150.0 2.0 54.589379 spng +161 9 3 150.0 2.0 54.451569 spng +162 2 8 150.0 2.0 54.482231 spng +163 45 11 150.0 2.0 101.408150 spng +164 46 12 150.0 2.0 101.542452 spng +165 47 1 150.0 2.0 101.963064 spng +166 48 2 150.0 2.0 101.517329 spng +167 37 3 150.0 2.0 101.603694 spng +168 38 4 150.0 2.0 102.014031 spng +169 39 5 150.0 2.0 101.547660 spng +170 40 6 150.0 2.0 101.573762 spng +171 41 7 150.0 2.0 101.897300 spng +172 42 8 150.0 2.0 101.497982 spng +173 43 9 150.0 2.0 101.870594 spng +174 44 10 150.0 2.0 102.043753 spng +175 45 11 150.0 2.0 101.408150 spng +176 46 8 150.0 2.0 101.548938 spng +177 47 10 150.0 2.0 90.645939 spng +178 48 10 150.0 2.0 101.952119 spng +179 37 11 150.0 2.0 101.552352 spng +180 38 12 150.0 2.0 101.491447 spng +181 39 1 150.0 2.0 101.971524 spng +182 40 2 150.0 2.0 101.587400 spng +183 41 3 150.0 2.0 101.519279 spng +184 42 4 150.0 2.0 101.976181 spng +185 43 5 150.0 2.0 101.714570 spng +186 44 6 150.0 2.0 101.388747 spng +187 45 7 150.0 2.0 101.773286 spng + +nodes> [ { 0 100 } swap set-node-vel ] each ; + +USING: threads ui ; + +: go ( -- ) [ [ springies-window* 1000 sleep model ] with-scope ] with-ui ; + +MAIN: go \ No newline at end of file diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor new file mode 100644 index 0000000000..f4fb19c8a3 --- /dev/null +++ b/extra/springies/springies.factor @@ -0,0 +1,246 @@ + +USING: kernel combinators sequences arrays math math.vectors + combinators.lib shuffle vars ; + +IN: springies + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: scalar-projection ( a b -- n ) [ v. ] [ nip norm ] 2bi / ; + +: vector-projection ( a b -- vec ) + [ nip normalize ] [ scalar-projection ] 2bi v*n ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: nodes +VAR: springs +VAR: time-slice +VAR: world-size + +: world-width ( -- width ) world-size> first ; + +: world-height ( -- height ) world-size> second ; + +VAR: gravity + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! node +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: node mass elas pos vel force ; + +C: node + +: >>pos ( node pos -- node ) over set-node-pos ; + +: >>vel ( node vel -- node ) over set-node-vel ; + +: pos-x ( node -- x ) node-pos first ; +: pos-y ( node -- y ) node-pos second ; +: vel-x ( node -- y ) node-vel first ; +: vel-y ( node -- y ) node-vel second ; + +: >>pos-x ( node x -- node ) over node-pos set-first ; +: >>pos-y ( node y -- node ) over node-pos set-second ; +: >>vel-x ( node x -- node ) over node-vel set-first ; +: >>vel-y ( node y -- node ) over node-vel set-second ; + +: apply-force ( node vec -- ) over node-force v+ swap set-node-force ; + +: reset-force ( node -- ) 0 0 2array swap set-node-force ; + +: node-id ( id -- node ) 1- nodes> nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! spring +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: spring rest-length k damp node-a node-b ; + +C: spring + +: end-points ( spring -- b-pos a-pos ) + [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi ; + +: spring-length ( spring -- length ) end-points v- norm ; + +: stretch-length ( spring -- length ) + [ spring-length ] [ spring-rest-length ] bi - ; + +: dir ( spring -- vec ) end-points v- normalize ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Hooke +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! F = -kx +! +! k :: spring constant +! x :: distance stretched beyond rest length +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: hooke-force-mag ( spring -- mag ) [ spring-k ] [ stretch-length ] bi * ; + +: hooke-force ( spring -- force ) [ dir ] [ hooke-force-mag ] bi v*n ; + +: hooke-forces ( spring -- a b ) hooke-force dup vneg ; + +: act-on-nodes-hooke ( spring -- ) + [ spring-node-a ] [ spring-node-b ] [ ] tri hooke-forces swapd + apply-force + apply-force ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! damping +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! F = -bv +! +! b :: Damping constant +! v :: Velocity +! +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : damping-force-a ( spring -- vec ) +! [ spring-node-a node-vel ] [ spring-damp ] bi v*n vneg ; + +! : damping-force-b ( spring -- vec ) +! [ spring-node-b node-vel ] [ spring-damp ] bi v*n vneg ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: relative-velocity-a ( spring -- vel ) + [ spring-node-a node-vel ] [ spring-node-b node-vel ] bi v- ; + +: unit-vec-b->a ( spring -- vec ) + [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi v- ; + +: relative-velocity-along-spring-a ( spring -- vel ) + [ relative-velocity-a ] [ unit-vec-b->a ] bi vector-projection ; + +: damping-force-a ( spring -- vec ) + [ relative-velocity-along-spring-a ] [ spring-damp ] bi v*n vneg ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: relative-velocity-b ( spring -- vel ) + [ spring-node-b node-vel ] [ spring-node-a node-vel ] bi v- ; + +: unit-vec-a->b ( spring -- vec ) + [ spring-node-b node-pos ] [ spring-node-a node-pos ] bi v- ; + +: relative-velocity-along-spring-b ( spring -- vel ) + [ relative-velocity-b ] [ unit-vec-a->b ] bi vector-projection ; + +: damping-force-b ( spring -- vec ) + [ relative-velocity-along-spring-b ] [ spring-damp ] bi v*n vneg ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: act-on-nodes-damping ( spring -- ) + dup + [ spring-node-a ] [ damping-force-a ] bi apply-force + [ spring-node-b ] [ damping-force-b ] bi apply-force ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: below? ( node -- ? ) pos-y 0 < ; + +: above? ( node -- ? ) pos-y world-height >= ; + +: beyond-left? ( node -- ? ) pos-x 0 < ; + +: beyond-right? ( node -- ? ) pos-x world-width >= ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bounce-top ( node -- ) + world-height 1- >>pos-y + dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + drop ; + +: bounce-bottom ( node -- ) + 0 >>pos-y + dup [ vel-y ] [ node-elas ] bi * neg >>vel-y + drop ; + +: bounce-left ( node -- ) + 0 >>pos-x + dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + drop ; + +: bounce-right ( node -- ) + world-width 1- >>pos-x + dup [ vel-x ] [ node-elas ] bi * neg >>vel-x + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: handle-bounce ( node -- ) + { { [ dup above? ] [ bounce-top ] } + { [ dup below? ] [ bounce-bottom ] } + { [ dup beyond-left? ] [ bounce-left ] } + { [ dup beyond-right? ] [ bounce-right ] } + { [ t ] [ drop ] } } + cond ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: act-on-nodes ( spring -- ) + dup + act-on-nodes-hooke + act-on-nodes-damping ; + +! : act-on-nodes ( spring -- ) act-on-nodes-hooke ; + +: loop-over-springs ( -- ) springs> [ act-on-nodes ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: apply-gravity ( node -- ) { 0 -9.8 } apply-force ; + +: do-gravity ( -- ) gravity> [ nodes> [ apply-gravity ] each ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! F = ma + +: calc-acceleration ( node -- vec ) [ node-force ] [ node-mass ] bi v/n ; + +: new-vel ( node -- vel ) + [ node-vel ] [ calc-acceleration time-slice> v*n ] bi v+ ; + +: new-pos ( node -- pos ) [ node-pos ] [ node-vel time-slice> v*n ] bi v+ ; + +: iterate-node ( node -- ) + dup new-pos >>pos + dup new-vel >>vel + dup reset-force + handle-bounce ; + +: iterate-nodes ( -- ) nodes> [ iterate-node ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: iterate-system ( -- ) do-gravity loop-over-springs iterate-nodes ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Reading xspringies data files +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mass ( id x y x-vel y-vel mass elas -- ) + 7 nrot drop + 6 nrot 6 nrot 2array + 5 nrot 5 nrot 2array + 0 0 2array + nodes> swap add >nodes ; + +: spng ( id id-a id-b k damp rest-length -- ) + 6 nrot drop + -rot + 5 nrot node-id + 5 nrot node-id + + springs> swap add >springs ; diff --git a/extra/springies/ui/ui.factor b/extra/springies/ui/ui.factor new file mode 100644 index 0000000000..5a8f2455dd --- /dev/null +++ b/extra/springies/ui/ui.factor @@ -0,0 +1,61 @@ + +USING: kernel namespaces threads sequences math math.vectors combinators.lib + opengl.gl opengl colors ui ui.gadgets ui.gadgets.slate + rewrite-closures vars springies ; + +IN: springies.ui + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: draw-node ( node -- ) node-pos { -5 -5 } v+ dup { 10 10 } v+ gl-rect ; + +: draw-spring ( spring -- ) + [ spring-node-a node-pos ] [ spring-node-b node-pos ] bi gl-line ; + +: draw-nodes ( -- ) nodes> [ draw-node ] each ; + +: draw-springs ( -- ) springs> [ draw-spring ] each ; + +: set-projection ( -- ) + GL_PROJECTION glMatrixMode + glLoadIdentity + 0 world-width 1- 0 world-height 1- -1 1 glOrtho + GL_MODELVIEW glMatrixMode + glLoadIdentity ; + +: display ( -- ) set-projection black gl-color draw-nodes draw-springs ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: slate + +VAR: loop + +: update-world-size ( -- ) slate> rect-dim >world-size ; + +: refresh-slate ( -- ) slate> relayout-1 ; + +DEFER: maybe-loop + +: run ( -- ) + update-world-size + iterate-system + refresh-slate + yield + maybe-loop ; + +: maybe-loop ( -- ) loop> [ run ] when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: springies-window* ( -- ) + + C[ display ] >slate + { 500 500 } 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 + + slate> "Springies" open-window ; + +: springies-window ( -- ) [ [ springies-window* ] with-scope ] with-ui ; \ No newline at end of file From 94a8ce2237937b5c344fe507b7919980b6c91ab2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Oct 2007 21:23:20 -0400 Subject: [PATCH 35/41] Merged opengl.lib into opengl and update Ed's demos (don\'t tase me bro\!) --- extra/bunny/bunny.factor | 5 +--- extra/jamshred/gl/gl.factor | 2 +- extra/lsys/tortoise/graphics/graphics.factor | 13 +++++----- extra/lsys/ui/deploy.factor | 13 ++++++++++ extra/lsys/ui/ui.factor | 11 ++++----- extra/opengl/authors.txt | 1 + extra/opengl/camera/camera.factor | 4 ++-- extra/opengl/opengl.factor | 25 ++++++++++++++++---- 8 files changed, 51 insertions(+), 23 deletions(-) create mode 100644 extra/lsys/ui/deploy.factor diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index c33acb0f3a..3042b87ad6 100644 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -57,10 +57,7 @@ IN: bunny ] unless ; : draw-triangle ( ns vs triple -- ) - [ - dup roll nth first3 glNormal3d - swap nth first3 glVertex3d - ] each-with2 ; + [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ; : draw-bunny ( ns vs is -- ) GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ; diff --git a/extra/jamshred/gl/gl.factor b/extra/jamshred/gl/gl.factor index f20d8d2bd8..da38e43392 100644 --- a/extra/jamshred/gl/gl.factor +++ b/extra/jamshred/gl/gl.factor @@ -14,7 +14,7 @@ IN: jamshred.gl : draw-segment-vertex ( segment theta -- ) over segment-color gl-color segment-vertex-and-normal - first3 glNormal3d first3 glVertex3d ; + gl-normal gl-vertex ; : draw-vertex-pair ( theta next-segment segment -- ) rot tuck draw-segment-vertex draw-segment-vertex ; diff --git a/extra/lsys/tortoise/graphics/graphics.factor b/extra/lsys/tortoise/graphics/graphics.factor index 23bf66c2f8..c212ab435d 100644 --- a/extra/lsys/tortoise/graphics/graphics.factor +++ b/extra/lsys/tortoise/graphics/graphics.factor @@ -1,6 +1,7 @@ -USING: kernel math vectors sequences opengl.gl math.vectors math.matrices - vars opengl.lib self pos ori turtle lsys.tortoise lsys.strings ; +USING: kernel math vectors sequences opengl.gl math.vectors +math.matrices vars opengl self pos ori turtle lsys.tortoise +lsys.strings ; IN: lsys.tortoise.graphics @@ -12,7 +13,7 @@ IN: lsys.tortoise.graphics : (polygon) ( vertices -- ) GL_POLYGON glBegin -dup polygon-normal gl-normal-3f [ gl-vertex-3f ] each +dup polygon-normal gl-normal [ gl-vertex ] each glEnd ; : polygon ( vertices -- ) dup length 3 >= [ (polygon) ] [ drop ] if ; @@ -31,7 +32,7 @@ VAR: vertices ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: record-vertex ( -- ) pos> gl-vertex-3f ; +: record-vertex ( -- ) pos> gl-vertex ; : draw-forward ( length -- ) GL_LINES glBegin record-vertex step-turtle record-vertex glEnd ; @@ -78,10 +79,10 @@ VAR: color-table ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : material-color ( color -- ) -GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material-fv ; +GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE rot gl-material ; : set-color ( i -- ) -dup >color color-table> nth dup gl-color-4f material-color ; +dup >color color-table> nth dup gl-color material-color ; : inc-color ( -- ) color> 1+ set-color ; diff --git a/extra/lsys/ui/deploy.factor b/extra/lsys/ui/deploy.factor new file mode 100644 index 0000000000..22b6d0e4a3 --- /dev/null +++ b/extra/lsys/ui/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy ; +V{ + { strip-word-props? t } + { strip-word-names? t } + { strip-dictionary? t } + { strip-debugger? t } + { strip-c-types? t } + { deploy-math? t } + { deploy-compiled? t } + { deploy-io? f } + { deploy-ui? t } + { "bundle-name" "Lindenmayer Systems.app" } +} diff --git a/extra/lsys/ui/ui.factor b/extra/lsys/ui/ui.factor index efdaa9caba..2602adfcee 100644 --- a/extra/lsys/ui/ui.factor +++ b/extra/lsys/ui/ui.factor @@ -1,5 +1,6 @@ USING: kernel namespaces threads math math.vectors quotations sequences + opengl opengl.gl colors ui @@ -11,7 +12,7 @@ USING: kernel namespaces threads math math.vectors quotations sequences ui.gadgets.lib ui.gadgets.slate ui.gadgets.theme - vars rewrite-closures opengl.lib + vars rewrite-closures self pos ori turtle opengl.camera lsys.tortoise lsys.tortoise.graphics lsys.strings ; @@ -34,7 +35,7 @@ VAR: model : display ( -- ) -black gl-clear-color +black gl-clear GL_FLAT glShadeModel @@ -48,13 +49,11 @@ glLoadIdentity camera> do-look-at -GL_COLOR_BUFFER_BIT glClear - GL_FRONT_AND_BACK GL_LINE glPolygonMode -white gl-color-4f +white gl-color -GL_LINES glBegin { 0 0 0 } gl-vertex-3f { 0 0 1 } gl-vertex-3f glEnd +GL_LINES glBegin { 0 0 0 } gl-vertex { 0 0 1 } gl-vertex glEnd color> set-color diff --git a/extra/opengl/authors.txt b/extra/opengl/authors.txt index 1901f27a24..e1907c6d91 100644 --- a/extra/opengl/authors.txt +++ b/extra/opengl/authors.txt @@ -1 +1,2 @@ Slava Pestov +Eduardo Cavazos diff --git a/extra/opengl/camera/camera.factor b/extra/opengl/camera/camera.factor index 030a5d0989..c324e53edc 100644 --- a/extra/opengl/camera/camera.factor +++ b/extra/opengl/camera/camera.factor @@ -1,5 +1,5 @@ -USING: kernel namespaces math.vectors opengl.lib pos ori turtle self ; +USING: kernel namespaces math.vectors opengl pos ori turtle self ; IN: opengl.camera @@ -13,4 +13,4 @@ IN: opengl.camera [ 90 pitch-up pos> 1 step-turtle pos> swap v- ] save-self ; : do-look-at ( camera -- ) -[ >self camera-eye camera-focus camera-up glu-look-at ] with-scope ; +[ >self camera-eye camera-focus camera-up gl-look-at ] with-scope ; diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 0cb16cccbd..13ce47ba52 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2005, 2006 Slava Pestov. +! Copyright (C) 2005, 2007 Slava Pestov. +! Portions copyright (C) 2007 Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types io kernel math namespaces -sequences math.vectors opengl.gl opengl.glu ; +sequences math.vectors opengl.gl opengl.glu combinators ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -10,8 +11,11 @@ IN: opengl : gl-color ( color -- ) first4 glColor4d ; inline +: gl-clear-color ( color -- ) + first4 glClearColor ; + : gl-clear ( color -- ) - first4 glClearColor GL_COLOR_BUFFER_BIT glClear ; + gl-clear-color GL_COLOR_BUFFER_BIT glClear ; : gl-error ( -- ) glGetError dup zero? [ @@ -28,7 +32,17 @@ IN: opengl swap [ glMatrixMode glPushMatrix call ] keep glMatrixMode glPopMatrix ; inline -: gl-vertex ( point -- ) first2 glVertex2d ; inline +: gl-vertex ( point -- ) + dup length { + { 2 [ first2 glVertex2d ] } + { 3 [ first3 glVertex3d ] } + { 4 [ first4 glVertex4d ] } + } case ; + +: gl-normal ( normal -- ) first3 glNormal3d ; + +: gl-material ( face pname params -- ) + >c-float-array glMaterialfv ; : gl-line ( a b -- ) GL_LINES [ gl-vertex gl-vertex ] do-state ; @@ -67,6 +81,9 @@ IN: opengl : do-attribs ( bits quot -- ) swap glPushAttrib call glPopAttrib ; inline +: gl-look-at ( eye focus up -- ) + >r >r first3 r> first3 r> first3 gluLookAt ; + TUPLE: sprite loc dim dim2 dlist texture ; : ( loc dim dim2 -- sprite ) From 202f7cdfffba6c65cf1485b15ed099e18b42e67f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Oct 2007 22:28:08 -0400 Subject: [PATCH 36/41] Forgot to remove opengl.lib --- extra/opengl/lib/lib.factor | 19 ------------------- 1 file changed, 19 deletions(-) delete mode 100644 extra/opengl/lib/lib.factor diff --git a/extra/opengl/lib/lib.factor b/extra/opengl/lib/lib.factor deleted file mode 100644 index 4e52710b85..0000000000 --- a/extra/opengl/lib/lib.factor +++ /dev/null @@ -1,19 +0,0 @@ -USING: kernel alien.c-types sequences opengl.gl opengl.glu ; - -IN: opengl.lib - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: gl-color-4f ( 4seq -- ) first4 glColor4f ; - -: gl-clear-color ( 4seq -- ) first4 glClearColor ; - -: gl-vertex-3f ( array -- ) first3 glVertex3f ; - -: gl-normal-3f ( array -- ) first3 glNormal3f ; - -: gl-material-fv ( face pname params -- ) >c-float-array glMaterialfv ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: glu-look-at ( eye focus up -- ) >r >r first3 r> first3 r> first3 gluLookAt ; \ No newline at end of file From 073bca910041779f2ff220af03d4669fdec9980f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Oct 2007 22:28:22 -0400 Subject: [PATCH 37/41] Update contributors --- extra/contributors/contributors.factor | 23 +++++++++-------------- 1 file changed, 9 insertions(+), 14 deletions(-) diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor index 7db2965a54..aaff1d2038 100644 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -1,29 +1,24 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: memory io io.files io.styles io.launcher -sequences prettyprint kernel arrays xml xml.utilities system -hashtables sorting math.parser assocs ; +USING: io.files io.launcher io.styles io hashtables kernel +sequences combinators.lib assocs system sorting math.parser ; IN: contributors -: changelog ( -- xml ) +: changelog ( -- authors ) image parent-dir cd - "darcs changes --xml-output" read-xml ; - -: authors ( xml -- seq ) - children-tags [ "author" swap at ] map ; - -: patch-count ( authors author -- n ) - [ = ] curry subset length ; + "git-log --pretty=format:%an" lines ; : patch-counts ( authors -- assoc ) - dup prune [ [ patch-count ] keep 2array ] curry* map ; + dup prune + [ dup rot [ = ] curry* count ] curry* + { } map>assoc ; : contributors ( -- ) - changelog authors patch-counts sort-keys + changelog patch-counts sort-values standard-table-style [ [ [ - first2 + first2 swap [ write ] with-cell [ number>string write ] with-cell ] with-row From 97fa31baf69867d871a9a4137354820f9c6899eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Oct 2007 22:56:02 -0400 Subject: [PATCH 38/41] Fix minor memory leak --- core/continuations/continuations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index f7349855dd..dc8f337f33 100644 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -89,7 +89,7 @@ C: continuation set-catchstack set-namestack set-retainstack - >r set-datastack drop 4 getenv f r> + >r set-datastack drop 4 getenv f 4 setenv f r> set-callstack ; PRIVATE> From 7bbd169b2a0d75f02f431aafdb42dc036f78afc3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 8 Oct 2007 22:56:15 -0400 Subject: [PATCH 39/41] Fix generator regression --- core/generator/generator.factor | 3 ++- core/generator/registers/registers.factor | 6 ++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 30295b722e..4a6aa8093a 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -130,7 +130,7 @@ UNION: #terminal M: node generate-node drop iterate-next ; : %call ( word -- ) - dup primitive? [ %call-primitive ] [ %call-label ] if ; + dup primitive? [ "Call prim: " write dup . %call-primitive ] [ %call-label ] if ; : %jump ( word -- ) { @@ -138,6 +138,7 @@ M: node generate-node drop iterate-next ; drop current-label-start get %jump-label ] } { [ dup primitive? ] [ + "Jump prim: " write dup . %epilogue-later %jump-primitive ] } { [ t ] [ diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 214aafd75c..1d7af86312 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -458,6 +458,12 @@ M: loc lazy-store dup loc? over cached? or [ 2drop ] [ %move ] if ] each-loc ; +: reset-phantom ( phantom -- ) + dup phantom-locs* over delete-all swap push-all ; + +: reset-phantoms ( -- ) + [ reset-phantom ] each-phantom ; + : finalize-contents ( -- ) finalize-locs finalize-vregs [ delete-all ] each-phantom ; From 236f505e14babd265782bb2ad2ab67d858e10915 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 9 Oct 2007 00:40:54 -0400 Subject: [PATCH 40/41] Remove debug messages --- core/generator/generator.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 4a6aa8093a..30295b722e 100644 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -130,7 +130,7 @@ UNION: #terminal M: node generate-node drop iterate-next ; : %call ( word -- ) - dup primitive? [ "Call prim: " write dup . %call-primitive ] [ %call-label ] if ; + dup primitive? [ %call-primitive ] [ %call-label ] if ; : %jump ( word -- ) { @@ -138,7 +138,6 @@ M: node generate-node drop iterate-next ; drop current-label-start get %jump-label ] } { [ dup primitive? ] [ - "Jump prim: " write dup . %epilogue-later %jump-primitive ] } { [ t ] [ From c644f21daf5def5fbcbf1b49c6df8dccff504a2d Mon Sep 17 00:00:00 2001 From: Slava Date: Tue, 9 Oct 2007 01:30:35 -0400 Subject: [PATCH 41/41] Fix find-template regression: many intrinsics were not open-coded on x86 --- core/compiler/test/templates-early.factor | 27 ++++++++++++ core/cpu/x86/intrinsics/intrinsics.factor | 2 +- core/generator/registers/registers.factor | 52 +++++++++++------------ 3 files changed, 54 insertions(+), 27 deletions(-) diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early.factor index ae7cf12502..8482f4767f 100644 --- a/core/compiler/test/templates-early.factor +++ b/core/compiler/test/templates-early.factor @@ -187,3 +187,30 @@ SYMBOL: template-chosen ! This should not fail [ ] [ [ end-basic-block ] { } make drop ] unit-test ] with-scope + +! Regression +SYMBOL: templates-chosen + +V{ } clone templates-chosen set + +: template-choice-1 ; + +\ template-choice-1 +[ "template-choice-1" templates-chosen get push ] +H{ + { +input+ { { f "obj" } { [ ] "n" } } } + { +output+ { "obj" } } +} define-intrinsic + +: template-choice-2 ; + +\ template-choice-2 +[ "template-choice-2" templates-chosen get push drop ] +{ { f "x" } { f "y" } } define-if-intrinsic + +[ ] [ + [ 2 template-choice-1 template-choice-2 ] compile-quot drop +] unit-test + +[ V{ "template-choice-1" "template-choice-2" } ] +[ templates-chosen get ] unit-test diff --git a/core/cpu/x86/intrinsics/intrinsics.factor b/core/cpu/x86/intrinsics/intrinsics.factor index c828474742..3b39afaa24 100644 --- a/core/cpu/x86/intrinsics/intrinsics.factor +++ b/core/cpu/x86/intrinsics/intrinsics.factor @@ -586,7 +586,7 @@ IN: cpu.x86.intrinsics "value" operand [ swap MOV ] %alien-accessor ] H{ { +input+ { - { unboxed-c-ptr "value" c-ptr } + { unboxed-c-ptr "value" pinned-c-ptr } { unboxed-c-ptr "alien" c-ptr } { f "offset" fixnum } } } diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 1d7af86312..68e63ac605 100644 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -459,13 +459,22 @@ M: loc lazy-store ] each-loc ; : reset-phantom ( phantom -- ) - dup phantom-locs* over delete-all swap push-all ; + #! Kill register assignments but preserve constants and + #! class information. + dup phantom-locs* + over [ + dup constant? [ nip ] [ + operand-class over set-operand-class + ] if + ] 2map + over delete-all + swap push-all ; : reset-phantoms ( -- ) [ reset-phantom ] each-phantom ; : finalize-contents ( -- ) - finalize-locs finalize-vregs [ delete-all ] each-phantom ; + finalize-locs finalize-vregs reset-phantoms ; : %gc ( -- ) 0 frame-required @@ -474,8 +483,8 @@ M: loc lazy-store ! Loading stacks to vregs : free-vregs? ( int# float# -- ? ) - T{ float-regs f 8 } free-vregs length < - >r T{ int-regs } free-vregs length < r> and ; + T{ float-regs f 8 } free-vregs length <= + >r T{ int-regs } free-vregs length <= r> and ; : phantom&spec ( phantom spec -- phantom' spec' ) [ length f pad-left ] keep @@ -591,24 +600,18 @@ M: loc lazy-store 2dup first value-matches? >r >r operand-class 2 r> ?nth class-matches? r> and ; -: template-specs-match? ( -- ? ) - phantom-d get +input+ get - [ spec-matches? ] phantom&spec-agree? ; - : template-matches? ( spec -- ? ) - clone [ - template-specs-match? - [ guess-template-vregs free-vregs? ] [ f ] if - ] bind ; - -: (find-template) ( templates -- pair/f ) - [ second template-matches? ] find nip ; + phantom-d get +input+ rot at + [ spec-matches? ] phantom&spec-agree? ; : ensure-template-vregs ( -- ) guess-template-vregs free-vregs? [ finalize-contents compute-free-vregs ] unless ; +: clear-phantoms ( -- ) + [ delete-all ] each-phantom ; + PRIVATE> : set-operand-classes ( classes -- ) @@ -620,15 +623,11 @@ PRIVATE> #! Commit all deferred stacking shuffling, and ensure the #! in-memory data and retain stacks are up to date with #! respect to the compiler's current picture. - finalize-contents finalize-heights + finalize-contents + clear-phantoms + finalize-heights fresh-objects get dup empty? swap delete-all [ %gc ] unless ; -: do-template ( pair -- ) - #! Use with return value from find-template - first2 - clone [ template-inputs call template-outputs ] bind - compute-free-vregs ; inline - : with-template ( quot hash -- ) clone [ ensure-template-vregs @@ -636,6 +635,10 @@ PRIVATE> ] bind compute-free-vregs ; inline +: do-template ( pair -- ) + #! Use with return value from find-template + first2 with-template ; + : fresh-object ( obj -- ) fresh-objects get push ; : fresh-object? ( obj -- ? ) fresh-objects get memq? ; @@ -657,10 +660,7 @@ PRIVATE> : find-template ( templates -- pair/f ) #! Pair has shape { quot hash } - compute-free-vregs - dup (find-template) [ ] [ - finalize-contents (find-template) - ] ?if ; + [ second template-matches? ] find nip ; : operand-tag ( operand -- tag/f ) operand-class class-tag ;