From d91165a32be27d612b43d29240a14a6c0cec7585 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Nov 2007 04:12:41 -0500 Subject: [PATCH 01/55] Fix dispatch on ARM --- core/cpu/arm/architecture/architecture.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index cadfcfda14..4e2a363db3 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -117,7 +117,8 @@ M: arm-backend %jump-t ( label -- ) #! Load jump table target address into reg. "scratch" operand PC "n" operand 1 ADD "scratch" operand 0 <+> LDR - rc-indirect-arm rel-dispatch ; + rc-indirect-arm rel-dispatch + "scratch" operand dup compiled-header-size ADD ; M: arm-backend %call-dispatch ( word-table# -- ) [ From b31440a574b1bf26117f68745c549f600e1c94ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 2 Nov 2007 14:26:04 -0400 Subject: [PATCH 02/55] Fix deployment, remove image compression since its useless and broken --- core/memory/memory.factor | 26 ------------------------- extra/tools/deploy/config/config.factor | 2 +- extra/tools/deploy/shaker/shaker.factor | 4 +--- 3 files changed, 2 insertions(+), 30 deletions(-) diff --git a/core/memory/memory.factor b/core/memory/memory.factor index 871838c3f3..0d684c3261 100644 --- a/core/memory/memory.factor +++ b/core/memory/memory.factor @@ -16,29 +16,3 @@ math strings combinators ; pusher >r each-object r> >array ; inline : save ( -- ) image save-image ; - - - -: compress-image ( -- ) - prepare-compress-image "bad-strings" [ - [ - { - { [ dup quotation? ] [ t ] } - { [ dup wrapper? ] [ t ] } - { [ dup fixnum? ] [ f ] } - { [ dup number? ] [ t ] } - { [ dup string? ] [ dup "bad-strings" get memq? not ] } - { [ t ] [ f ] } - } cond nip - ] intern-objects - ] with-variable ; diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index cebf39cbd0..da3daa91f1 100644 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -17,7 +17,7 @@ SYMBOL: deploy-io { 3 "Level 3 - Non-blocking streams and networking" } } ; -: strip-io? deploy-io get zero? ; +: strip-io? deploy-io get 1 = ; : native-io? deploy-io get 3 = ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 73c00cbd50..4531a88011 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -70,8 +70,8 @@ IN: tools.deploy.shaker strip-word-defs ; : strip-environment ( retain-globals -- ) - "Stripping environment" show strip-globals? [ + "Stripping environment" show global strip-assoc 21 setenv ] [ drop ] if ; @@ -160,8 +160,6 @@ SYMBOL: deploy-vocab deploy-vocab get require r> [ call ] when* strip - "Compressing image" show - compress-image finish-deploy ] [ print-error flush 1 exit From c3efd8a60d5d2a66e9f5ccee1e62ac6bcc12bcf8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 2 Nov 2007 14:41:19 -0500 Subject: [PATCH 03/55] Move heaps to core/ --- core/heaps/heaps-tests.factor | 32 ++++++++++ core/heaps/heaps.factor | 112 ++++++++++++++++++++++++++++++++++ 2 files changed, 144 insertions(+) create mode 100644 core/heaps/heaps-tests.factor create mode 100644 core/heaps/heaps.factor diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor new file mode 100644 index 0000000000..a8087916e7 --- /dev/null +++ b/core/heaps/heaps-tests.factor @@ -0,0 +1,32 @@ +! Copyright 2007 Ryan Murphy +! See http://factorcode.org/license.txt for BSD license. + +USING: kernel math tools.test heaps heaps.private ; +IN: temporary + +[ pop-heap ] unit-test-fails +[ pop-heap ] unit-test-fails + +[ t ] [ heap-empty? ] unit-test +[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ t ] [ heap-empty? ] unit-test +[ f ] [ 1 over push-heap heap-empty? ] unit-test + +! Binary Min Heap +{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test +{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test +{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test + +[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] +[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test + +[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ + { 3 5 4 6 5 7 6 8 } over push-heap* + 3 [ dup pop-heap* ] times +] unit-test + +[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test + +[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test + +[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor new file mode 100644 index 0000000000..2ff9096483 --- /dev/null +++ b/core/heaps/heaps.factor @@ -0,0 +1,112 @@ +! Copyright (C) 2007 Ryan Murphy, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math sequences ; +IN: heaps + + ( -- obj ) + V{ } clone heap construct-boa ; +PRIVATE> + +TUPLE: min-heap ; + +: ( -- obj ) + min-heap construct-delegate ; + +TUPLE: max-heap ; + +: ( -- obj ) + max-heap construct-delegate ; + +r left r> nth ; +: right-value ( n heap -- obj ) >r right r> nth ; +: up-value ( n vec -- obj ) >r up r> nth ; +: swap-up ( n vec -- ) >r dup up r> exchange ; +: last-index ( vec -- n ) length 1- ; + +GENERIC: heap-compare ( obj1 obj2 heap -- ? ) + +M: min-heap heap-compare drop <=> 0 > ; +M: max-heap heap-compare drop <=> 0 < ; + +: left-bounds-check? ( m heap -- ? ) + >r left r> heap-data length >= ; + +: right-bounds-check? ( m heap -- ? ) + >r right r> heap-data length >= ; + +: (up-heap) ( vec heap -- ) + [ + >r [ last-index ] keep [ up-value ] keep peek r> heap-compare + ] 2keep rot [ + >r dup last-index + [ over swap-up ] keep + up 1+ head-slice + r> (up-heap) + ] [ + 2drop + ] if ; + +: up-heap ( heap -- ) + [ heap-data ] keep (up-heap) ; + +: child ( m heap -- n ) + 2dup right-bounds-check? [ + drop left + ] [ + dupd + [ heap-data left-value ] 2keep + [ heap-data right-value ] keep heap-compare [ + right + ] [ + left + ] if + ] if ; + +: swap-down ( m heap -- ) + [ child ] 2keep heap-data exchange ; + +DEFER: down-heap + +: (down-heap) ( m heap -- ) + 2dup [ heap-data nth ] 2keep child pick + dupd [ heap-data nth swapd ] keep + heap-compare [ + -rot [ swap-down ] keep down-heap + ] [ + 3drop + ] if ; + +: down-heap ( m heap -- ) + 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; + +PRIVATE> + +: push-heap ( obj heap -- ) + tuck heap-data push up-heap ; + +: push-heap* ( seq heap -- ) + swap [ swap push-heap ] curry* each ; + +: peek-heap ( heap -- obj ) + heap-data first ; + +: pop-heap* ( heap -- ) + dup heap-data length 1 > [ + [ heap-data pop 0 ] keep + [ heap-data set-nth ] keep + >r 0 r> down-heap + ] [ + heap-data pop* + ] if ; + +: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; + +: heap-empty? ( heap -- ? ) + heap-data empty? ; From fe9563ece239cfba38d9b14c8f9765d7e1ccdcab Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 15:38:45 -0400 Subject: [PATCH 04/55] Move io.buffers to extra --- core/optimizer/known-words/known-words.factor | 4 +--- {core => extra}/io/buffers/authors.txt | 0 {core => extra}/io/buffers/buffers-docs.factor | 0 {core => extra}/io/buffers/buffers-tests.factor | 0 {core => extra}/io/buffers/buffers.factor | 4 +++- {core => extra}/io/buffers/summary.txt | 0 6 files changed, 4 insertions(+), 4 deletions(-) rename {core => extra}/io/buffers/authors.txt (100%) rename {core => extra}/io/buffers/buffers-docs.factor (100%) rename {core => extra}/io/buffers/buffers-tests.factor (100%) rename {core => extra}/io/buffers/buffers.factor (96%) rename {core => extra}/io/buffers/summary.txt (100%) diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index dffe18e630..40752c58a5 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -5,7 +5,7 @@ USING: alien arrays generic hashtables inference.dataflow inference.class kernel assocs math math.private kernel.private sequences words parser vectors strings sbufs io namespaces assocs quotations sequences.private io.binary io.crc32 -io.buffers io.streams.string layouts splitting math.intervals +io.streams.string layouts splitting math.intervals math.floats.private tuples tuples.private classes optimizer.def-use optimizer.backend optimizer.pattern-match float-arrays combinators.private ; @@ -148,5 +148,3 @@ float-arrays combinators.private ; \ >le { { fixnum bignum } fixnum } "specializer" set-word-prop \ >be { { fixnum bignum } fixnum } "specializer" set-word-prop - -\ search-buffer-until { fixnum fixnum simple-alien string } "specializer" set-word-prop diff --git a/core/io/buffers/authors.txt b/extra/io/buffers/authors.txt similarity index 100% rename from core/io/buffers/authors.txt rename to extra/io/buffers/authors.txt diff --git a/core/io/buffers/buffers-docs.factor b/extra/io/buffers/buffers-docs.factor similarity index 100% rename from core/io/buffers/buffers-docs.factor rename to extra/io/buffers/buffers-docs.factor diff --git a/core/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor similarity index 100% rename from core/io/buffers/buffers-tests.factor rename to extra/io/buffers/buffers-tests.factor diff --git a/core/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor similarity index 96% rename from core/io/buffers/buffers.factor rename to extra/io/buffers/buffers.factor index cb897c26d8..e58cf3ead0 100644 --- a/core/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. IN: io.buffers USING: alien alien.syntax kernel kernel.private libc math -sequences strings ; +sequences strings hints ; TUPLE: buffer size ptr fill pos ; @@ -54,6 +54,8 @@ TUPLE: buffer size ptr fill pos ; : search-buffer-until ( start end alien separators -- n ) [ >r swap alien-unsigned-1 r> memq? ] 2curry find* drop ; +HINTS: search-buffer-until { fixnum fixnum simple-alien string } ; + : finish-buffer-until ( buffer n -- string separator ) [ over buffer-pos - diff --git a/core/io/buffers/summary.txt b/extra/io/buffers/summary.txt similarity index 100% rename from core/io/buffers/summary.txt rename to extra/io/buffers/summary.txt From 83190f4680e03514b846d5fa4654a90e8de885c0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 15:41:39 -0400 Subject: [PATCH 05/55] Fix using in bootstra.ui.tools --- core/bootstrap/ui/tools/tools.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/bootstrap/ui/tools/tools.factor b/core/bootstrap/ui/tools/tools.factor index 52e4367b42..9dde428e72 100644 --- a/core/bootstrap/ui/tools/tools.factor +++ b/core/bootstrap/ui/tools/tools.factor @@ -1,4 +1,4 @@ -USING: kernel vocabs vocabs.loader sequences ; +USING: kernel vocabs vocabs.loader sequences system ; { "ui" "help" "tools" } [ "bootstrap." swap append vocab ] all? [ From 8584e7e95d7f4e7042a42c01cd791e46380752ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 15:42:30 -0400 Subject: [PATCH 06/55] Deploy tool can now strip out libc debugging --- extra/tools/deploy/deploy.factor | 4 ++-- extra/tools/deploy/shaker/shaker.factor | 15 +++++++++++++-- extra/tools/deploy/shaker/strip-libc.factor | 8 ++++++++ 3 files changed, 23 insertions(+), 4 deletions(-) create mode 100644 extra/tools/deploy/shaker/strip-libc.factor diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index 2832551a34..c11b41e09c 100644 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -37,8 +37,8 @@ IN: tools.deploy "" deploy-math? get " math" ?append deploy-compiler? get " compiler" ?append - native-io? " io" ?append deploy-ui? get " ui" ?append + native-io? " io" ?append ] bind ; : deploy-command-line ( vm image vocab config -- vm flags ) @@ -49,7 +49,7 @@ IN: tools.deploy "\"-output-image=" swap "\"" 3append , - "-no-stack-traces" , + ! "-no-stack-traces" , "-no-user-init" , ] { } make ; diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4531a88011..4b20c3f0ee 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -5,7 +5,7 @@ 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 ; +quotations words.private tools.deploy.config compiler ; IN: tools.deploy.shaker : show ( msg -- ) @@ -23,6 +23,15 @@ IN: tools.deploy.shaker "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file + recompile + ] when ; + +: strip-libc ( -- ) + "libc" vocab [ + "Stripping manual memory management debug code" show + "resource:extra/tools/deploy/shaker/strip-libc.factor" + run-file + recompile ] when ; : strip-cocoa ( -- ) @@ -30,6 +39,7 @@ IN: tools.deploy.shaker "Stripping unused Cocoa methods" show "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file + recompile ] when ; : strip-assoc ( retained-keys assoc -- newassoc ) @@ -126,7 +136,7 @@ SYMBOL: deploy-vocab } % ] unless - deploy-c-types? get deploy-ui? get or [ + deploy-c-types? get [ "c-types" "alien.c-types" lookup , ] when @@ -141,6 +151,7 @@ SYMBOL: deploy-vocab ] { } make dup . ; : strip ( -- ) + strip-libc strip-cocoa strip-debugger strip-init-hooks diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor new file mode 100644 index 0000000000..f62b4b5935 --- /dev/null +++ b/extra/tools/deploy/shaker/strip-libc.factor @@ -0,0 +1,8 @@ +USING: libc.private ; +IN: libc + +: malloc (malloc) ; + +: free (free) ; + +: realloc (realloc) ; From 1cac7d54a62942562efa1e3e398dbf31c35f4475 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 15:42:51 -0400 Subject: [PATCH 07/55] Move checkbox and radio button renders to ui.gadgets.buttons --- extra/ui/gadgets/buttons/buttons.factor | 24 +++++++++++++++++++++++ extra/ui/render/render.factor | 26 ------------------------- 2 files changed, 24 insertions(+), 26 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index bd5591fa32..a9142449e5 100644 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -95,6 +95,18 @@ repeat-button H{ repeat-button construct-empty [ >r r> set-gadget-delegate ] keep ; +TUPLE: checkmark-paint color ; + +C: checkmark-paint + +M: checkmark-paint draw-interior + checkmark-paint-color gl-color + origin get [ + rect-dim + { 0 0 } over gl-line + dup { 0 1 } v* swap { 1 0 } v* gl-line + ] with-translation ; + : checkmark-theme ( gadget -- ) f f @@ -125,6 +137,18 @@ repeat-button H{ [ set-button-selected? ] dup checkbox-theme ; +TUPLE: radio-paint color ; + +C: radio-paint + +M: radio-paint draw-interior + radio-paint-color gl-color + origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ; + +M: radio-paint draw-boundary + radio-paint-color gl-color + origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; + : radio-knob-theme ( gadget -- ) f f diff --git a/extra/ui/render/render.factor b/extra/ui/render/render.factor index 2c2f84c067..54615b08a2 100644 --- a/extra/ui/render/render.factor +++ b/extra/ui/render/render.factor @@ -140,32 +140,6 @@ M: polygon draw-interior >r r> over set-rect-dim [ set-gadget-interior ] keep ; -! Checkbox and radio button pens -TUPLE: checkmark-paint color ; - -C: checkmark-paint - -M: checkmark-paint draw-interior - checkmark-paint-color gl-color - origin get [ - rect-dim - { 0 0 } over gl-line - dup { 0 1 } v* swap { 1 0 } v* gl-line - ] with-translation ; - - -TUPLE: radio-paint color ; - -C: radio-paint - -M: radio-paint draw-interior - radio-paint-color gl-color - origin get { 4 4 } v+ swap rect-dim { 8 8 } v- 12 gl-fill-circle ; - -M: radio-paint draw-boundary - radio-paint-color gl-color - origin get { 1 1 } v+ swap rect-dim { 2 2 } v- 12 gl-circle ; - ! Font rendering SYMBOL: font-renderer From e0104549cb747318a582d3d74aefb0e0a9a0bac2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 16:22:40 -0400 Subject: [PATCH 08/55] Move channels to unmaintained for the time being, so that load-everything can work --- {extra => unmaintained}/channels/authors.txt | 0 {extra => unmaintained}/channels/channels-docs.factor | 0 {extra => unmaintained}/channels/channels-tests.factor | 0 {extra => unmaintained}/channels/channels.factor | 0 {extra => unmaintained}/channels/examples/authors.txt | 0 {extra => unmaintained}/channels/examples/examples.factor | 0 {extra => unmaintained}/channels/examples/summary.txt | 0 {extra => unmaintained}/channels/examples/tags.txt | 0 {extra => unmaintained}/channels/remote/authors.txt | 0 {extra => unmaintained}/channels/remote/remote-docs.factor | 0 {extra => unmaintained}/channels/remote/remote-tests.factor | 0 {extra => unmaintained}/channels/remote/remote.factor | 0 {extra => unmaintained}/channels/remote/summary.txt | 0 {extra => unmaintained}/channels/remote/tags.txt | 0 {extra => unmaintained}/channels/sniffer/bsd/bsd.factor | 0 {extra => unmaintained}/channels/sniffer/sniffer.factor | 0 {extra => unmaintained}/channels/summary.txt | 0 {extra => unmaintained}/channels/tags.txt | 0 18 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/channels/authors.txt (100%) rename {extra => unmaintained}/channels/channels-docs.factor (100%) rename {extra => unmaintained}/channels/channels-tests.factor (100%) rename {extra => unmaintained}/channels/channels.factor (100%) rename {extra => unmaintained}/channels/examples/authors.txt (100%) rename {extra => unmaintained}/channels/examples/examples.factor (100%) rename {extra => unmaintained}/channels/examples/summary.txt (100%) rename {extra => unmaintained}/channels/examples/tags.txt (100%) rename {extra => unmaintained}/channels/remote/authors.txt (100%) rename {extra => unmaintained}/channels/remote/remote-docs.factor (100%) rename {extra => unmaintained}/channels/remote/remote-tests.factor (100%) rename {extra => unmaintained}/channels/remote/remote.factor (100%) rename {extra => unmaintained}/channels/remote/summary.txt (100%) rename {extra => unmaintained}/channels/remote/tags.txt (100%) rename {extra => unmaintained}/channels/sniffer/bsd/bsd.factor (100%) rename {extra => unmaintained}/channels/sniffer/sniffer.factor (100%) rename {extra => unmaintained}/channels/summary.txt (100%) rename {extra => unmaintained}/channels/tags.txt (100%) diff --git a/extra/channels/authors.txt b/unmaintained/channels/authors.txt similarity index 100% rename from extra/channels/authors.txt rename to unmaintained/channels/authors.txt diff --git a/extra/channels/channels-docs.factor b/unmaintained/channels/channels-docs.factor similarity index 100% rename from extra/channels/channels-docs.factor rename to unmaintained/channels/channels-docs.factor diff --git a/extra/channels/channels-tests.factor b/unmaintained/channels/channels-tests.factor similarity index 100% rename from extra/channels/channels-tests.factor rename to unmaintained/channels/channels-tests.factor diff --git a/extra/channels/channels.factor b/unmaintained/channels/channels.factor similarity index 100% rename from extra/channels/channels.factor rename to unmaintained/channels/channels.factor diff --git a/extra/channels/examples/authors.txt b/unmaintained/channels/examples/authors.txt similarity index 100% rename from extra/channels/examples/authors.txt rename to unmaintained/channels/examples/authors.txt diff --git a/extra/channels/examples/examples.factor b/unmaintained/channels/examples/examples.factor similarity index 100% rename from extra/channels/examples/examples.factor rename to unmaintained/channels/examples/examples.factor diff --git a/extra/channels/examples/summary.txt b/unmaintained/channels/examples/summary.txt similarity index 100% rename from extra/channels/examples/summary.txt rename to unmaintained/channels/examples/summary.txt diff --git a/extra/channels/examples/tags.txt b/unmaintained/channels/examples/tags.txt similarity index 100% rename from extra/channels/examples/tags.txt rename to unmaintained/channels/examples/tags.txt diff --git a/extra/channels/remote/authors.txt b/unmaintained/channels/remote/authors.txt similarity index 100% rename from extra/channels/remote/authors.txt rename to unmaintained/channels/remote/authors.txt diff --git a/extra/channels/remote/remote-docs.factor b/unmaintained/channels/remote/remote-docs.factor similarity index 100% rename from extra/channels/remote/remote-docs.factor rename to unmaintained/channels/remote/remote-docs.factor diff --git a/extra/channels/remote/remote-tests.factor b/unmaintained/channels/remote/remote-tests.factor similarity index 100% rename from extra/channels/remote/remote-tests.factor rename to unmaintained/channels/remote/remote-tests.factor diff --git a/extra/channels/remote/remote.factor b/unmaintained/channels/remote/remote.factor similarity index 100% rename from extra/channels/remote/remote.factor rename to unmaintained/channels/remote/remote.factor diff --git a/extra/channels/remote/summary.txt b/unmaintained/channels/remote/summary.txt similarity index 100% rename from extra/channels/remote/summary.txt rename to unmaintained/channels/remote/summary.txt diff --git a/extra/channels/remote/tags.txt b/unmaintained/channels/remote/tags.txt similarity index 100% rename from extra/channels/remote/tags.txt rename to unmaintained/channels/remote/tags.txt diff --git a/extra/channels/sniffer/bsd/bsd.factor b/unmaintained/channels/sniffer/bsd/bsd.factor similarity index 100% rename from extra/channels/sniffer/bsd/bsd.factor rename to unmaintained/channels/sniffer/bsd/bsd.factor diff --git a/extra/channels/sniffer/sniffer.factor b/unmaintained/channels/sniffer/sniffer.factor similarity index 100% rename from extra/channels/sniffer/sniffer.factor rename to unmaintained/channels/sniffer/sniffer.factor diff --git a/extra/channels/summary.txt b/unmaintained/channels/summary.txt similarity index 100% rename from extra/channels/summary.txt rename to unmaintained/channels/summary.txt diff --git a/extra/channels/tags.txt b/unmaintained/channels/tags.txt similarity index 100% rename from extra/channels/tags.txt rename to unmaintained/channels/tags.txt From d366ced0a823b67d2e197355027488801d03de9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 3 Nov 2007 16:24:17 -0400 Subject: [PATCH 09/55] Fix load problem --- extra/ui/gadgets/buttons/buttons.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index a9142449e5..a4fc5a7c21 100644 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -4,7 +4,8 @@ USING: arrays ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render kernel math models namespaces sequences strings -quotations assocs combinators classes colors tuples ; +quotations assocs combinators classes colors tuples opengl +math.vectors ; IN: ui.gadgets.buttons TUPLE: button pressed? selected? quot ; From 1364674546202e2e4fe5139eb0463968b19d2f91 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sun, 4 Nov 2007 13:42:18 -0600 Subject: [PATCH 10/55] Added execv, and some constants used with waitpid to unix vocab --- extra/unix/unix.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index ca4b569587..0854754dcb 100644 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -107,6 +107,7 @@ FUNCTION: void close ( int fd ) ; FUNCTION: int connect ( int s, void* name, socklen_t namelen ) ; FUNCTION: int dup2 ( int oldd, int newd ) ; ! FUNCTION: int dup ( int oldd ) ; +FUNCTION: int execv ( char* path, char** argv ) ; FUNCTION: int execvp ( char* path, char** argv ) ; FUNCTION: int execve ( char* path, char** argv, char** envp ) ; FUNCTION: int fchdir ( int fd ) ; @@ -164,6 +165,18 @@ FUNCTION: int system ( char* command ) ; FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; + +! Flags for waitpid + +: WNOHANG 1 ; +: WUNTRACED 2 ; + +: WSTOPPED 2 ; +: WEXITED 4 ; +: WCONTINUED 8 ; +: WNOWAIT HEX: 1000000 ; + FUNCTION: pid_t wait ( int* status ) ; FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; + FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; From 7b3fee0b640b47df26b84ce79a7440dcbbd1766b Mon Sep 17 00:00:00 2001 From: "Zed A. Shaw" Date: Sun, 4 Nov 2007 17:23:33 -0500 Subject: [PATCH 11/55] Bug fix for range to restrict results to within assigned range. Tests for all range behavior. --- extra/models/models-tests.factor | 39 ++++++++++++++++++++++++++++++-- extra/models/models.factor | 2 +- 2 files changed, 38 insertions(+), 3 deletions(-) diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index 97751c1858..e47e1a66c3 100644 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,6 +1,6 @@ IN: temporary -USING: arrays generic kernel math models namespaces sequences -tools.test assocs ; +USING: arrays generic kernel math models namespaces sequences assocs +tools.test ; TUPLE: model-tester hit? ; @@ -137,3 +137,38 @@ f "history" set ] unit-test [ ] [ "m" get deactivate-model ] unit-test + +! Test +: setup-range 0 0 0 255 ; + +! clamp-value should not go past range ends +[ 0 ] [ -10 setup-range clamp-value ] unit-test +[ 255 ] [ 2000 setup-range clamp-value ] unit-test +[ 14 ] [ 14 setup-range clamp-value ] unit-test + +! range min/max/page values should be correct +[ 0 ] [ setup-range range-page-value ] unit-test +[ 0 ] [ setup-range range-min-value ] unit-test +[ 255 ] [ setup-range range-max-value ] unit-test + +! should be able to set the value within the range and get back +[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test +[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test +[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test + +! should be able to change the range min/max/page value +[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test +[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test +[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test + +! should be able to move by positive and negative values +[ 30 ] [ setup-range 30 over move-by range-value ] unit-test +[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test + +! should be able to move by a page of 10 +[ 10 ] [ + setup-range 10 over set-range-page-value + 1 over move-by-page range-value +] unit-test + + diff --git a/extra/models/models.factor b/extra/models/models.factor index 59f888b0e0..724d6e45f4 100644 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -207,7 +207,7 @@ M: range range-max-value range-max model-value ; M: range range-max-value* dup range-max-value swap range-page-value [-] ; -M: range set-range-value range-model set-model ; +M: range set-range-value [ clamp-value ] keep range-model set-model ; M: range set-range-page-value range-page set-model ; From dfeb154bb1ed28a9932d99ac161ccc303395786f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 17:32:01 -0500 Subject: [PATCH 12/55] Change unfold word --- core/bootstrap/image/image.factor | 2 +- core/classes/classes.factor | 2 +- core/io/io.factor | 2 +- core/sequences/sequences.factor | 10 ++++------ core/tuples/tuples.factor | 2 +- extra/concurrency/concurrency.factor | 2 +- extra/io/sockets/impl/impl.factor | 21 +++++++++++---------- extra/ui/gadgets/borders/borders.factor | 3 ++- extra/ui/gadgets/gadgets.factor | 4 ++-- 9 files changed, 24 insertions(+), 24 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index ba0e4800fb..f6f3e5c0da 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -157,7 +157,7 @@ GENERIC: ' ( obj -- ptr ) #! n is positive or zero. [ dup 0 > ] [ dup bignum-bits neg shift swap bignum-radix bitand ] - { } unfold ; + [ ] unfold nip ; : emit-bignum ( n -- ) dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq diff --git a/core/classes/classes.factor b/core/classes/classes.factor index a17866aa3b..d9f2c71f74 100644 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -133,7 +133,7 @@ PRIVATE> >vector [ dup empty? not ] [ dup largest-class >r over delete-nth r> ] - { } unfold ; + [ ] unfold nip ; : class-or ( class1 class2 -- class ) { diff --git a/core/io/io.factor b/core/io/io.factor index d00a208e4e..cc0d2cc8e5 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -86,7 +86,7 @@ SYMBOL: stdio presented associate format ; : lines ( stream -- seq ) - [ [ readln dup ] [ ] { } unfold ] with-stream ; + [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ; : contents ( stream -- str ) 2048 [ stream-copy ] keep >string ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index dedbbfc59d..2f6bb7ad57 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -414,12 +414,10 @@ PRIVATE> : interleave ( seq between quot -- ) [ (interleave) ] 2curry iterate-seq 2each ; inline -: unfold ( obj pred quot exemplar -- seq ) - [ - 10 swap new-resizable [ - [ push ] curry compose [ drop ] while - ] keep - ] keep like ; inline +: unfold ( pred quot tail -- seq ) + V{ } clone [ + swap >r [ push ] curry compose r> while + ] keep { } like ; inline : index ( obj seq -- n ) [ = ] curry* find drop ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index edd37abb65..4369a56d23 100644 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -107,7 +107,7 @@ M: tuple equal? [ dup , delegate (delegates) ] when* ; : delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] { } unfold ; + [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b59f758ad8..e885877a37 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -60,7 +60,7 @@ PRIVATE> (mailbox-block-if-empty) [ dup mailbox-empty? ] [ dup mailbox-data dlist-pop-front ] - { } unfold ; + [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) f mailbox-get-all* ; diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index b03ec94a6b..426eda9c76 100644 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -12,7 +12,10 @@ GENERIC: protocol-family ( addrspec -- af ) GENERIC: sockaddr-type ( addrspec -- type ) -GENERIC: make-sockaddr ( addrspec -- sockaddr type ) +GENERIC: make-sockaddr ( addrspec -- sockaddr ) + +: make-sockaddr/size ( addrspec -- sockaddr size ) + dup make-sockaddr swap sockaddr-type heap-size ; GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec ) @@ -36,16 +39,15 @@ M: inet4 address-size drop 4 ; M: inet4 protocol-family drop PF_INET ; -M: inet4 sockaddr-type drop "sockaddr-in" ; +M: inet4 sockaddr-type drop "sockaddr-in" c-type ; -M: inet4 make-sockaddr ( inet -- sockaddr type ) +M: inet4 make-sockaddr ( inet -- sockaddr ) "sockaddr-in" AF_INET over set-sockaddr-in-family over inet4-port htons over set-sockaddr-in-port over inet4-host "0.0.0.0" or - rot inet-pton *uint over set-sockaddr-in-addr - "sockaddr-in" ; + rot inet-pton *uint over set-sockaddr-in-addr ; M: inet4 parse-sockaddr >r dup sockaddr-in-addr r> inet-ntop @@ -65,15 +67,14 @@ M: inet6 address-size drop 16 ; M: inet6 protocol-family drop PF_INET6 ; -M: inet6 sockaddr-type drop "sockaddr-in6" ; +M: inet6 sockaddr-type drop "sockaddr-in6" c-type ; -M: inet6 make-sockaddr ( inet -- sockaddr type ) +M: inet6 make-sockaddr ( inet -- sockaddr ) "sockaddr-in6" AF_INET6 over set-sockaddr-in6-family over inet6-port htons over set-sockaddr-in6-port over inet6-host "::" or - rot inet-pton over set-sockaddr-in6-addr - "sockaddr-in6" ; + rot inet-pton over set-sockaddr-in6-addr ; M: inet6 parse-sockaddr >r dup sockaddr-in6-addr r> inet-ntop @@ -97,7 +98,7 @@ M: f parse-sockaddr nip ; : parse-addrinfo-list ( addrinfo -- seq ) [ dup ] [ dup addrinfo-next swap addrinfo>addrspec ] - { } unfold [ ] subset ; + [ ] unfold nip [ ] subset ; M: object resolve-host ( host serv passive? -- seq ) >r dup integer? [ number>string ] when diff --git a/extra/ui/gadgets/borders/borders.factor b/extra/ui/gadgets/borders/borders.factor index f0099e2f91..e58ba343c7 100644 --- a/extra/ui/gadgets/borders/borders.factor +++ b/extra/ui/gadgets/borders/borders.factor @@ -20,7 +20,8 @@ M: border pref-dim* : border-minor-rect ( major border -- rect ) gadget-child pref-dim - [ >r rect-bounds r> v- 2 v/n v+ ] keep ; + [ >r rect-bounds r> v- [ 2 / >fixnum ] map v+ ] keep + ; : scale-rect ( rect vec -- loc dim ) [ v* ] curry >r rect-bounds r> 2apply ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 214c5b4921..dddab1aa8a 100644 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -286,7 +286,7 @@ M: gadget ungraft* drop ; swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ dup ] [ [ gadget-parent ] keep ] { } unfold ; + [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -333,7 +333,7 @@ M: f request-focus-on 2drop ; dup focusable-child swap request-focus-on ; : focus-path ( world -- seq ) - [ dup ] [ [ gadget-focus ] keep ] { } unfold ; + [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline From de582084a40f66eedb3450a263e26d38968296bd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 17:32:18 -0500 Subject: [PATCH 13/55] Refactor I/O a bit so that C types are resolved at compile time -- better for deployment --- extra/io/unix/sockets/sockets.factor | 13 ++++++------- extra/io/windows/ce/ce.factor | 4 ++-- extra/io/windows/nt/sockets/sockets.factor | 9 ++++----- extra/io/windows/windows.factor | 2 +- 4 files changed, 13 insertions(+), 15 deletions(-) diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index 43c8224c2c..0787a1afde 100644 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -45,9 +45,9 @@ M: connect-task task-container drop write-tasks get-global ; [ swap add-io-task stop ] callcc0 drop ; M: unix-io (client) ( addrspec -- stream ) - dup make-sockaddr >r >r + dup make-sockaddr/size >r >r protocol-family SOCK_STREAM socket-fd - dup r> r> heap-size connect + dup r> r> connect zero? err_no EINPROGRESS = or [ dup init-client-socket dup handle>duplex-stream @@ -92,7 +92,7 @@ USE: io.sockets : server-fd ( addrspec type -- fd ) >r dup protocol-family r> socket-fd dup init-server-socket - dup rot make-sockaddr heap-size bind + dup rot make-sockaddr/size bind zero? [ dup close (io-error) ] unless ; M: unix-io ( addrspec -- stream ) @@ -190,20 +190,19 @@ M: send-task task-container drop write-tasks get ; M: unix-io send ( packet addrspec datagram -- ) 3dup check-datagram-send - [ >r make-sockaddr heap-size r> wait-send ] keep + [ >r make-sockaddr/size r> wait-send ] keep pending-error ; M: local protocol-family drop PF_UNIX ; -M: local sockaddr-type drop "sockaddr-un" ; +M: local sockaddr-type drop "sockaddr-un" c-type ; M: local make-sockaddr local-path dup length 1 + max-un-path > [ "Path too long" throw ] when "sockaddr-un" AF_UNIX over set-sockaddr-un-family - dup sockaddr-un-path rot string>char-alien dup length memcpy - "sockaddr-un" ; + dup sockaddr-un-path rot string>char-alien dup length memcpy ; M: local parse-sockaddr drop diff --git a/extra/io/windows/ce/ce.factor b/extra/io/windows/ce/ce.factor index 7023d88989..b45f2df4d7 100644 --- a/extra/io/windows/ce/ce.factor +++ b/extra/io/windows/ce/ce.factor @@ -153,7 +153,7 @@ M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ; : do-connect ( addrspec -- socket ) [ tcp-socket dup ] keep - make-sockaddr heap-size + make-sockaddr/size f f f f windows.winsock:WSAConnect zero? [ winsock-error-string throw ] unless ; @@ -227,7 +227,7 @@ M: windows-ce-io send ( packet addrspec datagram -- ) [ windows.winsock:set-WSABUF-len ] keep [ windows.winsock:set-WSABUF-buf ] keep - rot make-sockaddr heap-size + rot make-sockaddr/size >r >r 1 0 0 r> r> f f windows.winsock:WSASendTo zero? [ winsock-error-string throw diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor index 0767c08002..1b6288eb1d 100755 --- a/extra/io/windows/nt/sockets/sockets.factor +++ b/extra/io/windows/nt/sockets/sockets.factor @@ -29,8 +29,7 @@ TUPLE: ConnectEx-args port s* name* namelen* lpSendBuffer* dwSendDataLength* lpdwBytesSent* lpOverlapped* ptr* ; -: init-connect ( sockaddr sockaddr-name ConnectEx -- ) - >r heap-size r> +: init-connect ( sockaddr size ConnectEx -- ) [ set-ConnectEx-args-namelen* ] keep [ set-ConnectEx-args-name* ] keep f over set-ConnectEx-args-lpSendBuffer* @@ -55,7 +54,7 @@ TUPLE: ConnectEx-args port M: windows-nt-io (client) ( addrspec -- duplex-stream ) [ \ ConnectEx-args construct-empty - over make-sockaddr pick init-connect + over make-sockaddr/size pick init-connect over tcp-socket over set-ConnectEx-args-s* dup ConnectEx-args-s* add-completion dup ConnectEx-args-s* get-ConnectEx-ptr over set-ConnectEx-args-ptr* @@ -229,9 +228,9 @@ TUPLE: WSASendTo-args port >r delegate port-handle delegate win32-file-handle r> set-WSASendTo-args-s* ] keep [ - >r make-sockaddr >r + >r make-sockaddr/size >r malloc-byte-array dup free-always - r> heap-size r> + r> r> [ set-WSASendTo-args-iToLen* ] keep set-WSASendTo-args-lpTo* ] keep [ diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index f46af26568..8d6d7cb6f2 100644 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -175,7 +175,7 @@ USE: windows.winsock : server-fd ( addrspec type -- fd ) >r dup protocol-family r> open-socket dup close-socket-later - dup rot make-sockaddr heap-size bind socket-error ; + dup rot make-sockaddr/size bind socket-error ; USE: namespaces From 781bd15625ff394c921451d0b355d3c4b60e4134 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 17:33:18 -0500 Subject: [PATCH 14/55] Fix long line --- extra/models/models.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/models/models.factor b/extra/models/models.factor index 724d6e45f4..d76269eaf0 100644 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -207,7 +207,8 @@ M: range range-max-value range-max model-value ; M: range range-max-value* dup range-max-value swap range-page-value [-] ; -M: range set-range-value [ clamp-value ] keep range-model set-model ; +M: range set-range-value + [ clamp-value ] keep range-model set-model ; M: range set-range-page-value range-page set-model ; From 613cdb94290c05ac41e70a50699f743ee6170583 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 18:05:49 -0500 Subject: [PATCH 15/55] Documentation updates --- core/kernel/kernel-docs.factor | 14 ++++++++++++++ core/sequences/sequences-docs.factor | 14 +++++++++++++- 2 files changed, 27 insertions(+), 1 deletion(-) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 5251f2b231..84ee4fe5cf 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -60,6 +60,8 @@ $nl "A pair of utility words built from " { $link 2apply } ":" { $subsection both? } { $subsection either? } +"A looping combinator:" +{ $subsection while } "Quotations can be composed using efficient quotation-specific operations:" { $subsection curry } { $subsection 2curry } @@ -538,3 +540,15 @@ HELP: 3compose } "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." } ; + +HELP: while +{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } } +{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." } +{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used." +$nl +"Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:" +{ $code + "[ P ] [ Q ] [ T ] while" + "[ P ] [ Q ] [ ] while T" +} +"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." } ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index c8c5577eb1..072fc0da08 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -127,8 +127,9 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection 2reduce } "Mapping:" { $subsection map } -{ $subsection accumulate } { $subsection 2map } +{ $subsection accumulate } +{ $subsection unfold } "Filtering:" { $subsection push-if } { $subsection subset } ; @@ -230,6 +231,7 @@ $nl { $subsection "sequences-tests" } { $subsection "sequences-search" } { $subsection "sequences-comparing" } +{ $subsection "sequences-split" } { $subsection "sequences-destructive" } { $subsection "sequences-stacks" } "For inner loops:" @@ -961,3 +963,13 @@ HELP: supremum { $values { "seq" "a sequence of real numbers" } { "n" "a number" } } { $description "Outputs the greatest element of " { $snippet "seq" } "." } { $errors "Throws an error if the sequence is empty." } ; + +HELP: unfold +{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation with stack effect " { $snippet "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } } +{ $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." } +{ $examples + "The following example divides a number by two until we reach zero, and accumulates intermediate results:" + { $example "1337 [ dup 0 > ] [ 2/ dup ] [ ] unfold nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } + "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link unfold } " call:" + { $unchecked-example "[ 10 random dup 1 > ] [ ] [ drop ] unfold ." "{ 8 2 2 9 }" } +} ; From 4cc86d74ffb9f746c95676da30f3eea02960fccc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 18:06:34 -0500 Subject: [PATCH 16/55] Update more libraries for unfold change --- extra/help/crossref/crossref.factor | 2 +- extra/serialize/serialize.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/help/crossref/crossref.factor b/extra/help/crossref/crossref.factor index 9597a51471..d7f4ec8b1b 100644 --- a/extra/help/crossref/crossref.factor +++ b/extra/help/crossref/crossref.factor @@ -14,7 +14,7 @@ M: link uses collect-elements [ \ f or ] map ; : help-path ( topic -- seq ) - [ dup ] [ [ article-parent ] keep ] { } unfold 1 tail ; + [ dup ] [ [ article-parent ] keep ] [ ] unfold nip 1 tail ; : set-article-parents ( parent article -- ) article-children [ set-article-parent ] curry* each ; diff --git a/extra/serialize/serialize.factor b/extra/serialize/serialize.factor index 632ed763fb..fd04c86e03 100644 --- a/extra/serialize/serialize.factor +++ b/extra/serialize/serialize.factor @@ -261,7 +261,7 @@ DEFER: (deserialize) ( -- obj ) V{ } clone serialized rot with-variable ; inline : deserialize-sequence ( -- seq ) - [ [ deserialize* ] [ ] { } unfold ] with-serialized ; + [ [ deserialize* ] [ ] [ drop ] unfold ] with-serialized ; : deserialize ( -- obj ) [ (deserialize) ] with-serialized ; From 092d18d1b945c6b3fcbc507419561bcae907700a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 18:06:47 -0500 Subject: [PATCH 17/55] OpenGL errors are now thrown instaed of just being printed --- extra/opengl/opengl.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index d796c2611d..fbd935da4c 100644 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,8 +1,9 @@ ! 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 math.constants math.functions opengl.gl opengl.glu combinators arrays ; +USING: alien alien.c-types kernel math namespaces sequences +math.vectors math.constants math.functions opengl.gl opengl.glu +combinators arrays ; IN: opengl : coordinates [ first2 ] 2apply ; @@ -19,7 +20,7 @@ IN: opengl : gl-error ( -- ) glGetError dup zero? [ - "GL error: " write dup gluErrorString print flush + "GL error: " dup gluErrorString append throw ] unless drop ; : do-state ( what quot -- ) From 72c1276837ed5ff786d955284cf14011ba175b7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 18:07:03 -0500 Subject: [PATCH 18/55] Update editors docs --- extra/editors/editors-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/editors/editors-docs.factor b/extra/editors/editors-docs.factor index 9fa505351a..2b9e4cc021 100644 --- a/extra/editors/editors-docs.factor +++ b/extra/editors/editors-docs.factor @@ -4,8 +4,8 @@ IN: editors ARTICLE: "editor" "Editor integration" "Factor development is best done with one of the supported editors; this allows you to quickly jump to definitions from the Factor environment." { $subsection edit } -"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } "." -$nl +"Depending on the editor you are using, you must load one of the child vocabularies of the " { $vocab-link "editors" } " vocabulary, for example " { $vocab-link "editors.emacs" } ", for example:" +{ $code "USE: editors.emacs" } "Editor integration vocabularies store a quotation in a global variable when loaded:" { $subsection edit-hook } "If a syntax error was thrown while loading a source file, you can jump to the location of the error in your editor:" From cf39de0a334b5c78bd0bc77d7f28e06a904647bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 18:07:11 -0500 Subject: [PATCH 19/55] Remove breakpoints from extra/mad --- extra/mad/api/api.factor | 1 - extra/mad/player/player.factor | 1 - 2 files changed, 2 deletions(-) diff --git a/extra/mad/api/api.factor b/extra/mad/api/api.factor index 4905424300..e3178b95f9 100644 --- a/extra/mad/api/api.factor +++ b/extra/mad/api/api.factor @@ -52,7 +52,6 @@ VARS: buffer-start buffer-length output-callback-var ; : output ( data header pcm -- mad_flow ) "output" . flush - break -rot 2drop output-callback-var> call [ MAD_FLOW_CONTINUE ] [ MAD_FLOW_STOP ] if ; diff --git a/extra/mad/player/player.factor b/extra/mad/player/player.factor index 417fc5145b..3d0b1c16c2 100644 --- a/extra/mad/player/player.factor +++ b/extra/mad/player/player.factor @@ -47,7 +47,6 @@ VARS: openal-buffer ; malloc [ fill-data ] keep ; : output-openal ( pcm -- ? ) - break openal-buffer> swap ! buffer pcm [ get-format ] keep ! buffer format pcm [ get-data ] keep ! buffer format size alien pcm From 943fe1b6cf36de2f94f4db8cb5928335388b476c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 21:24:08 -0500 Subject: [PATCH 20/55] Deploy tool fixes --- core/alien/c-types/c-types.factor | 2 +- extra/tools/deploy/shaker/shaker.factor | 1 + extra/tools/deploy/shaker/strip-libc.factor | 2 ++ 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 234e6ef65b..f35981ce77 100644 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -29,7 +29,7 @@ TUPLE: no-c-type name ; dup string? [ (c-type) ] when ] when ; -GENERIC: c-type ( name -- type ) +GENERIC: c-type ( name -- type ) foldable : resolve-pointer-type ( name -- name ) c-types get at dup string? diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 4b20c3f0ee..5dee50398c 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -16,6 +16,7 @@ IN: tools.deploy.shaker : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at + "mallocs" init-hooks get delete-at strip-io? [ "io.backend" init-hooks get delete-at ] when ; : strip-debugger ( -- ) diff --git a/extra/tools/deploy/shaker/strip-libc.factor b/extra/tools/deploy/shaker/strip-libc.factor index f62b4b5935..898399b092 100644 --- a/extra/tools/deploy/shaker/strip-libc.factor +++ b/extra/tools/deploy/shaker/strip-libc.factor @@ -6,3 +6,5 @@ IN: libc : free (free) ; : realloc (realloc) ; + +: calloc (calloc) ; From 4485bc0c01ef002c323d918959203103e4167d55 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 21:24:22 -0500 Subject: [PATCH 21/55] Remove code duplication --- extra/ui/gadgets/canvas/canvas.factor | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/extra/ui/gadgets/canvas/canvas.factor b/extra/ui/gadgets/canvas/canvas.factor index 5a013113b8..a1fb95cdbf 100644 --- a/extra/ui/gadgets/canvas/canvas.factor +++ b/extra/ui/gadgets/canvas/canvas.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.worlds -ui.render opengl opengl.gl kernel namespaces tuples colors ; +USING: ui.backend ui.gadgets ui.gadgets.theme ui.gadgets.lib +ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces +tuples colors ; IN: ui.gadgets.canvas TUPLE: canvas dlist ; @@ -10,9 +11,6 @@ TUPLE: canvas dlist ; canvas construct-gadget dup black solid-interior ; -: find-gl-context ( gadget -- ) - find-world world-handle select-gl-context ; - : delete-canvas-dlist ( canvas -- ) dup find-gl-context dup canvas-dlist [ delete-dlist ] when* From ac8b30a30ef0d54faa6d989816b77bf296c15115 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 21:24:50 -0500 Subject: [PATCH 22/55] Remove erronous tags --- extra/lint/tags.txt | 1 - 1 file changed, 1 deletion(-) delete mode 100644 extra/lint/tags.txt diff --git a/extra/lint/tags.txt b/extra/lint/tags.txt deleted file mode 100644 index 90cd671f56..0000000000 --- a/extra/lint/tags.txt +++ /dev/null @@ -1 +0,0 @@ -lint refactor From 667f26249e3043cca543da68c70a742ceda85077 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 22:51:34 -0500 Subject: [PATCH 23/55] Small fixes --- extra/icfp/2006/2006.factor | 2 +- extra/lsys/summary.txt | 2 +- extra/math/quadratic/quadratic.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/icfp/2006/2006.factor b/extra/icfp/2006/2006.factor index 2b42cddc6a..90ac9dc03e 100644 --- a/extra/icfp/2006/2006.factor +++ b/extra/icfp/2006/2006.factor @@ -4,7 +4,7 @@ USING: kernel math sequences kernel.private namespaces arrays io io.files splitting io.binary math.functions vectors quotations combinators.private ; -IN: universal-machine +IN: icfp.2006 SYMBOL: regs SYMBOL: arrays diff --git a/extra/lsys/summary.txt b/extra/lsys/summary.txt index bce1465e98..2615e85329 100644 --- a/extra/lsys/summary.txt +++ b/extra/lsys/summary.txt @@ -1 +1 @@ -L-system explorer +Lindenmayer system explorer diff --git a/extra/math/quadratic/quadratic.factor b/extra/math/quadratic/quadratic.factor index 979e20599b..2253582623 100644 --- a/extra/math/quadratic/quadratic.factor +++ b/extra/math/quadratic/quadratic.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.functions ; -IN: quadratic +IN: math.quadratic : monic ( c b a -- c' b' ) tuck / >r / r> ; From 206bf56b302a5d7ee8acfc89c450aff21031744a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 22:52:25 -0500 Subject: [PATCH 24/55] Add deploy-word-defs? deploy flag to make lsys happy --- extra/tools/deploy/config/config-docs.factor | 50 ++++++++++++++++---- extra/tools/deploy/config/config.factor | 2 + extra/tools/deploy/shaker/shaker.factor | 5 +- extra/ui/tools/deploy/deploy.factor | 1 + 4 files changed, 48 insertions(+), 10 deletions(-) diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor index 1528fe0015..31f4883cf8 100644 --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -9,10 +9,11 @@ ARTICLE: "deploy-config" "Deployment configuration" { $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 } ; +{ $subsection set-deploy-flag } +"The " { $link "ui.tools.deploy" } " provides a graphical way of editing the configuration." ; 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:" +"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:" { $subsection deploy-math? } { $subsection deploy-compiler? } { $subsection deploy-ui? } @@ -34,10 +35,26 @@ HELP: deploy-word-props? $nl "Off by default. Enable this if the heuristics strip out required word properties." } ; -HELP: deploy-c-types? -{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table." +HELP: deploy-word-defs? +{ $description "Deploy flag. If set, the deploy tool retains word definition quotations for words compiled with the optimizing compiler. Otherwise, word definitions are stripped from words compiled with the optimizing compiler." $nl -"Off 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." } ; +"Off by default. During normal execution, the word definition quotation of a word compiled with the optimizing compiler is not used, so disabling this flag can save space. However, some libraries introspect word definitions dynamically (for example, " { $link "inverse" } ") and so programs using these libraries must retain word definition quotations." } ; + +HELP: deploy-c-types? +{ $description "Deploy flag. If set, the deploy tool retains the " { $link c-types } " table, otherwise this table is stripped out, saving space." +$nl +"Off by default." +$nl +"The optimizing compiler is able to fold away calls to various words which take a C type as an input if the C type is a literal string:" +{ $list + { $link c-type } + { $link heap-size } + { $link } + { $link } + { $link malloc-object } + { $link malloc-array } +} +"If your program looks up C types dynamically or from words which do not have a stack effect, you must enable this flag, because in these situations the C type lookup is not folded away and the global table must be consulted at runtime." } ; HELP: deploy-math? { $description "Deploy flag. If set, the deployed image will contain support for " { $link ratio } " and " { $link complex } " types." @@ -45,7 +62,7 @@ $nl "On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ; HELP: deploy-compiler? -{ $description "Deploy flag. If set, words in the deployed image will be compiled when possible." +{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler 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." } ; @@ -55,10 +72,27 @@ $nl "Off by default. Programs wishing to use the UI must be deployed with this flag on." } ; HELP: deploy-io -{ $description "The level of I/O support required by the deployed image." } ; +{ $description "The level of I/O support required by the deployed image:" + { $table + { "Value" "Description" } + { "1" "No input/output" } + { "2" "Basic ANSI C streams" } + { "3" "Non-blocking streams and networking" } + } +"The default value is 1, basic ANSI C streams. This enables basic console and file I/O, however more advanced features such are not available." } ; HELP: deploy-reflection -{ $description "The level of reflection support required by the deployed image." } ; +{ $description "The level of reflection support required by the deployed image." + { $table + { "Value" "Description" } + { "1" "No reflection" } + { "2" "Retain word names" } + { "3" "Prettyprinter" } + { "4" "Debugger" } + { "5" "Parser" } + { "6" "Full environment" } + } +"The defalut value is 1, no reflection. Programs which use the above features will need to be deployed with a higher level of reflection support." } ; HELP: default-config { $values { "assoc" assoc } } diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index da3daa91f1..694eb36e0b 100644 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -40,6 +40,7 @@ SYMBOL: deploy-reflection : strip-globals? deploy-reflection get 6 < ; SYMBOL: deploy-word-props? +SYMBOL: deploy-word-defs? SYMBOL: deploy-c-types? SYMBOL: deploy-vm @@ -53,6 +54,7 @@ SYMBOL: deploy-image { deploy-compiler? t } { deploy-math? t } { deploy-word-props? f } + { deploy-word-defs? f } { deploy-c-types? f } ! default value for deploy.app { "stop-after-last-window?" t } diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 5dee50398c..52e1486199 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -76,9 +76,10 @@ IN: tools.deploy.shaker : strip-words ( props -- ) [ word? ] instances - deploy-word-props? get [ nip ] [ tuck strip-word-props ] if + deploy-word-props? get [ 2dup strip-word-props ] unless + deploy-word-defs? get [ dup strip-word-defs ] unless strip-word-names? [ dup strip-word-names ] when - strip-word-defs ; + 2drop ; : strip-environment ( retain-globals -- ) strip-globals? [ diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index 5a1851d1b3..297d9e0614 100644 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -35,6 +35,7 @@ TUPLE: deploy-gadget vocab settings ; deploy-compiler? get "Use optimizing compiler" gadget, deploy-math? get "Rational and complex number support" gadget, deploy-word-props? get "Include word properties" gadget, + deploy-word-defs? get "Include word definitions" gadget, deploy-c-types? get "Include C types" gadget, ; : deploy-settings-theme From a4f8bf05b90b4fd3c35106455ed64ff62804ae39 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 22:58:00 -0500 Subject: [PATCH 25/55] Update deploy configs for various modules --- extra/automata/ui/deploy.factor | 16 ++++++---------- extra/boids/ui/deploy.factor | 15 +++++++-------- extra/bunny/deploy.factor | 14 +++++++------- extra/catalyst-talk/deploy.factor | 12 ++++++++++++ extra/color-picker/deploy.factor | 16 ++++++++-------- extra/gesture-logger/deploy.factor | 15 +++++++-------- extra/golden-section/deploy.factor | 17 ++++++----------- extra/hello-ui/deploy.factor | 18 +++++++----------- extra/hello-world/deploy.factor | 17 +++++++---------- extra/lsys/ui/deploy.factor | 20 ++++++++++---------- extra/maze/deploy.factor | 15 +++++++-------- extra/nehe/deploy.factor | 17 ++++++++--------- extra/tetris/deploy.factor | 15 +++++++-------- 13 files changed, 99 insertions(+), 108 deletions(-) create mode 100644 extra/catalyst-talk/deploy.factor diff --git a/extra/automata/ui/deploy.factor b/extra/automata/ui/deploy.factor index eb261ed93f..1aa5a2883a 100644 --- a/extra/automata/ui/deploy.factor +++ b/extra/automata/ui/deploy.factor @@ -1,16 +1,12 @@ USING: tools.deploy.config ; 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? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } { "stop-after-last-window?" t } { "bundle-name" "Cellular Automata.app" } } diff --git a/extra/boids/ui/deploy.factor b/extra/boids/ui/deploy.factor index 0b22fa5200..e272a277e4 100644 --- a/extra/boids/ui/deploy.factor +++ b/extra/boids/ui/deploy.factor @@ -1,13 +1,12 @@ USING: tools.deploy.config ; 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 } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } { "bundle-name" "Boids.app" } } diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor index 889bae3d12..d2c84582a5 100644 --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -1,12 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-word-props? t } - { strip-word-names? t } - { strip-dictionary? t } - { strip-debugger? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? t } { deploy-ui? t } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } { "bundle-name" "Bunny.app" } } diff --git a/extra/catalyst-talk/deploy.factor b/extra/catalyst-talk/deploy.factor new file mode 100644 index 0000000000..506270fa55 --- /dev/null +++ b/extra/catalyst-talk/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "catalyst-talk.app" } +} diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor index ebce45177b..d16b74d076 100644 --- a/extra/color-picker/deploy.factor +++ b/extra/color-picker/deploy.factor @@ -1,12 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-word-props? t } - { strip-word-names? t } - { strip-dictionary? t } - { strip-debugger? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } { deploy-ui? t } - { "bundle-name" "Color Picker.app" } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "color-picker.app" } } diff --git a/extra/gesture-logger/deploy.factor b/extra/gesture-logger/deploy.factor index 5e412987f0..782b996895 100644 --- a/extra/gesture-logger/deploy.factor +++ b/extra/gesture-logger/deploy.factor @@ -1,13 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-word-props? t } - { strip-word-names? f } - { strip-dictionary? t } - { strip-debugger? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } { deploy-ui? t } - { strip-prettyprint? f } + { deploy-io 1 } + { deploy-reflection 3 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } { "bundle-name" "Gesture Logger.app" } } diff --git a/extra/golden-section/deploy.factor b/extra/golden-section/deploy.factor index 3923d258f0..a41d1b33c6 100644 --- a/extra/golden-section/deploy.factor +++ b/extra/golden-section/deploy.factor @@ -1,17 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-io? t } - { 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? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } { "stop-after-last-window?" t } { "bundle-name" "Golden Section.app" } } diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor index 2f346e94c6..bb819f5ce2 100644 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,16 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-prettyprint? t } - { strip-globals? t } - { strip-word-props? t } - { strip-word-names? f } - { strip-dictionary? t } - { strip-debugger? t } - { strip-c-types? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Hello World.app" } + { "bundle-name" "Hello world.app" } } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 145f7ecea7..7af1913d93 100644 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,15 +1,12 @@ USING: tools.deploy.config ; 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? f } - { deploy-compiled? f } - { deploy-io? f } { deploy-ui? f } + { deploy-io 3 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? f } + { deploy-word-props? f } + { deploy-c-types? f } { "stop-after-last-window?" t } + { "bundle-name" "Hello world (console).app" } } diff --git a/extra/lsys/ui/deploy.factor b/extra/lsys/ui/deploy.factor index 22b6d0e4a3..de5076cac0 100644 --- a/extra/lsys/ui/deploy.factor +++ b/extra/lsys/ui/deploy.factor @@ -1,13 +1,13 @@ -USING: tools.deploy ; +USING: tools.deploy.config ; 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" } + { deploy-io 1 } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? t } + { deploy-word-defs? t } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "Lindenmayer System Explorer.app" } } diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor index 31818c30c3..123412f4a3 100644 --- a/extra/maze/deploy.factor +++ b/extra/maze/deploy.factor @@ -1,13 +1,12 @@ USING: tools.deploy.config ; V{ - { strip-word-props? t } - { strip-word-names? f } - { strip-dictionary? t } - { strip-debugger? t } - { strip-c-types? t } - { deploy-math? t } - { deploy-compiled? t } - { deploy-io? f } { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } { "bundle-name" "Maze.app" } } diff --git a/extra/nehe/deploy.factor b/extra/nehe/deploy.factor index b464d735ce..cbd31d67b1 100644 --- a/extra/nehe/deploy.factor +++ b/extra/nehe/deploy.factor @@ -1,13 +1,12 @@ USING: tools.deploy.config ; 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" "NeHe Demos.app" } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "NeHe OpenGL demos.app" } } diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor index 61fd0a545c..c00b7041db 100644 --- a/extra/tetris/deploy.factor +++ b/extra/tetris/deploy.factor @@ -1,13 +1,12 @@ USING: tools.deploy.config ; 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 } + { deploy-io 1 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } { "bundle-name" "Tetris.app" } } From b2d2b47610e8ea12836357740e1e4fa898bf02f7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 4 Nov 2007 23:18:05 -0500 Subject: [PATCH 26/55] ARM fixes --- core/alien/compiler/compiler.factor | 2 +- core/cpu/architecture/architecture.factor | 7 ++- core/cpu/arm/architecture/architecture.factor | 50 ++++++++++++------- core/cpu/ppc/architecture/architecture.factor | 2 +- core/cpu/x86/architecture/architecture.factor | 2 +- core/generator/generator.factor | 4 +- vm/cpu-arm.S | 5 ++ 7 files changed, 47 insertions(+), 25 deletions(-) mode change 100644 => 100755 core/cpu/architecture/architecture.factor diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index c6a3623666..9c686bd4aa 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -387,7 +387,7 @@ TUPLE: callback-context ; dup alien-callback-xt dup rot [ init-templates generate-profiler-prologue - %save-xt + %save-word-xt %prologue-later dup alien-stack-frame [ dup registers>objects diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor old mode 100644 new mode 100755 index 1fa4ab2abf..167014983e --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -50,7 +50,12 @@ HOOK: %epilogue compiler-backend ( n -- ) HOOK: %profiler-prologue compiler-backend ( word -- ) ! Store word XT in stack frame -HOOK: %save-xt compiler-backend ( -- ) +HOOK: %save-word-xt compiler-backend ( -- ) + +! Store dispatch branch XT in stack frame +HOOK: %save-dispatch-xt compiler-backend ( -- ) + +M: object %save-dispatch-xt %save-word-xt ; ! Call another label HOOK: %call-label compiler-backend ( label -- ) diff --git a/core/cpu/arm/architecture/architecture.factor b/core/cpu/arm/architecture/architecture.factor index 4e2a363db3..0784b3af60 100755 --- a/core/cpu/arm/architecture/architecture.factor +++ b/core/cpu/arm/architecture/architecture.factor @@ -47,6 +47,16 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap <+/-> ; "end" resolve-label ] with-scope ; +: call-cell ( -- ) + ! Compute return address; we skip 3 instructions + LR PC 8 ADD + ! Load target address + R12 PC 0 <+> LDR + ! Jump to target address + R12 BX + ! The target address + 0 , ; + M: arm-backend load-indirect ( obj reg -- ) tuck load-cell rc-absolute-cell rel-literal dup 0 <+> LDR ; @@ -66,9 +76,12 @@ M: immediate load-literal M: arm-backend stack-frame ( n -- i ) factor-area-size + 8 align ; -M: arm-backend %save-xt ( -- ) +M: arm-backend %save-word-xt ( -- ) R12 PC 9 cells SUB ; +M: arm-backend %save-dispatch-xt ( -- ) + R12 PC 2 cells SUB ; + M: arm-backend %prologue ( n -- ) SP SP pick SUB R11 over MOV @@ -98,31 +111,36 @@ M: arm-backend %call-label ( label -- ) BL ; M: arm-backend %jump-label ( label -- ) B ; -: %prepare-primitive ( word -- ) +: %prepare-primitive ( -- ) #! Save stack pointer to stack_chain->callstack_top, load XT - R1 SP MOV - T{ temp-reg } load-literal - R12 R12 word-xt-offset <+> LDR ; + R1 SP MOV ; M: arm-backend %call-primitive ( word -- ) - %prepare-primitive R12 BLX ; + %prepare-primitive + call-cell rc-absolute-cell rel-word ; M: arm-backend %jump-primitive ( word -- ) - %prepare-primitive R12 BX ; + %prepare-primitive + ! Load target address + R12 PC 0 <+> LDR + ! Jump to target address + R12 BX + ! The target address + 0 , rc-absolute-cell rel-word ; M: arm-backend %jump-t ( label -- ) "flag" operand f v>operand CMP NE B ; -: (%dispatch) ( word-table# reg -- ) +: (%dispatch) ( word-table# -- ) #! Load jump table target address into reg. "scratch" operand PC "n" operand 1 ADD - "scratch" operand 0 <+> LDR + "scratch" operand dup 0 <+> LDR rc-indirect-arm rel-dispatch "scratch" operand dup compiled-header-size ADD ; M: arm-backend %call-dispatch ( word-table# -- ) [ - "scratch" operand (%dispatch) + (%dispatch) "scratch" operand BLX ] H{ { +input+ { { f "n" } } } @@ -132,7 +150,8 @@ M: arm-backend %call-dispatch ( word-table# -- ) M: arm-backend %jump-dispatch ( word-table# -- ) [ %epilogue-later - PC (%dispatch) + (%dispatch) + "scratch" operand BX ] H{ { +input+ { { f "n" } } } { +scratch+ { { f "scratch" } } } @@ -260,14 +279,7 @@ M: arm-backend %prepare-alien-invoke rs-reg R12 12 <+> STR ; M: arm-backend %alien-invoke ( symbol dll -- ) - ! Load target address - R12 PC 4 <+> LDR - ! Store address of next instruction in LR - LR PC 4 ADD - ! Jump to target address - R12 BX - ! The target address - 0 , rc-absolute rel-dlsym ; + call-cell rc-absolute-cell rel-dlsym ; M: arm-backend %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 9dd6c9c6c8..28bfb8c09c 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -76,7 +76,7 @@ M: ppc-backend load-indirect ( obj reg -- ) [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep dup 0 LWZ ; -M: ppc-backend %save-xt ( -- ) +M: ppc-backend %save-word-xt ( -- ) 0 11 LOAD32 rc-absolute-ppc-2/2 rel-current-word ; M: ppc-backend %prologue ( n -- ) diff --git a/core/cpu/x86/architecture/architecture.factor b/core/cpu/x86/architecture/architecture.factor index 672520c23d..ac26705664 100755 --- a/core/cpu/x86/architecture/architecture.factor +++ b/core/cpu/x86/architecture/architecture.factor @@ -44,7 +44,7 @@ M: immediate load-literal v>operand swap v>operand MOV ; M: x86-backend stack-frame ( n -- i ) 3 cells + 16 align cell - ; -M: x86-backend %save-xt ( -- ) +M: x86-backend %save-word-xt ( -- ) xt-reg 0 MOV rc-absolute-cell rel-current-word ; : factor-area-size 4 cells ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 77f45dc70d..be382b565d 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -60,7 +60,7 @@ GENERIC: generate-node ( node -- next ) [ init-templates generate-profiler-prologue - %save-xt + %save-word-xt %prologue-later current-label-start define-label current-label-start resolve-label @@ -189,7 +189,7 @@ M: #if generate-node gensym [ rot [ copy-templates - %save-xt + %save-dispatch-xt %prologue-later [ generate-nodes ] with-node-iterator ] generate-1 diff --git a/vm/cpu-arm.S b/vm/cpu-arm.S index ba49eb8fdb..35740f9c45 100755 --- a/vm/cpu-arm.S +++ b/vm/cpu-arm.S @@ -124,3 +124,8 @@ DEF(void,lazy_jit_compile,(CELL quot)): bl MANGLE(primitive_jit_compile) EPILOGUE JUMP_QUOT /* call the quotation */ + +#ifdef WINCE + .section .drectve + .ascii " -export:c_to_factor" +#endif From 6d2f1bc4bd6d9c8477f356f41c703be8e7946c0a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 00:45:02 -0500 Subject: [PATCH 27/55] Rename parent-dir to parent-directory, add copy-file and copy-directory words, start Windows deploy tool --- core/io/files/files-docs.factor | 6 +-- core/io/files/files.factor | 32 +++++++++++---- extra/tools/deploy/config/config-docs.factor | 9 +++- extra/tools/deploy/config/config.factor | 15 ++++--- extra/tools/deploy/deploy.factor | 12 ++++-- .../{app/app.factor => macosx/macosx.factor} | 39 ++++++++---------- .../tools/deploy/{app => macosx}/summary.txt | 0 extra/tools/deploy/{app => macosx}/tags.txt | 0 extra/tools/deploy/windows/summary.txt | 1 + extra/tools/deploy/windows/tags.txt | 1 + extra/tools/deploy/windows/windows.factor | 41 +++++++++++++++++++ 11 files changed, 113 insertions(+), 43 deletions(-) mode change 100644 => 100755 core/io/files/files-docs.factor mode change 100644 => 100755 core/io/files/files.factor mode change 100644 => 100755 extra/tools/deploy/config/config-docs.factor mode change 100644 => 100755 extra/tools/deploy/config/config.factor mode change 100644 => 100755 extra/tools/deploy/deploy.factor rename extra/tools/deploy/{app/app.factor => macosx/macosx.factor} (65%) mode change 100644 => 100755 rename extra/tools/deploy/{app => macosx}/summary.txt (100%) rename extra/tools/deploy/{app => macosx}/tags.txt (100%) create mode 100644 extra/tools/deploy/windows/summary.txt create mode 100644 extra/tools/deploy/windows/tags.txt create mode 100755 extra/tools/deploy/windows/windows.factor diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor old mode 100644 new mode 100755 index 66524959a2..fba91ded0a --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -7,7 +7,7 @@ ARTICLE: "file-streams" "Reading and writing files" { $subsection } { $subsection } "Pathname manipulation:" -{ $subsection parent-dir } +{ $subsection parent-directory } { $subsection file-name } { $subsection last-path-separator } { $subsection path+ } @@ -101,10 +101,10 @@ HELP: file-modified { $values { "path" "a pathname string" } { "n" "a non-negative integer or " { $link f } } } { $description "Outputs a file's last modification time, since midnight January 1, 1970. If the file does not exist, outputs " { $link f } "." } ; -HELP: parent-dir +HELP: parent-directory { $values { "path" "a pathname string" } { "parent" "a pathname string" } } { $description "Strips the last component off a pathname." } -{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-dir print" "/etc" } } ; +{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ; HELP: file-name { $values { "path" "a pathname string" } { "string" string } } diff --git a/core/io/files/files.factor b/core/io/files/files.factor old mode 100644 new mode 100755 index da1c078525..441dcfbee3 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2004, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.files -USING: io.backend io.files.private hashtables kernel math memory -namespaces sequences strings arrays definitions system +USING: io.backend io.files.private io hashtables kernel math +memory namespaces sequences strings arrays definitions system combinators splitting ; HOOK: io-backend ( path -- stream ) @@ -58,13 +58,16 @@ M: object root-directory? ( path -- ? ) "/" = ; TUPLE: no-parent-directory path ; -: parent-dir ( path -- parent ) +: no-parent-directory ( path -- * ) + \ no-parent-directory construct-boa throw ; + +: parent-directory ( path -- parent ) { { [ dup root-directory? ] [ ] } { [ dup "/\\" split ".." over member? "." rot member? or ] - [ \ no-parent-directory construct-boa throw ] } + [ no-parent-directory ] } { [ t ] [ dup last-path-separator - [ 1+ head ] [ 2drop "." ] if ] } + [ 1+ head ] [ 2drop "." ] if ] } } cond ; : file-name ( path -- string ) @@ -72,7 +75,7 @@ TUPLE: no-parent-directory path ; [ 1+ tail ] [ drop ] if ; : resource-path ( path -- newpath ) - \ resource-path get [ image parent-dir ] unless* + \ resource-path get [ image parent-directory ] unless* swap path+ ; : ?resource-path ( path -- newpath ) @@ -86,7 +89,7 @@ TUPLE: no-parent-directory path ; { [ dup empty? ] [ ] } { [ dup exists? ] [ ] } { [ t ] [ - dup parent-dir make-directories + dup parent-directory make-directories dup make-directory ] } } cond drop ; @@ -103,3 +106,18 @@ M: pathname <=> [ pathname-string ] compare ; { [ wince? ] [ "" resource-path ] } { [ unix? ] [ "HOME" os-env ] } } cond ; + +: copy-file ( from to -- ) + dup parent-directory make-directories + [ + stdio get swap + [ + stdio get swap stream-copy + ] with-stream + ] with-stream ; + +: copy-directory ( from to -- ) + dup make-directories + >r dup directory swap r> [ + >r >r first r> over path+ r> rot path+ copy-file + ] 2curry each ; diff --git a/extra/tools/deploy/config/config-docs.factor b/extra/tools/deploy/config/config-docs.factor old mode 100644 new mode 100755 index 31f4883cf8..5b1efce25e --- a/extra/tools/deploy/config/config-docs.factor +++ b/extra/tools/deploy/config/config-docs.factor @@ -30,6 +30,11 @@ ARTICLE: "prepare-deploy" "Preparing to deploy an application" ABOUT: "prepare-deploy" +HELP: deploy-name +{ $description "Deploy setting. The name of the executable." +$nl +"On Mac OS X, this becomes the name of the application bundle, with " { $snippet ".app" } " appended. On Windows, this becomes the name of the directory containing the executable." } ; + HELP: deploy-word-props? { $description "Deploy flag. If set, the deploy tool retains all word properties. Otherwise, it applies various heuristics to strip out un-needed word properties from words in the dictionary." $nl @@ -95,8 +100,8 @@ HELP: deploy-reflection "The defalut value is 1, no reflection. Programs which use the above features will need to be deployed with a higher level of reflection support." } ; HELP: default-config -{ $values { "assoc" assoc } } -{ $description "Outputs the default deployment configuration." } ; +{ $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } +{ $description "Outputs the default deployment configuration for a vocabulary." } ; HELP: deploy-config { $values { "vocab" "a vocabulary specifier" } { "assoc" assoc } } diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor old mode 100644 new mode 100755 index 694eb36e0b..e6d03c2233 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -1,9 +1,12 @@ ! 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 namespaces math ; +splitting parser prettyprint namespaces math vocabs +hashtables ; IN: tools.deploy.config +SYMBOL: deploy-name + SYMBOL: deploy-ui? SYMBOL: deploy-compiler? SYMBOL: deploy-math? @@ -46,8 +49,8 @@ SYMBOL: deploy-c-types? SYMBOL: deploy-vm SYMBOL: deploy-image -: default-config ( -- assoc ) - V{ +: default-config ( vocab -- assoc ) + vocab-name deploy-name associate H{ { deploy-ui? f } { deploy-io 2 } { deploy-reflection 1 } @@ -56,15 +59,15 @@ SYMBOL: deploy-image { deploy-word-props? f } { deploy-word-defs? f } { deploy-c-types? f } - ! default value for deploy.app + ! default value for deploy.macosx { "stop-after-last-window?" t } - } clone ; + } union ; : deploy-config-path ( vocab -- string ) vocab-dir "deploy.factor" path+ ; : deploy-config ( vocab -- assoc ) - default-config swap + dup default-config swap dup deploy-config-path vocab-file-contents parse-fresh dup empty? [ drop ] [ first union ] if ; diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor old mode 100644 new mode 100755 index c11b41e09c..adee30a8bc --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -49,7 +49,7 @@ IN: tools.deploy "\"-output-image=" swap "\"" 3append , - ! "-no-stack-traces" , + "-no-stack-traces" , "-no-user-init" , ] { } make ; @@ -59,6 +59,10 @@ PRIVATE> : deploy* ( vm image vocab config -- ) deploy-command-line stage2 ; -: deploy ( vocab -- ) - "" resource-path cd - vm over ".image" append rot dup deploy-config deploy* ; +SYMBOL: deploy-implementation + +HOOK: deploy deploy-implementation ( vocab -- ) + +USE-IF: macosx? tools.deploy.macosx + +USE-IF: winnt? tools.deploy.windows diff --git a/extra/tools/deploy/app/app.factor b/extra/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 similarity index 65% rename from extra/tools/deploy/app/app.factor rename to extra/tools/deploy/macosx/macosx.factor index 3672c9a586..0b71ac5209 --- a/extra/tools/deploy/app/app.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -3,10 +3,7 @@ USING: io io.files io.launcher kernel namespaces sequences system cocoa.plists cocoa.application tools.deploy tools.deploy.config assocs hashtables prettyprint ; -IN: tools.deploy.app - -: mkdir ( path -- ) - "mkdir -p \"" swap "\"" 3append run-process ; +IN: tools.deploy.macosx : touch ( path -- ) "touch \"" swap "\"" 3append run-process ; @@ -14,22 +11,19 @@ IN: tools.deploy.app : rm ( path -- ) "rm -rf \"" swap "\"" 3append run-process ; -: cp ( from to -- ) - "Copying " write over write " to " write dup print - dup parent-dir mkdir - [ "cp -R \"" % swap % "\" \"" % % "\"" % ] "" make - run-process ; +: bundle-dir ( -- dir ) + vm parent-directory parent-directory ; : copy-bundle-dir ( name dir -- ) - vm parent-dir parent-dir over path+ -rot - >r "Contents" path+ r> path+ cp ; + bundle-dir over path+ -rot + >r "Contents" path+ r> path+ copy-directory ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap [ cp ] keep ; + "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ; : copy-fonts ( name -- ) "fonts/" resource-path - swap "Contents/Resources/fonts/" path+ cp ; + swap "Contents/Resources/fonts/" path+ copy-directory ; : print-app-plist ( executable bundle-name -- ) [ @@ -57,16 +51,19 @@ IN: tools.deploy.app : deploy.app-image ( vocab bundle-name -- str ) [ % "/Contents/Resources/" % % ".image" % ] "" make ; -: deploy.app-config ( vocab -- assoc ) - [ ".app" append "bundle-name" associate ] keep - deploy-config union ; +: bundle-name ( -- string ) + deploy-name get ".app" append ; -: deploy.app ( vocab -- ) +TUPLE: macosx-deploy-implementation ; + +T{ macosx-deploy-implementation } deploy-implementation set-global + +M: macosx-deploy-implementation deploy ( vocab -- ) ".app deploy tool" assert.app "." resource-path cd - dup deploy.app-config [ - "bundle-name" get rm - [ "bundle-name" get create-app-dir ] keep - [ "bundle-name" get deploy.app-image ] keep + dup deploy-config [ + bundle-name rm + [ bundle-name create-app-dir ] keep + [ bundle-name deploy.app-image ] keep namespace ] bind deploy* ; diff --git a/extra/tools/deploy/app/summary.txt b/extra/tools/deploy/macosx/summary.txt similarity index 100% rename from extra/tools/deploy/app/summary.txt rename to extra/tools/deploy/macosx/summary.txt diff --git a/extra/tools/deploy/app/tags.txt b/extra/tools/deploy/macosx/tags.txt similarity index 100% rename from extra/tools/deploy/app/tags.txt rename to extra/tools/deploy/macosx/tags.txt diff --git a/extra/tools/deploy/windows/summary.txt b/extra/tools/deploy/windows/summary.txt new file mode 100644 index 0000000000..6b67694cc2 --- /dev/null +++ b/extra/tools/deploy/windows/summary.txt @@ -0,0 +1 @@ +Deploying minimal stand-alone Windows executables diff --git a/extra/tools/deploy/windows/tags.txt b/extra/tools/deploy/windows/tags.txt new file mode 100644 index 0000000000..ef1aab0d0e --- /dev/null +++ b/extra/tools/deploy/windows/tags.txt @@ -0,0 +1 @@ +tools diff --git a/extra/tools/deploy/windows/windows.factor b/extra/tools/deploy/windows/windows.factor new file mode 100755 index 0000000000..0d0241a5e0 --- /dev/null +++ b/extra/tools/deploy/windows/windows.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2007 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io io.files kernel namespaces sequences system +tools.deploy tools.deploy.config assocs hashtables prettyprint ; +IN: tools.deploy.windows + +: copy-vm ( executable bundle-name -- vm ) + swap path+ ".exe" append vm swap [ copy-file ] keep ; + +: copy-fonts ( bundle-name -- ) + "fonts/" resource-path + swap "fonts/" path+ copy-directory ; + +: copy-dlls ( bundle-name -- ) + { + "freetype6.dll" + "zlib1.dll" + "factor-nt.dll" + } [ + dup resource-path -rot path+ copy-file + ] curry* each ; + +: create-exe-dir ( vocab bundle-name -- vm ) + dup copy-dlls + dup copy-fonts + copy-vm ; + +: image-name ( vocab bundle-name -- str ) + swap path+ ".image" append ; + +TUPLE: windows-deploy-implementation ; + +T{ windows-deploy-implementation } deploy-implementation set-global + +M: windows-deploy-implementation deploy + "." resource-path cd + dup deploy-config [ + [ deploy-name get create-exe-dir ] keep + [ deploy-name get image-name ] keep + namespace + ] bind deploy* ; From d8d1da96d71e0b36c9cd79520d5dce595d110cda Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 00:46:03 -0500 Subject: [PATCH 28/55] Update libraries for parent-dir rename --- extra/contributors/contributors.factor | 2 +- .../http/server/templating/templating.factor | 2 +- extra/io/unix/files/files-tests.factor | 10 +++++----- extra/io/windows/windows-tests.factor | 14 +++++++------- extra/ui/tools/deploy/deploy.factor | 19 ++++++++----------- extra/ui/tools/operations/operations.factor | 7 +++++-- 6 files changed, 27 insertions(+), 27 deletions(-) mode change 100644 => 100755 extra/contributors/contributors.factor mode change 100644 => 100755 extra/http/server/templating/templating.factor mode change 100644 => 100755 extra/io/unix/files/files-tests.factor mode change 100644 => 100755 extra/ui/tools/deploy/deploy.factor mode change 100644 => 100755 extra/ui/tools/operations/operations.factor diff --git a/extra/contributors/contributors.factor b/extra/contributors/contributors.factor old mode 100644 new mode 100755 index aaff1d2038..65035480b2 --- a/extra/contributors/contributors.factor +++ b/extra/contributors/contributors.factor @@ -5,7 +5,7 @@ sequences combinators.lib assocs system sorting math.parser ; IN: contributors : changelog ( -- authors ) - image parent-dir cd + image parent-directory cd "git-log --pretty=format:%an" lines ; : patch-counts ( authors -- assoc ) diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor old mode 100644 new mode 100755 index 64ee4bd129..d76e11287c --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -88,7 +88,7 @@ DEFER: <% delimiter ] assert-depth drop ; : run-relative-template-file ( filename -- ) - file get source-file-path parent-dir + file get source-file-path parent-directory swap path+ run-template-file ; : template-convert ( infile outfile -- ) diff --git a/extra/io/unix/files/files-tests.factor b/extra/io/unix/files/files-tests.factor old mode 100644 new mode 100755 index 9e3fb44bc1..103c2789c6 --- a/extra/io/unix/files/files-tests.factor +++ b/extra/io/unix/files/files-tests.factor @@ -1,8 +1,8 @@ USING: tools.test io.files ; IN: temporary -[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-dir ] unit-test -[ "/etc/" ] [ "/etc/passwd" parent-dir ] unit-test -[ "/" ] [ "/etc/" parent-dir ] unit-test -[ "/" ] [ "/etc" parent-dir ] unit-test -[ "/" ] [ "/" parent-dir ] unit-test +[ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test +[ "/etc/" ] [ "/etc/passwd" parent-directory ] unit-test +[ "/" ] [ "/etc/" parent-directory ] unit-test +[ "/" ] [ "/etc" parent-directory ] unit-test +[ "/" ] [ "/" parent-directory ] unit-test diff --git a/extra/io/windows/windows-tests.factor b/extra/io/windows/windows-tests.factor index 3c3684ad3c..4c090590df 100755 --- a/extra/io/windows/windows-tests.factor +++ b/extra/io/windows/windows-tests.factor @@ -1,14 +1,14 @@ USING: io.files kernel tools.test ; IN: temporary -[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-dir ] unit-test -[ "c:\\" ] [ "c:\\foo\\" parent-dir ] unit-test -[ "c:\\" ] [ "c:\\foo" parent-dir ] unit-test +[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test ! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing -[ "c:\\" ] [ "c:\\" parent-dir ] unit-test -[ "Z:\\" ] [ "Z:\\" parent-dir ] unit-test -[ "c:" ] [ "c:" parent-dir ] unit-test -[ "Z:" ] [ "Z:" parent-dir ] unit-test +[ "c:\\" ] [ "c:\\" parent-directory ] unit-test +[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test +[ "c:" ] [ "c:" parent-directory ] unit-test +[ "Z:" ] [ "Z:" parent-directory ] unit-test [ t ] [ "c:\\" root-directory? ] unit-test [ t ] [ "Z:\\" root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor old mode 100644 new mode 100755 index 297d9e0614..ae2a4e1a8e --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -5,14 +5,14 @@ ui.gadgets.controls models sequences ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels tools.deploy.config namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands assocs ui.gadgets.tracks ui ui.tools.listener -tools.deploy.app vocabs ui.tools.workspace ui.operations ; +tools.deploy vocabs ui.tools.workspace system ; IN: ui.tools.deploy TUPLE: deploy-gadget vocab settings ; : bundle-name ( -- ) - "bundle-name" get - "Bundle name:" label-on-left gadget, ; + deploy-name get + "Executable name:" label-on-left gadget, ; : deploy-ui ( -- ) deploy-ui? get @@ -42,13 +42,12 @@ TUPLE: deploy-gadget vocab settings ; { 10 10 } over set-pack-gap 1 swap set-pack-fill ; -: ( -- control ) +: ( vocab -- control ) default-config [ ] assoc-map [ - f "bundle-name" set [ bundle-name deploy-ui - exit-when-windows-closed + macosx? [ exit-when-windows-closed ] when io-settings reflection-settings advanced-settings @@ -63,7 +62,7 @@ TUPLE: deploy-gadget vocab settings ; find-deploy-gadget deploy-gadget-vocab ; : find-deploy-config - find-deploy-vocab deploy.app-config ; + find-deploy-vocab deploy-config ; : find-deploy-settings find-deploy-gadget deploy-gadget-settings ; @@ -78,7 +77,7 @@ TUPLE: deploy-gadget vocab settings ; : com-deploy ( gadget -- ) dup com-save - find-deploy-vocab [ deploy.app ] curry call-listener ; + find-deploy-vocab [ deploy ] curry call-listener ; : com-help ( -- ) "ui-deploy" help-window ; @@ -99,7 +98,7 @@ deploy-gadget "toolbar" f { : ( vocab -- gadget ) f deploy-gadget construct-boa [ - + dup g-> set-deploy-gadget-settings gadget, buttons, ] { 0 1 } build-pack @@ -109,5 +108,3 @@ deploy-gadget "toolbar" f { : deploy-tool ( vocab -- ) vocab-name dup 10 "Deploying \"" rot "\"" 3append open-window ; - -[ vocab-spec? ] \ deploy-tool H{ } define-operation diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor old mode 100644 new mode 100755 index b19221ce0b..d2d7685f45 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -6,8 +6,9 @@ ui.tools.search ui.tools.traceback ui.tools.workspace generic help.topics inference inspector io.files io.styles kernel namespaces parser prettyprint quotations tools.annotations editors tools.profiler tools.test tools.time tools.walker -ui.commands ui.gadgets.editors ui.gestures ui.operations vocabs -vocabs.loader words sequences tools.browser classes ; +ui.commands ui.gadgets.editors ui.gestures ui.operations +ui.tools.deploy vocabs vocabs.loader words sequences +tools.browser classes ; IN: ui.tools.operations V{ } clone operations set-global @@ -155,6 +156,8 @@ M: word com-stack-effect word-def com-stack-effect ; { +listener+ t } } define-operation +[ vocab-spec? ] \ deploy-tool H{ } define-operation + ! Quotations [ quotation? ] \ com-stack-effect H{ { +keyboard+ T{ key-down f { C+ } "i" } } From fdf251103d64613e13883f18f9f3b9920f471b65 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 00:47:13 -0500 Subject: [PATCH 29/55] Update deploy.factor files for renaming of config flag --- extra/automata/ui/deploy.factor | 2 +- extra/boids/ui/deploy.factor | 2 +- extra/bunny/deploy.factor | 2 +- extra/catalyst-talk/deploy.factor | 2 +- extra/color-picker/deploy.factor | 2 +- extra/gesture-logger/deploy.factor | 2 +- extra/golden-section/deploy.factor | 2 +- extra/hello-ui/deploy.factor | 15 ++++++++------- extra/hello-world/deploy.factor | 2 +- extra/lsys/ui/deploy.factor | 2 +- extra/maze/deploy.factor | 2 +- extra/nehe/deploy.factor | 2 +- extra/tetris/deploy.factor | 2 +- 13 files changed, 20 insertions(+), 19 deletions(-) mode change 100644 => 100755 extra/automata/ui/deploy.factor mode change 100644 => 100755 extra/boids/ui/deploy.factor mode change 100644 => 100755 extra/bunny/deploy.factor mode change 100644 => 100755 extra/catalyst-talk/deploy.factor mode change 100644 => 100755 extra/color-picker/deploy.factor mode change 100644 => 100755 extra/gesture-logger/deploy.factor mode change 100644 => 100755 extra/golden-section/deploy.factor mode change 100644 => 100755 extra/hello-ui/deploy.factor mode change 100644 => 100755 extra/hello-world/deploy.factor mode change 100644 => 100755 extra/lsys/ui/deploy.factor mode change 100644 => 100755 extra/maze/deploy.factor mode change 100644 => 100755 extra/nehe/deploy.factor mode change 100644 => 100755 extra/tetris/deploy.factor diff --git a/extra/automata/ui/deploy.factor b/extra/automata/ui/deploy.factor old mode 100644 new mode 100755 index 1aa5a2883a..12861cf728 --- a/extra/automata/ui/deploy.factor +++ b/extra/automata/ui/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Cellular Automata.app" } + { deploy-name "Cellular Automata" } } diff --git a/extra/boids/ui/deploy.factor b/extra/boids/ui/deploy.factor old mode 100644 new mode 100755 index e272a277e4..168c5d9ace --- a/extra/boids/ui/deploy.factor +++ b/extra/boids/ui/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Boids.app" } + { deploy-name "Boids" } } diff --git a/extra/bunny/deploy.factor b/extra/bunny/deploy.factor old mode 100644 new mode 100755 index d2c84582a5..12aaffc19c --- a/extra/bunny/deploy.factor +++ b/extra/bunny/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Bunny.app" } + { deploy-name "Bunny" } } diff --git a/extra/catalyst-talk/deploy.factor b/extra/catalyst-talk/deploy.factor old mode 100644 new mode 100755 index 506270fa55..2f7f79da9d --- a/extra/catalyst-talk/deploy.factor +++ b/extra/catalyst-talk/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "catalyst-talk.app" } + { deploy-name "Catalyst Talk" } } diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor old mode 100644 new mode 100755 index d16b74d076..fcb4dbd69d --- a/extra/color-picker/deploy.factor +++ b/extra/color-picker/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "color-picker.app" } + { deploy-name "Color Picker" } } diff --git a/extra/gesture-logger/deploy.factor b/extra/gesture-logger/deploy.factor old mode 100644 new mode 100755 index 782b996895..0692feb30d --- a/extra/gesture-logger/deploy.factor +++ b/extra/gesture-logger/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Gesture Logger.app" } + { deploy-name "Gesture Logger" } } diff --git a/extra/golden-section/deploy.factor b/extra/golden-section/deploy.factor old mode 100644 new mode 100755 index a41d1b33c6..0aa3185d66 --- a/extra/golden-section/deploy.factor +++ b/extra/golden-section/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Golden Section.app" } + { deploy-name "Golden Section" } } diff --git a/extra/hello-ui/deploy.factor b/extra/hello-ui/deploy.factor old mode 100644 new mode 100755 index bb819f5ce2..a1ad007c62 --- a/extra/hello-ui/deploy.factor +++ b/extra/hello-ui/deploy.factor @@ -1,12 +1,13 @@ USING: tools.deploy.config ; -V{ - { deploy-ui? t } - { deploy-io 1 } - { deploy-reflection 2 } - { deploy-compiler? t } +H{ { deploy-math? t } + { deploy-reflection 2 } + { deploy-io 1 } { deploy-word-props? f } - { deploy-c-types? f } + { deploy-word-defs? f } { "stop-after-last-window?" t } - { "bundle-name" "Hello world.app" } + { deploy-ui? t } + { deploy-compiler? t } + { deploy-name "Hello world" } + { deploy-c-types? f } } diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor old mode 100644 new mode 100755 index 7af1913d93..95d7d625c1 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Hello world (console).app" } + { deploy-name "Hello world (console)" } } diff --git a/extra/lsys/ui/deploy.factor b/extra/lsys/ui/deploy.factor old mode 100644 new mode 100755 index de5076cac0..4db8cf93e9 --- a/extra/lsys/ui/deploy.factor +++ b/extra/lsys/ui/deploy.factor @@ -9,5 +9,5 @@ V{ { deploy-word-defs? t } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Lindenmayer System Explorer.app" } + { deploy-name "Lindenmayer System Explorer" } } diff --git a/extra/maze/deploy.factor b/extra/maze/deploy.factor old mode 100644 new mode 100755 index 123412f4a3..321a30d5b2 --- a/extra/maze/deploy.factor +++ b/extra/maze/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Maze.app" } + { deploy-name "Maze" } } diff --git a/extra/nehe/deploy.factor b/extra/nehe/deploy.factor old mode 100644 new mode 100755 index cbd31d67b1..6cf9543678 --- a/extra/nehe/deploy.factor +++ b/extra/nehe/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "NeHe OpenGL demos.app" } + { deploy-name "NeHe OpenGL demos" } } diff --git a/extra/tetris/deploy.factor b/extra/tetris/deploy.factor old mode 100644 new mode 100755 index c00b7041db..57a5eda494 --- a/extra/tetris/deploy.factor +++ b/extra/tetris/deploy.factor @@ -8,5 +8,5 @@ V{ { deploy-word-props? f } { deploy-c-types? f } { "stop-after-last-window?" t } - { "bundle-name" "Tetris.app" } + { deploy-name "Tetris" } } From e0d8a52a291091b3e5a9efa368bc2f700bc179e3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:08:19 -0500 Subject: [PATCH 30/55] chmod the executable --- extra/tools/deploy/macosx/macosx.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 0b71ac5209..d59665488a 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -11,6 +11,9 @@ IN: tools.deploy.macosx : rm ( path -- ) "rm -rf \"" swap "\"" 3append run-process ; +: chmod ( path perms -- ) + [ "chmod " % % " \"" % % "\"" % ] "" make run-process ; + : bundle-dir ( -- dir ) vm parent-directory parent-directory ; @@ -19,7 +22,9 @@ IN: tools.deploy.macosx >r "Contents" path+ r> path+ copy-directory ; : copy-vm ( executable bundle-name -- vm ) - "Contents/MacOS/" path+ swap path+ vm swap [ copy-file ] keep ; + "Contents/MacOS/" path+ swap path+ vm swap + [ copy-file ] keep + [ "755" chmod ] keep ; : copy-fonts ( name -- ) "fonts/" resource-path From 821cabeb4472b49ae50946b1aacc545d86dbbe98 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:08:28 -0500 Subject: [PATCH 31/55] Fix hello-world deploy config --- extra/hello-world/deploy.factor | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index 95d7d625c1..c8f69648a5 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,12 +1,13 @@ USING: tools.deploy.config ; -V{ - { deploy-ui? f } - { deploy-io 3 } +H{ { deploy-reflection 1 } - { deploy-compiler? t } - { deploy-math? f } - { deploy-word-props? f } - { deploy-c-types? f } - { "stop-after-last-window?" t } { deploy-name "Hello world (console)" } + { deploy-word-props? f } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-word-defs? f } + { deploy-io 2 } + { deploy-ui? f } + { deploy-math? f } } From b4f6d7aa1c9c0e0bbee54cf7a5adbeb3b08d96ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:12:21 -0500 Subject: [PATCH 32/55] Fix accidental tools.deploy -> compiler dependency --- extra/cfdg/models/flower6/deploy.factor | 12 ++++++++++++ extra/hello-world/deploy.factor | 8 ++++---- extra/springies/models/belt-tire/deploy.factor | 13 +++++++++++++ extra/tools/deploy/shaker/shaker.factor | 8 ++++---- 4 files changed, 33 insertions(+), 8 deletions(-) create mode 100644 extra/cfdg/models/flower6/deploy.factor create mode 100644 extra/springies/models/belt-tire/deploy.factor diff --git a/extra/cfdg/models/flower6/deploy.factor b/extra/cfdg/models/flower6/deploy.factor new file mode 100644 index 0000000000..d6dadc035d --- /dev/null +++ b/extra/cfdg/models/flower6/deploy.factor @@ -0,0 +1,12 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 1 } + { deploy-reflection 2 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "cfdg.models.flower6.app" } +} diff --git a/extra/hello-world/deploy.factor b/extra/hello-world/deploy.factor index c8f69648a5..06bad872be 100755 --- a/extra/hello-world/deploy.factor +++ b/extra/hello-world/deploy.factor @@ -1,13 +1,13 @@ USING: tools.deploy.config ; H{ - { deploy-reflection 1 } - { deploy-name "Hello world (console)" } + { deploy-math? f } + { deploy-word-defs? f } { deploy-word-props? f } + { deploy-name "Hello world (console)" } { "stop-after-last-window?" t } { deploy-c-types? f } { deploy-compiler? f } - { deploy-word-defs? f } { deploy-io 2 } { deploy-ui? f } - { deploy-math? f } + { deploy-reflection 1 } } diff --git a/extra/springies/models/belt-tire/deploy.factor b/extra/springies/models/belt-tire/deploy.factor new file mode 100644 index 0000000000..ed522d5ee9 --- /dev/null +++ b/extra/springies/models/belt-tire/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +V{ + { deploy-ui? t } + { deploy-io 2 } + { deploy-reflection 1 } + { deploy-compiler? t } + { deploy-math? t } + { deploy-word-props? f } + { deploy-word-defs? f } + { deploy-c-types? f } + { "stop-after-last-window?" t } + { "bundle-name" "Belt Tire.app" } +} diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 52e1486199..0322ed372f 100644 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -5,7 +5,7 @@ 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 compiler ; +quotations words.private tools.deploy.config ; IN: tools.deploy.shaker : show ( msg -- ) @@ -24,7 +24,7 @@ IN: tools.deploy.shaker "Stripping debugger" show "resource:extra/tools/deploy/shaker/strip-debugger.factor" run-file - recompile + do-parse-hook ] when ; : strip-libc ( -- ) @@ -32,7 +32,7 @@ IN: tools.deploy.shaker "Stripping manual memory management debug code" show "resource:extra/tools/deploy/shaker/strip-libc.factor" run-file - recompile + do-parse-hook ] when ; : strip-cocoa ( -- ) @@ -40,7 +40,7 @@ IN: tools.deploy.shaker "Stripping unused Cocoa methods" show "resource:extra/tools/deploy/shaker/strip-cocoa.factor" run-file - recompile + do-parse-hook ] when ; : strip-assoc ( retained-keys assoc -- newassoc ) From b85af601c04b288189b4ccb46c4c9b4523cc7e84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:23:48 -0500 Subject: [PATCH 33/55] Document deployment --- extra/tools/deploy/deploy-docs.factor | 20 ++++++++++++-------- extra/ui/tools/deploy/deploy-docs.factor | 14 ++++++++++++++ extra/ui/tools/tools-docs.factor | 4 +++- 3 files changed, 29 insertions(+), 9 deletions(-) create mode 100644 extra/ui/tools/deploy/deploy-docs.factor diff --git a/extra/tools/deploy/deploy-docs.factor b/extra/tools/deploy/deploy-docs.factor index 29e0da1f5c..f6e9cb2882 100644 --- a/extra/tools/deploy/deploy-docs.factor +++ b/extra/tools/deploy/deploy-docs.factor @@ -2,16 +2,20 @@ USING: help.markup help.syntax words alien.c-types assocs kernel ; IN: tools.deploy -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." +ARTICLE: "tools.deploy" "Application deployment" +"The stand-alone application deployment tool compiles a vocabulary down to a native executable which runs the vocabulary's " { $link POSTPONE: MAIN: } " hook. Deployed executables do not depend on Factor being installed, and do not expose any source code, and thus are suitable for delivering commercial end-user applications." $nl "For example, we can deploy the " { $vocab-link "hello-world" } " demo which comes with Factor:" -{ $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" } - -"Once the necessary deployment flags have been set, a deployment image can be generated:" -{ $subsection deploy } ; +{ $code "\"hello-ui\" deploy" } +"On Mac OS X, this yields a program named " { $snippet "Hello world.app" } ". On Windows, it yields a directory named " { $snippet "Hello world" } " containing a program named " { $snippet "hello-ui.exe" } ". In both cases, running the program displays a window with a message." +$nl +"The deployment tool works by bootstrapping a fresh image, loading the vocabulary into this image, then applying various heuristics to strip the image down to minimal size." +$nl +"You must explicitly specify major subsystems which are required, as well as the level of reflection support needed. This is done by modifying the deployment configuration prior to deployment." +{ $subsection "prepare-deploy" } +"Once the necessary deployment flags have been set, the application can be deployed:" +{ $subsection deploy } +{ $see-also "ui.tools.deploy" } ; ABOUT: "tools.deploy" diff --git a/extra/ui/tools/deploy/deploy-docs.factor b/extra/ui/tools/deploy/deploy-docs.factor new file mode 100644 index 0000000000..4898b651a1 --- /dev/null +++ b/extra/ui/tools/deploy/deploy-docs.factor @@ -0,0 +1,14 @@ +USING: help.markup help.syntax ui.tools.deploy ; + +HELP: deploy-tool +{ $values { "vocab" "a vocabulary specifier" } } +{ $description "Opens the graphical deployment tool for the specified vocabulary." } +{ $examples { $code "\"tetris\" deploy-tool" } } ; + +ARTICLE: "ui.tools.deploy" "Application deployment UI tool" +"The application deployment UI tool provides a graphical front-end to deployment configuration. Using the tool, you can set deployment options graphically." +$nl +"To start the tool, pass a vocabulary name to a word:" +{ $subsection deploy-tool } +"Alternatively, right-click on a vocabulary presentation in the UI and choose " { $strong "Deploy tool" } " from the resulting popup menu." +{ $see-also "tools.deploy" } ; diff --git a/extra/ui/tools/tools-docs.factor b/extra/ui/tools/tools-docs.factor index e80dfe3c33..df795fa987 100644 --- a/extra/ui/tools/tools-docs.factor +++ b/extra/ui/tools/tools-docs.factor @@ -130,12 +130,14 @@ $nl { $subsection "ui-presentations" } { $subsection "ui-completion" } { $heading "Tools" } -"All development tools are integrated into a single-window " { $emphasis "workspace" } "." +"A single-window " { $emphasis "workspace" } " contains the most frequently-used tools:" { $subsection "ui-listener" } { $subsection "ui-browser" } { $subsection "ui-inspector" } { $subsection "ui-walker" } { $subsection "ui-profiler" } +"Additional tools:" +{ $subsection "ui.tools.deploy" } "Platform-specific features:" { $subsection "ui-cocoa" } ; From 86f98eac407a4339dd0f15c49a99db48e5857994 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:37:07 -0500 Subject: [PATCH 34/55] Deploy generates a stage1 image now if necessary --- core/bootstrap/image/image.factor | 5 ++++- extra/tools/deploy/deploy.factor | 21 +++++++++++++-------- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f6f3e5c0da..4204503372 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -442,7 +442,7 @@ M: curry ' PRIVATE> -: make-image ( architecture -- ) +: make-image ( arch -- ) [ parse-hook off prepare-image @@ -452,6 +452,9 @@ PRIVATE> image get image-name write-image ] with-scope ; +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + : make-images ( -- ) { "x86.32" "x86.64" "linux-ppc" "macosx-ppc" "arm" diff --git a/extra/tools/deploy/deploy.factor b/extra/tools/deploy/deploy.factor index adee30a8bc..7c0dabc458 100755 --- a/extra/tools/deploy/deploy.factor +++ b/extra/tools/deploy/deploy.factor @@ -5,25 +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 tools.deploy.config ; +quotations io.launcher words.private tools.deploy.config +bootstrap.image ; IN: tools.deploy @@ -57,7 +62,7 @@ IN: tools.deploy PRIVATE> : deploy* ( vm image vocab config -- ) - deploy-command-line stage2 ; + stage1 deploy-command-line stage2 ; SYMBOL: deploy-implementation From af83b87b7d8acd4467f59c231acc54d299e5ea58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:37:23 -0500 Subject: [PATCH 35/55] Minor improvement to fep's object dumpmer --- vm/debug.c | 1 + 1 file changed, 1 insertion(+) diff --git a/vm/debug.c b/vm/debug.c index 733f4eb49c..55ffcadca6 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -200,6 +200,7 @@ void dump_objects(F_FIXNUM type) { if(type == -1 || type_of(obj) == type) { + printf("%lx ",obj); print_nested_obj(obj,3); printf("\n"); } From 0051acbb2e47adefefca7e0f9b9a8fef9fb67737 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 01:40:48 -0500 Subject: [PATCH 36/55] Linux/ARM fixes with help from doublec --- Makefile | 2 ++ vm/Config.linux.arm | 1 + vm/Config.unix | 2 +- vm/os-linux-arm.c | 23 +++++++++++++++++++++++ vm/os-linux-arm.h | 8 ++++---- 5 files changed, 31 insertions(+), 5 deletions(-) create mode 100644 vm/os-linux-arm.c diff --git a/Makefile b/Makefile index a67f24f19d..77a6fb6409 100644 --- a/Makefile +++ b/Makefile @@ -1,4 +1,6 @@ CC = gcc +AR = ar +LD = ld EXECUTABLE = factor VERSION = 0.91 diff --git a/vm/Config.linux.arm b/vm/Config.linux.arm index 4b8c8415db..26acde562d 100644 --- a/vm/Config.linux.arm +++ b/vm/Config.linux.arm @@ -1,2 +1,3 @@ include vm/Config.linux include vm/Config.arm +PLAF_DLL_OBJS += vm/os-linux-arm.o diff --git a/vm/Config.unix b/vm/Config.unix index 73934d7f41..390a719c77 100644 --- a/vm/Config.unix +++ b/vm/Config.unix @@ -21,5 +21,5 @@ endif # LINKER = gcc -shared -o # LINK_WITH_ENGINE = '-Wl,-rpath,$$ORIGIN' -lfactor -LINKER = ar rcs +LINKER = $(AR) rcs LINK_WITH_ENGINE = -Wl,--whole-archive -lfactor -Wl,-no-whole-archive diff --git a/vm/os-linux-arm.c b/vm/os-linux-arm.c new file mode 100644 index 0000000000..217fb58fa7 --- /dev/null +++ b/vm/os-linux-arm.c @@ -0,0 +1,23 @@ +#include "master.h" + +void flush_icache(CELL start, CELL len) +{ + int result; + + /* XXX: why doesn't this work on Nokia n800? It should behave + identically to the below assembly. */ + /* result = syscall(__ARM_NR_cacheflush,start,start + len,0); */ + + __asm__ __volatile__ ( + "mov r0, %1\n" + "sub r1, %2, #1\n" + "mov r2, #0\n" + "swi " __sys1(__ARM_NR_cacheflush) "\n" + "mov %0, r0\n" + : "=r" (result) + : "r" (start), "r" (start + len) + : "r0","r1","r2"); + + if(result < 0) + critical_error("flush_icache() failed",result); +} diff --git a/vm/os-linux-arm.h b/vm/os-linux-arm.h index 2e3d6062ed..6e078b014d 100644 --- a/vm/os-linux-arm.h +++ b/vm/os-linux-arm.h @@ -8,7 +8,7 @@ INLINE void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.arm_sp; } -INLINE void flush_icache(CELL start, CELL len) -{ - syscall(__ARM_NR_cacheflush,start,start + len,0); -} +#define UAP_PROGRAM_COUNTER(ucontext) \ + (((ucontext_t *)(ucontext))->uc_mcontext.arm_pc) + +void flush_icache(CELL start, CELL len); From f301d365350e508ad43a603e4df8d16cccc24e7f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:41:23 -0600 Subject: [PATCH 37/55] Move dlists to core/ Delete heaps --- {extra => core}/dlists/authors.txt | 1 + core/dlists/dlists-docs.factor | 74 ++++++++++++++++++ core/dlists/dlists-tests.factor | 61 +++++++++++++++ core/dlists/dlists.factor | 121 +++++++++++++++++++++++++++++ {extra => core}/dlists/summary.txt | 0 {extra => core}/dlists/tags.txt | 0 extra/dlists/dlists-tests.factor | 54 ------------- extra/dlists/dlists.factor | 100 ------------------------ extra/heaps/heaps-tests.factor | 32 -------- extra/heaps/heaps.factor | 112 -------------------------- 10 files changed, 257 insertions(+), 298 deletions(-) rename {extra => core}/dlists/authors.txt (59%) create mode 100644 core/dlists/dlists-docs.factor create mode 100644 core/dlists/dlists-tests.factor create mode 100644 core/dlists/dlists.factor rename {extra => core}/dlists/summary.txt (100%) rename {extra => core}/dlists/tags.txt (100%) delete mode 100644 extra/dlists/dlists-tests.factor delete mode 100644 extra/dlists/dlists.factor delete mode 100644 extra/heaps/heaps-tests.factor delete mode 100644 extra/heaps/heaps.factor diff --git a/extra/dlists/authors.txt b/core/dlists/authors.txt similarity index 59% rename from extra/dlists/authors.txt rename to core/dlists/authors.txt index 09839c9c91..ebeb56efd2 100644 --- a/extra/dlists/authors.txt +++ b/core/dlists/authors.txt @@ -1 +1,2 @@ Mackenzie Straight +Doug Coleman diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor new file mode 100644 index 0000000000..c5e41e9446 --- /dev/null +++ b/core/dlists/dlists-docs.factor @@ -0,0 +1,74 @@ +USING: help.markup help.syntax kernel ; +IN: dlists + +ARTICLE: "dlists" "Doubly-linked lists" +"A doubly-linked list is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object. Objects can be pushed and popped from the front and back of the list. The linked list keeps track of its length, so finding the length is O(1)." +; + +HELP: dlist-empty? +{ $values { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Returns true if a " { $link dlist } " is empty." } +{ $notes "This operation is O(1)." } ; + +HELP: push-front +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-back pop-front pop-front* pop-back pop-back* } ; + +HELP: push-back +{ $values { "obj" "an object" } { "dlist" dlist } } +{ $description "Push the object onto the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front pop-front pop-front* pop-back pop-back* } ; + +HELP: pop-front +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the front of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front* pop-back pop-back* } ; + +HELP: pop-front* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the front of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-back pop-back* } ; + +HELP: pop-back +{ $values { "dlist" dlist } { "obj" "an object" } } +{ $description "Pop the object off the back of the " { $link dlist } " and return the object." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back* } ; + +HELP: pop-back* +{ $values { "dlist" dlist } } +{ $description "Pop the object off the back of the " { $link dlist } "." } +{ $notes "This operation is O(1)." } +{ $see-also push-front push-back pop-front pop-front* pop-back } ; + +HELP: dlist-find +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $description "Applies the quotation to each element of the " { $link dlist } " in turn, until it outputs a true value or the end of the " { $link dlist } " is reached. Outputs either the object it found or " { $link f } ", and a boolean which is true if an object is found." } +{ $notes "Returns a boolean to allow dlists to store " { $link f } "." + $nl + "This operation is O(n)." +} ; + +HELP: dlist-contains? +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "?" "a boolean" } } +{ $description "Just like " { $link dlist-find } " except it doesn't return the object." } +{ $notes "This operation is O(n)." } ; + +HELP: delete-node* +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } { "?" "a boolean" } } +{ $description "Calls " { $link dlist-find } " on the " { $link dlist } " and deletes the node returned, if any. Returns the value of the deleted node and a boolean to allow the deleted value to distinguished from " { $link f } ", for nothing deleted." } +{ $notes "This operation is O(n)." } ; + +HELP: delete-node +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } { "obj/f" "an object or " { $link f } } } +{ $description "Like " { $link delete-node* } " but cannot distinguish from deleting a node whose value is " { $link f } " or not deleting an element." } +{ $notes "This operation is O(n)." } ; + +HELP: dlist-each +{ $values { "quot" "a quotation" } { "dlist" { $link dlist } } } +{ $description "Iterate a " { $link dlist } ", calling quot on each element." } ; diff --git a/core/dlists/dlists-tests.factor b/core/dlists/dlists-tests.factor new file mode 100644 index 0000000000..f4482d680d --- /dev/null +++ b/core/dlists/dlists-tests.factor @@ -0,0 +1,61 @@ +USING: dlists dlists.private kernel tools.test ; +IN: temporary + +[ t ] [ dlist-empty? ] unit-test + +[ T{ dlist f T{ dlist-node f 1 f f } T{ dlist-node f 1 f f } 1 } ] +[ 1 over push-front ] unit-test + +! Make sure empty lists are empty +[ t ] [ dlist-empty? ] unit-test +[ f ] [ 1 over push-front dlist-empty? ] unit-test +[ f ] [ 1 over push-back dlist-empty? ] unit-test + +[ 1 ] [ 1 over push-front pop-front ] unit-test +[ 1 ] [ 1 over push-front pop-back ] unit-test +[ 1 ] [ 1 over push-back pop-front ] unit-test +[ 1 ] [ 1 over push-back pop-back ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-front dup pop-back* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-front* ] unit-test +[ T{ dlist f f f 0 } ] [ 1 over push-back dup pop-back* ] unit-test + +! Test the prev,next links for two nodes +[ f ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-prev +] unit-test + +[ 2 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-obj +] unit-test + +[ 1 ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-prev dlist-node-obj +] unit-test + +[ f ] [ + 1 over push-back 2 over push-back + dlist-front dlist-node-next dlist-node-next +] unit-test + +[ f f ] [ [ 1 = ] swap dlist-find ] unit-test +[ 1 t ] [ 1 over push-back [ 1 = ] swap dlist-find ] unit-test +[ f f ] [ 1 over push-back [ 2 = ] swap dlist-find ] unit-test +[ f ] [ 1 over push-back [ 2 = ] swap dlist-contains? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] swap dlist-contains? ] unit-test + +[ 1 ] [ 1 over push-back [ 1 = ] swap delete-node ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ t ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-empty? ] unit-test +[ 0 ] [ 1 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 1 ] [ 1 over push-back 2 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 1 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 2 = ] over delete-node drop dlist-length ] unit-test +[ 2 ] [ 1 over push-back 2 over push-back 3 over push-back [ 3 = ] over delete-node drop dlist-length ] unit-test + +[ 0 ] [ dlist-length ] unit-test +[ 1 ] [ 1 over push-front dlist-length ] unit-test +[ 0 ] [ 1 over push-front dup pop-front* dlist-length ] unit-test diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor new file mode 100644 index 0000000000..da05df9d80 --- /dev/null +++ b/core/dlists/dlists.factor @@ -0,0 +1,121 @@ +! Copyright (C) 2007 Mackenzie Straight, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators kernel math ; +IN: dlists + +TUPLE: dlist front back length ; +: ( -- obj ) + dlist construct-empty + 0 over set-dlist-length ; + + dlist-node + +: dlist-empty? ( dlist -- ? ) dlist-front not ; + +: inc-length ( dlist -- ) + [ dlist-length 1+ ] keep set-dlist-length ; inline + +: dec-length ( dlist -- ) + [ dlist-length 1- ] keep set-dlist-length ; inline + +: set-prev-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-prev ] [ drop ] if* ; + +: set-next-when ( dlist-node dlist-node/f -- ) + [ set-dlist-node-next ] [ drop ] if* ; + +: set-next-prev ( dlist-node -- ) + dup dlist-node-next set-prev-when ; + +: normalize-front ( dlist -- ) + dup dlist-back [ drop ] [ f swap set-dlist-front ] if ; + +: normalize-back ( dlist -- ) + dup dlist-front [ drop ] [ f swap set-dlist-back ] if ; + +: set-back-to-front ( dlist -- ) + dup dlist-back + [ drop ] [ dup dlist-front swap set-dlist-back ] if ; + +: set-front-to-back ( dlist -- ) + dup dlist-front + [ drop ] [ dup dlist-back swap set-dlist-front ] if ; +PRIVATE> + +: push-front ( obj dlist -- ) + [ dlist-front f swap dup set-next-prev ] keep + [ set-dlist-front ] keep + [ set-back-to-front ] keep + inc-length ; + +: push-back ( obj dlist -- ) + [ dlist-back f ] keep + [ dlist-back set-next-when ] 2keep + [ set-dlist-back ] keep + [ set-front-to-back ] keep + inc-length ; + +: pop-front ( dlist -- obj ) + dup dlist-front [ + dlist-node-next + f over set-prev-when + swap set-dlist-front + ] 2keep dlist-node-obj + swap [ normalize-back ] keep dec-length ; + +: pop-front* ( dlist -- ) pop-front drop ; + +: pop-back ( dlist -- obj ) + [ + dlist-back dup dlist-node-prev f over set-next-when + ] keep + [ set-dlist-back ] keep + [ normalize-front ] keep + dec-length + dlist-node-obj ; + +: pop-back* ( dlist -- ) pop-back drop ; + +: (dlist-find-node) ( quot dlist-node -- node/f ? ) + dup dlist-node-obj pick dupd call [ + drop nip t + ] [ + drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* + ] if ; + +: dlist-find-node ( quot dlist -- node/f ? ) + dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; + +: dlist-find ( quot dlist -- obj/f ? ) + dlist-find-node dup [ >r dlist-node-obj r> ] when ; + +: dlist-contains? ( quot dlist -- ? ) + dlist-find nip ; + +: (delete-node) ( dlist dlist-node -- ) + { + { [ 2dup >r dlist-front r> = ] [ drop pop-front* ] } + { [ 2dup >r dlist-back r> = ] [ drop pop-back* ] } + { [ t ] [ dup dlist-node-prev swap dlist-node-next set-prev-when + dec-length ] } + } cond ; + +: delete-node ( quot dlist -- obj/f ) + tuck dlist-find-node [ + [ (delete-node) ] keep [ dlist-node-obj ] [ f ] if* + ] [ + 2drop f + ] if ; + +: (dlist-each-node) ( quot dlist -- ) + over + [ 2dup call >r dlist-node-next r> (dlist-each-node) ] + [ 2drop ] if ; + +: dlist-each-node ( quot dlist -- ) + >r dlist-front r> (dlist-each-node) ; inline + +: dlist-each ( dlist quot -- ) + [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/extra/dlists/summary.txt b/core/dlists/summary.txt similarity index 100% rename from extra/dlists/summary.txt rename to core/dlists/summary.txt diff --git a/extra/dlists/tags.txt b/core/dlists/tags.txt similarity index 100% rename from extra/dlists/tags.txt rename to core/dlists/tags.txt diff --git a/extra/dlists/dlists-tests.factor b/extra/dlists/dlists-tests.factor deleted file mode 100644 index cdcee84dc0..0000000000 --- a/extra/dlists/dlists-tests.factor +++ /dev/null @@ -1,54 +0,0 @@ -IN: temporary -USING: dlists kernel strings tools.test math ; - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-remove -] unit-test - -[ 5 20 ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ "junk" ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] over dlist-remove drop - [ integer? ] over dlist-remove drop - [ ] dlist-each -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] swap dlist-contains? -] unit-test - -[ t ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ integer? ] swap dlist-contains? -] unit-test - -[ f ] [ - - 5 over dlist-push-end - "junk" over dlist-push-end - 20 over dlist-push-end - [ string? ] over dlist-remove drop - [ string? ] swap dlist-contains? -] unit-test diff --git a/extra/dlists/dlists.factor b/extra/dlists/dlists.factor deleted file mode 100644 index 9ff7ce5f6f..0000000000 --- a/extra/dlists/dlists.factor +++ /dev/null @@ -1,100 +0,0 @@ -! Copyright (C) 2005 Mackenzie Straight. -! See http://factorcode.org/license.txt for BSD license. -IN: dlists -USING: kernel math ; - -! Double-linked lists. - -TUPLE: dlist first last ; - -: dlist construct-empty ; - -TUPLE: dlist-node data prev next ; - -C: dlist-node - -: dlist-push-end ( data dlist -- ) - [ dlist-last f ] keep - [ dlist-last [ dupd set-dlist-node-next ] when* ] keep - 2dup set-dlist-last - dup dlist-first [ 2drop ] [ set-dlist-first ] if ; - -: dlist-empty? ( dlist -- ? ) - dlist-first f = ; - -: (unlink-prev) ( dlist dnode -- ) - dup dlist-node-prev [ - dupd swap dlist-node-next swap set-dlist-node-next - ] when* - 2dup swap dlist-first eq? [ - dlist-node-next swap set-dlist-first - ] [ 2drop ] if ; - -: (unlink-next) ( dlist dnode -- ) - dup dlist-node-next [ - dupd swap dlist-node-prev swap set-dlist-node-prev - ] when* - 2dup swap dlist-last eq? [ - dlist-node-prev swap set-dlist-last - ] [ 2drop ] if ; - -: (dlist-unlink) ( dlist dnode -- ) - [ (unlink-prev) ] 2keep (unlink-next) ; - -: (dlist-pop-front) ( dlist -- data ) - [ dlist-first dlist-node-data ] keep dup dlist-first (dlist-unlink) ; - -: dlist-pop-front ( dlist -- data ) - dup dlist-empty? [ drop f ] [ (dlist-pop-front) ] if ; - -: (dlist-remove) ( dlist quot dnode -- obj/f ) - [ - [ dlist-node-data swap call ] 2keep rot [ - swapd [ (dlist-unlink) ] keep dlist-node-data nip - ] [ - dlist-node-next (dlist-remove) - ] if - ] [ - 2drop f - ] if* ; inline - -: dlist-remove ( quot dlist -- obj/f ) - #! Return first item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. The - #! item is removed from the dlist. The quotation - #! must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dup dlist-first swapd (dlist-remove) ; inline - -: (dlist-contains?) ( pred dnode -- bool ) - [ - [ dlist-node-data swap call ] 2keep rot [ - 2drop t - ] [ - dlist-node-next (dlist-contains?) - ] if - ] [ - drop f - ] if* ; inline - -: dlist-contains? ( quot dlist -- obj/f ) - #! Return true if any item in the dlist that when passed to the - #! predicate quotation, true is left on the stack. - #! The 'pred' quotation must have stack effect ( obj -- bool ). - #! TODO: needs a better name. - dlist-first (dlist-contains?) ; inline - -: (dlist-each) ( quot dnode -- ) - [ - [ dlist-node-data swap call ] 2keep - dlist-node-next (dlist-each) - ] [ - drop - ] if* ; inline - -: dlist-each ( dlist quot -- ) - swap dlist-first (dlist-each) ; inline - -: dlist-length ( dlist -- length ) - 0 swap [ drop 1+ ] dlist-each ; - diff --git a/extra/heaps/heaps-tests.factor b/extra/heaps/heaps-tests.factor deleted file mode 100644 index a8087916e7..0000000000 --- a/extra/heaps/heaps-tests.factor +++ /dev/null @@ -1,32 +0,0 @@ -! Copyright 2007 Ryan Murphy -! See http://factorcode.org/license.txt for BSD license. - -USING: kernel math tools.test heaps heaps.private ; -IN: temporary - -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails - -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test -[ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test - -! Binary Min Heap -{ 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test - -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test - -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times -] unit-test - -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test - -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test - -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test diff --git a/extra/heaps/heaps.factor b/extra/heaps/heaps.factor deleted file mode 100644 index 2ff9096483..0000000000 --- a/extra/heaps/heaps.factor +++ /dev/null @@ -1,112 +0,0 @@ -! Copyright (C) 2007 Ryan Murphy, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; -IN: heaps - - ( -- obj ) - V{ } clone heap construct-boa ; -PRIVATE> - -TUPLE: min-heap ; - -: ( -- obj ) - min-heap construct-delegate ; - -TUPLE: max-heap ; - -: ( -- obj ) - max-heap construct-delegate ; - -r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; - -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) - -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; - -: left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; - -: right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; - -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) - ] [ - 2drop - ] if ; - -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; - -: child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; - -: swap-down ( m heap -- ) - [ child ] 2keep heap-data exchange ; - -DEFER: down-heap - -: (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ - -rot [ swap-down ] keep down-heap - ] [ - 3drop - ] if ; - -: down-heap ( m heap -- ) - 2dup left-bounds-check? [ 2drop ] [ (down-heap) ] if ; - -PRIVATE> - -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; - -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; - -: peek-heap ( heap -- obj ) - heap-data first ; - -: pop-heap* ( heap -- ) - dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap - ] [ - heap-data pop* - ] if ; - -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; - -: heap-empty? ( heap -- ? ) - heap-data empty? ; From 1a86c5fd8585e451aa18c84469621cc506af286f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:42:37 -0600 Subject: [PATCH 38/55] Move heaps to core/ Document heaps Renamed a lot of heaps words -- pop-heap -> heap-pop --- core/heaps/heaps-docs.factor | 41 ++++++++++++++ core/heaps/heaps-tests.factor | 20 +++---- core/heaps/heaps.factor | 102 ++++++++++++++++------------------ 3 files changed, 98 insertions(+), 65 deletions(-) create mode 100644 core/heaps/heaps-docs.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor new file mode 100644 index 0000000000..a8f3d64b1e --- /dev/null +++ b/core/heaps/heaps-docs.factor @@ -0,0 +1,41 @@ +USING: heaps.private help.markup help.syntax kernel ; +IN: heaps + +ARTICLE: "heaps" "Heaps" +"A heap is a data structure that obeys the heap property. A min-heap will always have its smallest member available, as a max-heap will its largest. Objects stored on the heap must be comparable using the " { $link <=> } " operator, which may mean defining a new method on an object by using " { $link POSTPONE: M: } "." +; + + +HELP: +{ $values { "min-heap" min-heap } } +{ $description "Create a new " { $link min-heap } "." } +; + +HELP: +{ $values { "max-heap" max-heap } } +{ $description "Create a new " { $link max-heap } "." } +; + +HELP: heap-push +{ $values { "obj" "an object" } { "heap" "a heap" } } +{ $description "Push an object onto a heap." } ; + +HELP: heap-push-all +{ $values { "seq" "a sequence" } { "heap" "a heap" } } +{ $description "Push a sequence onto a heap." } ; + +HELP: heap-peek +{ $values { "heap" "a heap" } { "obj" "an object" } } +{ $description "Returns the first element in the heap and leaves it in the heap." } ; + +HELP: heap-pop* +{ $values { "heap" "a heap" } } +{ $description "Removes the first element from the heap." } ; + +HELP: heap-pop +{ $values { "heap" "a heap" } { "obj" "an object" } } +{ $description "Returns the first element in the heap and removes it from the heap." } ; + +HELP: heap-empty? +{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $description "Tests if a " { $link heap } " has no nodes." } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index a8087916e7..befbbc90fc 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -4,13 +4,13 @@ USING: kernel math tools.test heaps heaps.private ; IN: temporary -[ pop-heap ] unit-test-fails -[ pop-heap ] unit-test-fails +[ heap-pop ] unit-test-fails +[ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over push-heap heap-empty? ] unit-test +[ f ] [ 1 over heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test @@ -18,15 +18,15 @@ IN: temporary { f } [ 5 3 T{ max-heap } heap-compare ] unit-test [ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over push-heap* ] unit-test +[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test [ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over push-heap* - 3 [ dup pop-heap* ] times + { 3 5 4 6 5 7 6 8 } over heap-push-all + 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap pop-heap ] unit-test +[ 2 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test -[ 1 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ 1 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test -[ 400 ] [ 300 over push-heap 200 over push-heap 400 over push-heap 3 over push-heap 2 over push-heap 1 over push-heap pop-heap ] unit-test +[ 400 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 2ff9096483..74ca9e4b34 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,78 +6,74 @@ IN: heaps ( -- obj ) - V{ } clone heap construct-boa ; +: ( class -- obj ) + >r V{ } clone heap construct-boa r> + construct-delegate ; inline PRIVATE> TUPLE: min-heap ; -: ( -- obj ) - min-heap construct-delegate ; +: ( -- min-heap ) min-heap ; TUPLE: max-heap ; -: ( -- obj ) - max-heap construct-delegate ; +: ( -- max-heap ) max-heap ; r left r> nth ; -: right-value ( n heap -- obj ) >r right r> nth ; -: up-value ( n vec -- obj ) >r up r> nth ; -: swap-up ( n vec -- ) >r dup up r> exchange ; -: last-index ( vec -- n ) length 1- ; +: left ( n -- m ) 2 * 1+ ; inline +: right ( n -- m ) 2 * 2 + ; inline +: up ( n -- m ) 1- 2 /i ; inline +: left-value ( n heap -- obj ) >r left r> nth ; inline +: right-value ( n heap -- obj ) >r right r> nth ; inline +: up-value ( n vec -- obj ) >r up r> nth ; inline +: swap-up ( n vec -- ) >r dup up r> exchange ; inline +: last-index ( vec -- n ) length 1- ; inline GENERIC: heap-compare ( obj1 obj2 heap -- ? ) - M: min-heap heap-compare drop <=> 0 > ; M: max-heap heap-compare drop <=> 0 < ; +: heap-bounds-check? ( m heap -- ? ) + heap-data length >= ; inline + : left-bounds-check? ( m heap -- ? ) - >r left r> heap-data length >= ; + >r left r> heap-bounds-check? ; inline : right-bounds-check? ( m heap -- ? ) - >r right r> heap-data length >= ; + >r right r> heap-bounds-check? ; inline -: (up-heap) ( vec heap -- ) - [ - >r [ last-index ] keep [ up-value ] keep peek r> heap-compare - ] 2keep rot [ - >r dup last-index - [ over swap-up ] keep - up 1+ head-slice - r> (up-heap) +: up-heap-continue? ( vec heap -- ? ) + >r [ last-index ] keep [ up-value ] keep peek r> + heap-compare ; inline + +: up-heap ( vec heap -- ) + 2dup up-heap-continue? [ + >r dup last-index [ over swap-up ] keep + up 1+ head-slice r> up-heap ] [ 2drop ] if ; -: up-heap ( heap -- ) - [ heap-data ] keep (up-heap) ; +: (child) ( m heap -- n ) + dupd + [ heap-data left-value ] 2keep + [ heap-data right-value ] keep heap-compare + [ right ] [ left ] if ; : child ( m heap -- n ) - 2dup right-bounds-check? [ - drop left - ] [ - dupd - [ heap-data left-value ] 2keep - [ heap-data right-value ] keep heap-compare [ - right - ] [ - left - ] if - ] if ; + 2dup right-bounds-check? [ drop left ] [ (child) ] if ; : swap-down ( m heap -- ) [ child ] 2keep heap-data exchange ; DEFER: down-heap +: down-heap-continue? ( heap m heap -- m heap ? ) + [ heap-data nth ] 2keep child pick + dupd [ heap-data nth swapd ] keep heap-compare ; + : (down-heap) ( m heap -- ) - 2dup [ heap-data nth ] 2keep child pick - dupd [ heap-data nth swapd ] keep - heap-compare [ + 2dup down-heap-continue? [ -rot [ swap-down ] keep down-heap ] [ 3drop @@ -88,25 +84,21 @@ DEFER: down-heap PRIVATE> -: push-heap ( obj heap -- ) - tuck heap-data push up-heap ; +: heap-push ( obj heap -- ) + tuck heap-data push [ heap-data ] keep up-heap ; -: push-heap* ( seq heap -- ) - swap [ swap push-heap ] curry* each ; +: heap-push-all ( seq heap -- ) [ heap-push ] curry each ; -: peek-heap ( heap -- obj ) - heap-data first ; +: heap-peek ( heap -- obj ) heap-data first ; -: pop-heap* ( heap -- ) +: heap-pop* ( heap -- ) dup heap-data length 1 > [ - [ heap-data pop 0 ] keep - [ heap-data set-nth ] keep - >r 0 r> down-heap + [ heap-data pop ] keep + [ heap-data set-first ] keep + 0 swap down-heap ] [ heap-data pop* ] if ; -: pop-heap ( heap -- fist ) [ heap-data first ] keep pop-heap* ; - -: heap-empty? ( heap -- ? ) - heap-data empty? ; +: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ; +: heap-empty? ( heap -- ? ) heap-data empty? ; From b8561fdc1d8325fcb5a7f86945af1a73a50c71e8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:43:04 -0600 Subject: [PATCH 39/55] Change heap words in core/threads --- core/threads/threads.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 2cb7a3c3d0..074259dce6 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -17,15 +17,15 @@ M: sleeping <=> ( obj1 obj2 -- n ) : sleep-time ( -- ms ) sleep-queue get-global - dup heap-empty? [ drop 1000 ] [ peek-heap sleeping-ms millis [-] ] if ; + dup heap-empty? [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; : schedule-sleep ( ms continuation -- ) - sleeping construct-boa sleep-queue get-global push-heap ; + sleeping construct-boa sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global pop-heap sleeping-continuation ; + sleep-queue get-global heap-pop sleeping-continuation ; PRIVATE> From 6c8808dd8ddc789ebf0105c33129475072db44e3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:43:29 -0600 Subject: [PATCH 40/55] Check in core/dlists --- core/dlists/dlists.factor | 47 +++++++++++++++++++++------------------ 1 file changed, 25 insertions(+), 22 deletions(-) diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index da05df9d80..ac19e0cec1 100644 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -8,12 +8,12 @@ TUPLE: dlist front back length ; dlist construct-empty 0 over set-dlist-length ; +: dlist-empty? ( dlist -- ? ) dlist-front not ; + dlist-node -: dlist-empty? ( dlist -- ? ) dlist-front not ; - : inc-length ( dlist -- ) [ dlist-length 1+ ] keep set-dlist-length ; inline @@ -42,6 +42,24 @@ C: dlist-node : set-front-to-back ( dlist -- ) dup dlist-front [ drop ] [ dup dlist-back swap set-dlist-front ] if ; + +: (dlist-find-node) ( quot dlist-node -- node/f ? ) + dup dlist-node-obj pick dupd call [ + drop nip t + ] [ + drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* + ] if ; + +: dlist-find-node ( quot dlist -- node/f ? ) + dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; + +: (dlist-each-node) ( quot dlist -- ) + over + [ 2dup call >r dlist-node-next r> (dlist-each-node) ] + [ 2drop ] if ; + +: dlist-each-node ( quot dlist -- ) + >r dlist-front r> (dlist-each-node) ; inline PRIVATE> : push-front ( obj dlist -- ) @@ -78,16 +96,6 @@ PRIVATE> : pop-back* ( dlist -- ) pop-back drop ; -: (dlist-find-node) ( quot dlist-node -- node/f ? ) - dup dlist-node-obj pick dupd call [ - drop nip t - ] [ - drop dlist-node-next [ (dlist-find-node) ] [ drop f f ] if* - ] if ; - -: dlist-find-node ( quot dlist -- node/f ? ) - dlist-front [ (dlist-find-node) ] [ drop f f ] if* ; - : dlist-find ( quot dlist -- obj/f ? ) dlist-find-node dup [ >r dlist-node-obj r> ] when ; @@ -102,20 +110,15 @@ PRIVATE> dec-length ] } } cond ; -: delete-node ( quot dlist -- obj/f ) +: delete-node* ( quot dlist -- obj/f ? ) tuck dlist-find-node [ - [ (delete-node) ] keep [ dlist-node-obj ] [ f ] if* + [ (delete-node) ] keep [ dlist-node-obj t ] [ f f ] if* ] [ - 2drop f + 2drop f f ] if ; -: (dlist-each-node) ( quot dlist -- ) - over - [ 2dup call >r dlist-node-next r> (dlist-each-node) ] - [ 2drop ] if ; - -: dlist-each-node ( quot dlist -- ) - >r dlist-front r> (dlist-each-node) ; inline +: delete-node ( quot dlist -- obj/f ) + delete-node* drop ; : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline From 3e40ab714e5ff552284f421d87984ebdde4b43d4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:50:19 -0600 Subject: [PATCH 41/55] Move delete-random to sequences.lib Add some unit tests --- extra/sequences/lib/lib-tests.factor | 6 ++++++ extra/sequences/lib/lib.factor | 4 +++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 470cd096e1..c170a0d20a 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -33,3 +33,9 @@ math.functions tools.test ; [ { 1 -1 5 2 4 } [ < ] monotonic-split [ >array ] map ] unit-test [ { { 1 1 1 1 } { 2 2 } { 3 } { 4 } { 5 } { 6 6 6 } } ] [ { 1 1 1 1 2 2 3 4 5 6 6 6 } [ = ] monotonic-split [ >array ] map ] unit-test +[ f ] [ { } singleton? ] unit-test +[ t ] [ { "asdf" } singleton? ] unit-test +[ f ] [ { "asdf" "bsdf" } singleton? ] unit-test + +[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test +[ V{ } [ delete-random drop ] keep length ] unit-test-fails diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index d6cf1fe1dc..74d59101ca 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel sequences math namespaces -sequences.private shuffle ; +random sequences.private shuffle ; IN: sequences.lib @@ -61,3 +61,5 @@ IN: sequences.lib : singleton? ( seq -- ? ) length 1 = ; +: delete-random ( seq -- value ) + [ length random ] keep [ nth ] 2keep delete-nth ; From 6de2fc53998790a28d34cf439768a39aa168e30d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 01:51:38 -0600 Subject: [PATCH 42/55] Moved delete-random to sequences.lib Add a space to a lot of lines =-O --- extra/channels/channels-tests.factor | 52 ++++++++++++++-------------- extra/channels/channels.factor | 5 +-- 2 files changed, 27 insertions(+), 30 deletions(-) diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 5c339d3406..1a08fd3971 100644 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -10,39 +10,39 @@ IN: temporary ] unit-test { V{ 10 } } [ - V{ } clone - [ from swap push ] in-thread - 10 swap to + V{ } clone + [ from swap push ] in-thread + 10 swap to ] unit-test { 20 } [ - - [ 20 swap to ] in-thread - from + + [ 20 swap to ] in-thread + from ] unit-test { V{ 1 2 3 4 } } [ - V{ } clone - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - [ from swap push ] in-thread - 4 over to - 2 over to - 1 over to - 3 swap to - [ <=> ] sort + V{ } clone + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + [ from swap push ] in-thread + 4 over to + 2 over to + 1 over to + 3 swap to + natural-sort ] unit-test { V{ 1 2 4 9 } } [ - V{ } clone - [ 4 swap to ] in-thread - [ 2 swap to ] in-thread - [ 1 swap to ] in-thread - [ 9 swap to ] in-thread - 2dup from swap push - 2dup from swap push - 2dup from swap push - dupd from swap push - [ <=> ] sort + V{ } clone + [ 4 swap to ] in-thread + [ 2 swap to ] in-thread + [ 1 swap to ] in-thread + [ 9 swap to ] in-thread + 2dup from swap push + 2dup from swap push + 2dup from swap push + dupd from swap push + natural-sort ] unit-test diff --git a/extra/channels/channels.factor b/extra/channels/channels.factor index 54f0d7dd4e..07b5d2f5d5 100644 --- a/extra/channels/channels.factor +++ b/extra/channels/channels.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Channels - based on ideas from newsqueak -USING: kernel sequences threads continuations random math ; +USING: kernel sequences sequences.lib threads continuations random math ; IN: channels TUPLE: channel receivers senders ; @@ -15,9 +15,6 @@ GENERIC: from ( channel -- value ) Date: Mon, 5 Nov 2007 02:03:59 -0600 Subject: [PATCH 43/55] Remove a unit test --- extra/channels/channels-tests.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/channels/channels-tests.factor b/extra/channels/channels-tests.factor index 1a08fd3971..1f2436cf5d 100644 --- a/extra/channels/channels-tests.factor +++ b/extra/channels/channels-tests.factor @@ -5,10 +5,6 @@ USING: kernel tools.test math channels channels.private sequences threads sorting ; IN: temporary -{ 3 t } [ - V{ 1 2 3 4 } clone [ delete-random ] keep length swap integer? -] unit-test - { V{ 10 } } [ V{ } clone [ from swap push ] in-thread From 40752e447df274581dbcd547a3466826b95730f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:04:33 -0600 Subject: [PATCH 44/55] Fix random number mechanism in remote channels --- extra/channels/remote/remote.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/channels/remote/remote.factor b/extra/channels/remote/remote.factor index 5d62d17308..4f483b8775 100644 --- a/extra/channels/remote/remote.factor +++ b/extra/channels/remote/remote.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! Remote Channels -USING: kernel init namespaces assocs arrays +USING: kernel init namespaces assocs arrays random sequences channels match concurrency concurrency.distributed ; IN: channels.remote @@ -13,7 +13,7 @@ IN: channels.remote PRIVATE> : publish ( channel -- id ) - random-64 dup >r remote-channels set-at r> ; + random-256 dup >r remote-channels set-at r> ; : get-channel ( id -- channel ) remote-channels at ; From 1e60000395092bf2e72bac769ed2da64cdae5dd3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:05:01 -0600 Subject: [PATCH 45/55] Fix concurrency --- extra/concurrency/concurrency.factor | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b59f758ad8..bbb7a7045a 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -26,7 +26,7 @@ TUPLE: thread timeout continuation continued? ; mailbox-data dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data dlist-push-end ] keep + [ mailbox-data push-back ] keep [ mailbox-threads ] keep V{ } clone swap set-mailbox-threads [ thread-continuation schedule-thread ] each yield ; @@ -51,7 +51,7 @@ TUPLE: thread timeout continuation continued? ; PRIVATE> : mailbox-get* ( mailbox timeout -- obj ) (mailbox-block-if-empty) - mailbox-data dlist-pop-front ; + mailbox-data pop-front ; : mailbox-get ( mailbox -- obj ) f mailbox-get* ; @@ -59,7 +59,7 @@ PRIVATE> : mailbox-get-all* ( mailbox timeout -- array ) (mailbox-block-if-empty) [ dup mailbox-empty? ] - [ dup mailbox-data dlist-pop-front ] + [ dup mailbox-data pop-front ] { } unfold ; : mailbox-get-all ( mailbox -- array ) @@ -74,7 +74,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data dlist-remove ; inline + mailbox-data delete-node ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; @@ -85,21 +85,19 @@ C: process GENERIC: send ( message process -- ) -: random-pid ( -- id ) 8 big-random ; - ; + [ ] random-256 make-mailbox ; : make-linked-process ( process -- process ) #! Return a process set to run on the local node. That process is #! linked to the process on the stack. It will receive a message if #! that process terminates. - 1quotation random-pid make-mailbox ; + 1quotation random-256 make-mailbox ; PRIVATE> : self ( -- process ) @@ -206,7 +204,7 @@ MATCH-VARS: ?from ?tag ; r self random-pid r> 3array ; + >r self random-256 r> 3array ; PRIVATE> : send-synchronous ( message process -- reply ) From 5719eeda88f875e3c01b4d214908fc755a68edaa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:25:16 -0600 Subject: [PATCH 46/55] Document a couple of words in random Add a word to get a random 256-bit integer --- extra/random/random-docs.factor | 8 ++++++++ extra/random/random.factor | 2 ++ 2 files changed, 10 insertions(+) diff --git a/extra/random/random-docs.factor b/extra/random/random-docs.factor index 811b86496c..1d8334ab31 100644 --- a/extra/random/random-docs.factor +++ b/extra/random/random-docs.factor @@ -21,3 +21,11 @@ HELP: random { $values { "seq" "a sequence" } { "elt" "a random element" } } { $description "Outputs a random element of the sequence. If the sequence is empty, always outputs " { $link f } "." } { $notes "Since integers are sequences, passing an integer " { $snippet "n" } " yields a random integer in the interval " { $snippet "[0,n)" } "." } ; + +HELP: big-random +{ $values { "n" "an integer" } { "r" "a random integer" } } +{ $description "Outputs an integer with n bytes worth of bits." } ; + +HELP: random-256 +{ $values { "r" "a random integer" } } +{ $description "Outputs an random integer 256 bits in length." } ; diff --git a/extra/random/random.factor b/extra/random/random.factor index 45ce99bcea..ff4487dd27 100755 --- a/extra/random/random.factor +++ b/extra/random/random.factor @@ -93,6 +93,8 @@ PRIVATE> : big-random ( n -- r ) [ drop (random) ] map >c-uint-array byte-array>bignum ; +: random-256 ( -- r ) 8 big-random ; inline + : random ( seq -- elt ) dup empty? [ drop f From 1df90f392d5601b3deb6ed72c8aa57665a97ae76 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:25:53 -0600 Subject: [PATCH 47/55] Move delete-random to sequences.lib --- extra/sequences/lib/lib.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 74d59101ca..33cfe80fcc 100644 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -1,6 +1,5 @@ USING: combinators.lib kernel sequences math namespaces random sequences.private shuffle ; - IN: sequences.lib ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From f26d8efa06cc5fd2702177f7da51797e96b57599 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 02:26:16 -0600 Subject: [PATCH 48/55] Add dlists and heaps to the handbook --- extra/help/handbook/handbook.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 9460903ffc..8f20b68cc1 100644 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -127,8 +127,9 @@ ARTICLE: "collections" "Collections" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } -{ $subsection "queues" } -{ $subsection "buffers" } ; +{ $subsection "buffers" } +{ $subsection "dlists" } +{ $subsection "heaps" } ; USE: io.sockets From 599f1c60873a78244173048a8ac406eaa634e2e9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:01:11 -0500 Subject: [PATCH 49/55] Finish cleaning up erg's changes, remove queues --- core/dlists/dlists-docs.factor | 32 +++++++++++- core/dlists/dlists.factor | 6 +++ core/heaps/heaps-docs.factor | 26 +++++++++- core/queues/authors.txt | 1 - core/queues/queues-docs.factor | 77 ---------------------------- core/queues/queues-tests.factor | 12 ----- core/queues/queues.factor | 57 -------------------- core/queues/summary.txt | 1 - core/queues/tags.txt | 1 - core/threads/threads-docs.factor | 2 +- core/threads/threads.factor | 18 +++---- extra/help/handbook/handbook.factor | 6 +-- extra/help/markup/markup-docs.factor | 4 +- extra/ui/gadgets/gadgets.factor | 6 +-- extra/ui/gestures/gestures.factor | 2 +- extra/ui/ui.factor | 4 +- 16 files changed, 81 insertions(+), 174 deletions(-) delete mode 100644 core/queues/authors.txt delete mode 100644 core/queues/queues-docs.factor delete mode 100644 core/queues/queues-tests.factor delete mode 100644 core/queues/queues.factor delete mode 100644 core/queues/summary.txt delete mode 100644 core/queues/tags.txt diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index c5e41e9446..a20d038621 100644 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -2,8 +2,36 @@ USING: help.markup help.syntax kernel ; IN: dlists ARTICLE: "dlists" "Doubly-linked lists" -"A doubly-linked list is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object. Objects can be pushed and popped from the front and back of the list. The linked list keeps track of its length, so finding the length is O(1)." -; +"A doubly-linked list, or dlist, is a list of nodes. Each node has a link to the previous and next nodes, and a slot to store an object." +$nl +"While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." +$nl +"Dlists form a class:" +{ $subsection dlist } +{ $subsection dlist? } +"Constructing a dlist:" +{ $subsection } +"Double-ended queue protocol:" +{ $subsection dlist-empty? } +{ $subsection push-front } +{ $subsection pop-front } +{ $subsection pop-front* } +{ $subsection push-back } +{ $subsection pop-back } +{ $subsection pop-back* } +"Finding out the length:" +{ $subsection dlist-length } +"Iterating over elements:" +{ $subsection dlist-each } +{ $subsection dlist-find } +{ $subsection dlist-contains? } +"Deleting a node matching a predicate:" +{ $subsection delete-node* } +{ $subsection delete-node } +"Consuming all nodes:" +{ $subsection dlist-slurp } ; + +ABOUT: "dlists" HELP: dlist-empty? { $values { "dlist" { $link dlist } } { "?" "a boolean" } } diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index ac19e0cec1..890185d4c4 100644 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -4,6 +4,7 @@ USING: combinators kernel math ; IN: dlists TUPLE: dlist front back length ; + : ( -- obj ) dlist construct-empty 0 over set-dlist-length ; @@ -122,3 +123,8 @@ PRIVATE> : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline + +: dlist-slurp ( dlist quot -- ) + over dlist-empty? + [ 2drop ] [ [ >r pop-back r> call ] 2keep dlist-slurp ] if ; + inline diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index a8f3d64b1e..3ed2813123 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -2,9 +2,31 @@ USING: heaps.private help.markup help.syntax kernel ; IN: heaps ARTICLE: "heaps" "Heaps" -"A heap is a data structure that obeys the heap property. A min-heap will always have its smallest member available, as a max-heap will its largest. Objects stored on the heap must be comparable using the " { $link <=> } " operator, which may mean defining a new method on an object by using " { $link POSTPONE: M: } "." -; +"A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time." +$nl +"Heap elements are compared using the " { $link <=> } " generic word." +$nl +"There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Max-heaps sort their elements so that the maximum element is first:" +{ $subsection min-heap } +{ $subsection min-heap? } +{ $subsection } +"Both obey a protocol." +$nl +"Queries:" +{ $subsection heap-empty? } +{ $subsection heap-peek } +"Insertion:" +{ $subsection heap-push } +{ $subsection heap-push-all } +"Removal:" +{ $subsection heap-pop* } +{ $subsection heap-pop } ; +ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } diff --git a/core/queues/authors.txt b/core/queues/authors.txt deleted file mode 100644 index 1901f27a24..0000000000 --- a/core/queues/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/core/queues/queues-docs.factor b/core/queues/queues-docs.factor deleted file mode 100644 index 845b95ea1f..0000000000 --- a/core/queues/queues-docs.factor +++ /dev/null @@ -1,77 +0,0 @@ -USING: help.markup help.syntax kernel ; -IN: queues - -ARTICLE: "queues" "Queues" -"Last-in-first-out queues are defined in the " { $vocab-link "queues" } " vocabulary." -$nl -"Queues are a class." -{ $subsection queue } -{ $subsection queue? } -{ $subsection } -"Testing queues:" -{ $subsection queue-empty? } -"Adding elements:" -{ $subsection deque } -"Removing elements:" -{ $subsection enque } -{ $subsection clear-queue } -{ $subsection queue-each } -"An example:" -{ $code - " \"q\" set" - "5 \"q\" get enque" - "3 \"q\" get enque" - "7 \"q\" get enque" - "\"q\" get deque ." - " 5" - "\"q\" get deque ." - " 3" - "\"q\" get deque ." - " 7" -} ; - -ABOUT: "queues" - -HELP: queue -{ $class-description "A simple first-in-first-out queue. See " { $link "queues" } "." } ; - -HELP: entry -{ $class-description "The class of entries in a " { $link queue } ". Each entry holds an object and a reference to the next entry." } ; - -HELP: -{ $values { "obj" object } { "entry" entry } } -{ $description "Creates a new queue entry." } -{ $notes "This word is a factor of " { $link enque } "." } ; - -HELP: -{ $values { "queue" queue } } -{ $description "Makes a new queue with no elements." } ; - -HELP: queue-empty? -{ $values { "queue" queue } { "?" "a boolean" } } -{ $description "Tests if a queue contains no elements." } ; - -HELP: deque -{ $values { "queue" queue } { "elt" object } } -{ $description "Removes an element from the front of the queue." } -{ $errors "Throws an " { $link empty-queue-error } " if the queue has no entries." } -{ $side-effects "queue" } ; - -HELP: enque -{ $values { "elt" object } { "queue" queue } } -{ $description "Adds an element to the back of the queue." } -{ $side-effects "queue" } ; - -HELP: empty-queue-error -{ $description "Throws an " { $link empty-queue-error } "." } -{ $error-description "Thrown by " { $link deque } " if the queue has no entries." } ; - -HELP: clear-queue -{ $values { "queue" queue } } -{ $description "Removes all entries from the queue." } -{ $side-effects "queue" } ; - -HELP: queue-each -{ $values { "queue" queue } { "quot" "a quotation with stack effect " { $snippet "( obj -- )" } } } -{ $description "Applies the quotation to each entry in the queue, starting from the least recently added entry, clearing the queue in the process." } -{ $side-effects "queue" } ; diff --git a/core/queues/queues-tests.factor b/core/queues/queues-tests.factor deleted file mode 100644 index d8df256fc0..0000000000 --- a/core/queues/queues-tests.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: kernel math namespaces queues sequences tools.test ; -IN: temporary - - "queue" set - -[ t ] [ "queue" get queue-empty? ] unit-test - -[ ] [ [ 1 2 3 4 5 ] [ "queue" get enque ] each ] unit-test - -[ { 1 2 3 4 5 } ] [ 5 [ drop "queue" get deque ] map ] unit-test - -[ "queue" get deque ] unit-test-fails diff --git a/core/queues/queues.factor b/core/queues/queues.factor deleted file mode 100644 index 0cd05ea8c0..0000000000 --- a/core/queues/queues.factor +++ /dev/null @@ -1,57 +0,0 @@ -! Copyright (C) 2005, 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -IN: queues -USING: kernel inspector ; - -TUPLE: entry obj next ; - -: ( obj -- entry ) f entry construct-boa ; - -TUPLE: queue head tail ; - -: ( -- queue ) queue construct-empty ; - -: queue-empty? ( queue -- ? ) queue-head not ; - -: (enque) ( entry queue -- ) - [ set-queue-head ] 2keep set-queue-tail ; - -: clear-queue ( queue -- ) - f swap (enque) ; - -: enque ( elt queue -- ) - >r r> dup queue-empty? [ - (enque) - ] [ - [ queue-tail set-entry-next ] 2keep set-queue-tail - ] if ; - -: clear-entry ( entry -- ) - f over set-entry-obj f swap set-entry-next ; - -: (deque) ( queue -- ) - dup queue-head over queue-tail eq? [ - clear-queue - ] [ - dup queue-head dup entry-next rot set-queue-head - clear-entry - ] if ; - -TUPLE: empty-queue-error ; -: empty-queue-error ( -- * ) - \ empty-queue-error construct-empty throw ; - -: deque ( queue -- elt ) - dup queue-empty? [ - empty-queue-error - ] [ - dup queue-head entry-obj >r (deque) r> - ] if ; - -M: empty-queue-error summary - drop "Empty queue" ; - -: queue-each ( queue quot -- ) - over queue-empty? - [ 2drop ] [ [ >r deque r> call ] 2keep queue-each ] if ; - inline diff --git a/core/queues/summary.txt b/core/queues/summary.txt deleted file mode 100644 index 7bc2a8c7f2..0000000000 --- a/core/queues/summary.txt +++ /dev/null @@ -1 +0,0 @@ -FIFO queues diff --git a/core/queues/tags.txt b/core/queues/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/core/queues/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index b4a7c340ad..ccd25c8e3f 100644 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations queues ; +threads.private continuations ; IN: threads ARTICLE: "threads" "Threads" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 074259dce6..95536db00c 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -2,9 +2,9 @@ ! Copyright (C) 2005 Mackenzie Straight. ! See http://factorcode.org/license.txt for BSD license. IN: threads -USING: arrays init hashtables heaps io.backend kernel kernel.private -math namespaces queues sequences vectors io system sorting -continuations debugger ; +USING: arrays init hashtables heaps io.backend kernel +kernel.private math namespaces sequences vectors io system +continuations debugger dlists ; ( obj1 obj2 -- n ) [ sleeping-ms ] 2apply - ; : sleep-time ( -- ms ) - sleep-queue get-global - dup heap-empty? [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; + sleep-queue get-global dup heap-empty? + [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; @@ -29,7 +29,7 @@ M: sleeping <=> ( obj1 obj2 -- n ) PRIVATE> -: schedule-thread ( continuation -- ) run-queue enque ; +: schedule-thread ( continuation -- ) run-queue push-front ; : schedule-thread-with ( obj continuation -- ) 2array schedule-thread ; @@ -38,7 +38,7 @@ PRIVATE> walker-hook [ f swap continue-with ] [ - run-queue deque dup array? + run-queue pop-back dup array? [ first2 continue-with ] [ continue ] if ] if* ; @@ -64,10 +64,10 @@ PRIVATE> [ 0 ? io-multiplex ] if ; : idle-thread ( -- ) - run-queue queue-empty? (idle-thread) yield idle-thread ; + run-queue dlist-empty? (idle-thread) yield idle-thread ; : init-threads ( -- ) - \ run-queue set-global + \ run-queue set-global sleep-queue set-global [ idle-thread ] in-thread ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 8f20b68cc1..44f932abb2 100644 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -122,14 +122,14 @@ ARTICLE: "collections" "Collections" { $heading "Associative mappings" } { $subsection "assocs" } { $subsection "namespaces" } -{ $subsection "graphs" } "Implementations:" { $subsection "hashtables" } { $subsection "alists" } { $heading "Other collections" } -{ $subsection "buffers" } { $subsection "dlists" } -{ $subsection "heaps" } ; +{ $subsection "heaps" } +{ $subsection "graphs" } +{ $subsection "buffers" } ; USE: io.sockets diff --git a/extra/help/markup/markup-docs.factor b/extra/help/markup/markup-docs.factor index 0af65954e6..f6ef5f8408 100644 --- a/extra/help/markup/markup-docs.factor +++ b/extra/help/markup/markup-docs.factor @@ -100,7 +100,7 @@ HELP: $link { $values { "element" "a markup element of the form " { $snippet "{ topic }" } } } { $description "Prints a link to a help article or word." } { $examples - { $markup-example { $link "queues" } } + { $markup-example { $link "dlists" } } { $markup-example { $link + } } } ; @@ -123,7 +123,7 @@ HELP: $see-also { $values { "topics" "a sequence of article names or words" } } { $description "Prints a heading followed by a series of links." } { $examples - { $markup-example { $see-also "graphs" "queues" } } + { $markup-example { $see-also "graphs" "dlists" } } } ; { $see-also $related related-words } related-words diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index dddab1aa8a..e4d4434b4e 100644 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays hashtables kernel models math namespaces sequences -timers quotations math.vectors queues combinators sorting -vectors ; +timers quotations math.vectors combinators sorting vectors +dlists ; IN: ui.gadgets TUPLE: rect loc dim ; @@ -159,7 +159,7 @@ M: array gadget-text* #! When unit testing gadgets without the UI running, the #! invalid queue is not initialized and we simply ignore #! invalidation requests. - invalid [ enque ] [ drop ] if* ; + invalid [ push-front ] [ drop ] if* ; DEFER: relayout diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index c7b4455bc7..0e337c538a 100644 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel math models namespaces queues +USING: arrays assocs kernel math models namespaces sequences words strings system hashtables math.parser math.vectors tuples classes ui.gadgets timers ; IN: ui.gestures diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 18886ef348..6ed3aa6d36 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs io kernel math models namespaces -prettyprint queues sequences threads sequences words timers +prettyprint dlists sequences threads sequences words timers debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render continuations init ; IN: ui @@ -81,7 +81,7 @@ SYMBOL: windows [ invalid [ dup layout find-world [ , ] when* - ] queue-each + ] dlist-slurp ] { } make ; SYMBOL: ui-hook From 7751d49ffedfb1cae5837b3c1abb2ba993f338ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:11:48 -0500 Subject: [PATCH 50/55] Doc fixes --- core/dlists/dlists-docs.factor | 2 ++ core/threads/threads-docs.factor | 6 +++--- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/dlists/dlists-docs.factor b/core/dlists/dlists-docs.factor index a20d038621..5a808a9a5d 100644 --- a/core/dlists/dlists-docs.factor +++ b/core/dlists/dlists-docs.factor @@ -6,6 +6,8 @@ ARTICLE: "dlists" "Doubly-linked lists" $nl "While nodes can be modified directly, the fundamental protocol support by doubly-linked lists is that of a double-ended queue with a few additional operations. Elements can be added or removed at both ends of the dlist in constant time." $nl +"When using a dlist as a simple queue, the convention is to queue elements with " { $link push-front } " and dequeue them with " { $link pop-back } "." +$nl "Dlists form a class:" { $subsection dlist } { $subsection dlist? } diff --git a/core/threads/threads-docs.factor b/core/threads/threads-docs.factor index ccd25c8e3f..181979bfed 100644 --- a/core/threads/threads-docs.factor +++ b/core/threads/threads-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax kernel kernel.private io -threads.private continuations ; +threads.private continuations dlists ; IN: threads ARTICLE: "threads" "Threads" @@ -20,8 +20,8 @@ $nl ABOUT: "threads" HELP: run-queue -{ $values { "queue" queue } } -{ $description "Outputs the runnable thread queue." } ; +{ $values { "queue" dlist } } +{ $description "Outputs the runnable thread queue. By convention, continuations are queued with " { $link push-front } " and dequeued with " { $link pop-back } "." } ; HELP: schedule-thread { $values { "continuation" "a continuation reified by " { $link callcc0 } } } From bf32fb7a53342e89e9a6d205af1dd5d933c580fc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 11:13:31 -0500 Subject: [PATCH 51/55] Load fix --- extra/ui/ui.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/ui.factor b/extra/ui/ui.factor index 6ed3aa6d36..fc5777ab6a 100644 --- a/extra/ui/ui.factor +++ b/extra/ui/ui.factor @@ -87,7 +87,7 @@ SYMBOL: windows SYMBOL: ui-hook : init-ui ( -- ) - \ invalid set-global + \ invalid set-global V{ } clone windows set-global ; : start-ui ( -- ) From 29afe48d326623b929e68b5f61a9420529d5758f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 11:10:26 -0600 Subject: [PATCH 52/55] Update heaps to store key/value pairs instead of objects comparable by <=> Update docs Add heap-length --- core/heaps/heaps-docs.factor | 38 +++++++++++++++++++++++------------ core/heaps/heaps-tests.factor | 25 +++++++++++++---------- core/heaps/heaps.factor | 16 ++++++++------- 3 files changed, 48 insertions(+), 31 deletions(-) diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index 3ed2813123..edaa32a6a6 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -4,7 +4,7 @@ IN: heaps ARTICLE: "heaps" "Heaps" "A heap is an implementation of a " { $emphasis "priority queue" } ", which is a structure that maintains a sorted set of elements. The key property is that insertion of an arbitrary element and removal of the first element (determined by order) is performed in O(log n) time." $nl -"Heap elements are compared using the " { $link <=> } " generic word." +"Heap elements are key/value pairs and are compared using the " { $link <=> } " generic word on the first element of the pair." $nl "There are two classes of heaps. Min-heaps sort their elements so that the minimum element is first:" { $subsection min-heap } @@ -18,6 +18,7 @@ $nl $nl "Queries:" { $subsection heap-empty? } +{ $subsection heap-length } { $subsection heap-peek } "Insertion:" { $subsection heap-push } @@ -31,33 +32,44 @@ ABOUT: "heaps" HELP: { $values { "min-heap" min-heap } } { $description "Create a new " { $link min-heap } "." } -; +{ $see-also } ; HELP: { $values { "max-heap" max-heap } } { $description "Create a new " { $link max-heap } "." } -; +{ $see-also } ; HELP: heap-push -{ $values { "obj" "an object" } { "heap" "a heap" } } -{ $description "Push an object onto a heap." } ; +{ $values { "pair" "a key/value pair" } { "heap" "a heap" } } +{ $description "Push an pair onto a heap. The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." } +{ $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence" } { "heap" "a heap" } } -{ $description "Push a sequence onto a heap." } ; +{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } } +{ $description "Push a sequence of pairs onto a heap." } +{ $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "obj" "an object" } } -{ $description "Returns the first element in the heap and leaves it in the heap." } ; +{ $values { "heap" "a heap" } { "pair" "a key/value pair" } } +{ $description "Returns the first element in the heap and leaves it in the heap." } +{ $see-also heap-pop heap-pop* } ; HELP: heap-pop* { $values { "heap" "a heap" } } -{ $description "Removes the first element from the heap." } ; +{ $description "Removes the first element from the heap." } +{ $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "obj" "an object" } } -{ $description "Returns the first element in the heap and removes it from the heap." } ; +{ $values { "heap" "a heap" } { "pair" "an key/value pair" } } +{ $description "Returns the first element in the heap and removes it from the heap." } +{ $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? { $values { "heap" "a heap" } { "?" "a boolean" } } -{ $description "Tests if a " { $link heap } " has no nodes." } ; +{ $description "Tests if a " { $link heap } " has no nodes." } +{ $see-also heap-length heap-peek } ; + +HELP: heap-length +{ $values { "heap" "a heap" } { "n" "an integer" } } +{ $description "Returns the number of key/value pairs in the heap." } +{ $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index befbbc90fc..d326480cb8 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -8,25 +8,28 @@ IN: temporary [ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ 1 over heap-push heap-empty? ] unit-test +[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ 5 3 T{ min-heap } heap-compare ] unit-test -{ f } [ 5 3 T{ max-heap } heap-compare ] unit-test +{ t } [ { 5 t } { 3 t } T{ min-heap } heap-compare ] unit-test +{ f } [ { 5 t } { 3 t } T{ max-heap } heap-compare ] unit-test -[ T{ min-heap T{ heap f V{ -6 -4 2 1 5 3 2 4 3 7 6 8 3 4 4 6 5 5 } } } ] -[ { 3 5 4 6 7 8 2 4 3 5 6 1 3 2 4 5 -6 -4 } over heap-push-all ] unit-test +[ T{ min-heap T{ heap f V{ { -6 t } { -4 t } { 2 t } { 1 t } { 5 t } { 3 t } { 2 t } { 4 t } { 3 t } { 7 t } { 6 t } { 8 t } { 3 t } { 4 t } { 4 t } { 6 t } { 5 t } { 5 t } } } } ] +[ { { 3 t } { 5 t } { 4 t } { 6 t } { 7 t } { 8 t } { 2 t } { 4 t } { 3 t } { 5 t } { 6 t } { 1 t } { 3 t } { 2 t } { 4 t } { 5 t } { -6 t } { -4 t } } over heap-push-all ] unit-test -[ T{ min-heap T{ heap f V{ 5 6 6 7 8 } } } ] [ - { 3 5 4 6 5 7 6 8 } over heap-push-all +[ T{ min-heap T{ heap f V{ { 5 t } { 6 t } { 6 t } { 7 t } { 8 t } } } } ] [ + { { 3 t } { 5 t } { 4 t } { 6 t } { 5 t } { 7 t } { 6 t } { 8 t } } over heap-push-all 3 [ dup heap-pop* ] times ] unit-test -[ 2 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push heap-pop ] unit-test +[ { 2 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test -[ 1 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test +[ { 1 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test -[ 400 ] [ 300 over heap-push 200 over heap-push 400 over heap-push 3 over heap-push 2 over heap-push 1 over heap-push heap-pop ] unit-test +[ { 400 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test + +[ 0 ] [ heap-length ] unit-test +[ 1 ] [ { 1 t } over heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 74ca9e4b34..c92134c25d 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -6,7 +6,7 @@ IN: heaps ( class -- obj ) +: ( class -- heap ) >r V{ } clone heap construct-boa r> construct-delegate ; inline PRIVATE> @@ -29,9 +29,10 @@ TUPLE: max-heap ; : swap-up ( n vec -- ) >r dup up r> exchange ; inline : last-index ( vec -- n ) length 1- ; inline -GENERIC: heap-compare ( obj1 obj2 heap -- ? ) -M: min-heap heap-compare drop <=> 0 > ; -M: max-heap heap-compare drop <=> 0 < ; +GENERIC: heap-compare ( pair1 pair2 heap -- ? ) +: (heap-compare) drop [ first ] 2apply <=> 0 ; inline +M: min-heap heap-compare (heap-compare) > ; +M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) heap-data length >= ; inline @@ -84,12 +85,12 @@ DEFER: down-heap PRIVATE> -: heap-push ( obj heap -- ) +: heap-push ( pair heap -- ) tuck heap-data push [ heap-data ] keep up-heap ; : heap-push-all ( seq heap -- ) [ heap-push ] curry each ; -: heap-peek ( heap -- obj ) heap-data first ; +: heap-peek ( heap -- pair ) heap-data first ; : heap-pop* ( heap -- ) dup heap-data length 1 > [ @@ -100,5 +101,6 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- obj ) [ heap-data first ] keep heap-pop* ; +: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ; : heap-empty? ( heap -- ? ) heap-data empty? ; +: heap-length ( heap -- n ) heap-data length ; From 478af8e51cd7e20f3c013a291eb64e01033fa078 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 5 Nov 2007 11:11:09 -0600 Subject: [PATCH 53/55] Store ms/continuation pairs in the sleep queue instead of tuples Updated for new heaps --- core/threads/threads.factor | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 95536db00c..b55bec6f85 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -10,22 +10,17 @@ continuations debugger dlists ; SYMBOL: sleep-queue -TUPLE: sleeping ms continuation ; - -M: sleeping <=> ( obj1 obj2 -- n ) - [ sleeping-ms ] 2apply - ; - : sleep-time ( -- ms ) sleep-queue get-global dup heap-empty? - [ drop 1000 ] [ heap-peek sleeping-ms millis [-] ] if ; + [ drop 1000 ] [ heap-peek first millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; : schedule-sleep ( ms continuation -- ) - sleeping construct-boa sleep-queue get-global heap-push ; + 2array sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global heap-pop sleeping-continuation ; + sleep-queue get-global heap-pop second ; PRIVATE> From d481f1480cd9df379f46407aca539115c7a10543 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 12:35:44 -0500 Subject: [PATCH 54/55] Further heap cleanups --- core/heaps/heaps-docs.factor | 22 +++++++++++----------- core/heaps/heaps-tests.factor | 12 ++++++------ core/heaps/heaps.factor | 33 ++++++++++++++++++++++++--------- core/none/deploy.factor | 13 +++++++++++++ core/threads/threads.factor | 13 +++++++------ 5 files changed, 61 insertions(+), 32 deletions(-) create mode 100644 core/none/deploy.factor diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index edaa32a6a6..b140b418aa 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -1,4 +1,4 @@ -USING: heaps.private help.markup help.syntax kernel ; +USING: heaps.private help.markup help.syntax kernel math ; IN: heaps ARTICLE: "heaps" "Heaps" @@ -40,36 +40,36 @@ HELP: { $see-also } ; HELP: heap-push -{ $values { "pair" "a key/value pair" } { "heap" "a heap" } } -{ $description "Push an pair onto a heap. The first element of the pair must be comparable to the rest of the heap by the " { $link <=> } " word." } +{ $values { "key" "a comparable object" } { "value" object } { "heap" } } +{ $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } { $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence of pairs" } { "heap" "a heap" } } +{ $values { "seq" "a sequence of pairs" } { "heap" } } { $description "Push a sequence of pairs onto a heap." } { $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" "a heap" } { "pair" "a key/value pair" } } -{ $description "Returns the first element in the heap and leaves it in the heap." } +{ $values { "heap" } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap, leaving it in the heap." } { $see-also heap-pop heap-pop* } ; HELP: heap-pop* -{ $values { "heap" "a heap" } } +{ $values { "heap" } } { $description "Removes the first element from the heap." } { $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" "a heap" } { "pair" "an key/value pair" } } -{ $description "Returns the first element in the heap and removes it from the heap." } +{ $values { "heap" } { "key" object } { "value" object } } +{ $description "Outputs the first element in the heap and removes it from the heap." } { $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? -{ $values { "heap" "a heap" } { "?" "a boolean" } } +{ $values { "heap" } { "?" "a boolean" } } { $description "Tests if a " { $link heap } " has no nodes." } { $see-also heap-length heap-peek } ; HELP: heap-length -{ $values { "heap" "a heap" } { "n" "an integer" } } +{ $values { "heap" } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } { $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index d326480cb8..68e667d80e 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -8,9 +8,9 @@ IN: temporary [ heap-pop ] unit-test-fails [ t ] [ heap-empty? ] unit-test -[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test [ t ] [ heap-empty? ] unit-test -[ f ] [ { 1 t } over heap-push heap-empty? ] unit-test +[ f ] [ 1 t pick heap-push heap-empty? ] unit-test ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test @@ -25,11 +25,11 @@ IN: temporary 3 [ dup heap-pop* ] times ] unit-test -[ { 2 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push heap-pop ] unit-test +[ 2 t ] [ 300 t pick heap-push 200 t pick heap-push 400 t pick heap-push 3 t pick heap-push 2 t pick heap-push heap-pop ] unit-test -[ { 1 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test +[ 1 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test -[ { 400 t } ] [ { 300 t } over heap-push { 200 t } over heap-push { 400 t } over heap-push { 3 t } over heap-push { 2 t } over heap-push { 1 t } over heap-push heap-pop ] unit-test +[ 400 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test [ 0 ] [ heap-length ] unit-test -[ 1 ] [ { 1 t } over heap-push heap-length ] unit-test +[ 1 ] [ 1 1 pick heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index c92134c25d..14d3e20a60 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Ryan Murphy, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math sequences ; +USING: kernel math sequences arrays assocs ; IN: heaps 0 ; inline +: (heap-compare) drop [ first ] compare 0 ; inline M: min-heap heap-compare (heap-compare) > ; M: max-heap heap-compare (heap-compare) < ; : heap-bounds-check? ( m heap -- ? ) heap-data length >= ; inline - + : left-bounds-check? ( m heap -- ? ) >r left r> heap-bounds-check? ; inline @@ -72,7 +72,7 @@ DEFER: down-heap : down-heap-continue? ( heap m heap -- m heap ? ) [ heap-data nth ] 2keep child pick dupd [ heap-data nth swapd ] keep heap-compare ; - + : (down-heap) ( m heap -- ) 2dup down-heap-continue? [ -rot [ swap-down ] keep down-heap @@ -85,12 +85,17 @@ DEFER: down-heap PRIVATE> -: heap-push ( pair heap -- ) - tuck heap-data push [ heap-data ] keep up-heap ; +: heap-push ( value key heap -- ) + >r swap 2array r> + [ heap-data push ] keep + [ heap-data ] keep + up-heap ; -: heap-push-all ( seq heap -- ) [ heap-push ] curry each ; +: heap-push-all ( assoc heap -- ) + [ swap heap-push ] curry assoc-each ; -: heap-peek ( heap -- pair ) heap-data first ; +: heap-peek ( heap -- value key ) + heap-data first first2 swap ; : heap-pop* ( heap -- ) dup heap-data length 1 > [ @@ -101,6 +106,16 @@ PRIVATE> heap-data pop* ] if ; -: heap-pop ( heap -- pair ) [ heap-data first ] keep heap-pop* ; +: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ; + : heap-empty? ( heap -- ? ) heap-data empty? ; + : heap-length ( heap -- n ) heap-data length ; + +: heap-pop-all ( heap -- seq ) + [ dup heap-empty? not ] + [ dup heap-pop drop ] + [ ] unfold nip ; + +: heap-sort ( assoc -- seq ) + tuck heap-push-all heap-pop-all ; diff --git a/core/none/deploy.factor b/core/none/deploy.factor new file mode 100644 index 0000000000..f604beab3f --- /dev/null +++ b/core/none/deploy.factor @@ -0,0 +1,13 @@ +USING: tools.deploy.config ; +H{ + { deploy-math? f } + { deploy-word-defs? f } + { deploy-word-props? f } + { deploy-name "none" } + { "stop-after-last-window?" t } + { deploy-c-types? f } + { deploy-compiler? f } + { deploy-io 1 } + { deploy-ui? f } + { deploy-reflection 1 } +} diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b55bec6f85..7a67d1b531 100644 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -12,19 +12,20 @@ SYMBOL: sleep-queue : sleep-time ( -- ms ) sleep-queue get-global dup heap-empty? - [ drop 1000 ] [ heap-peek first millis [-] ] if ; + [ drop 1000 ] [ heap-peek nip millis [-] ] if ; : run-queue ( -- queue ) \ run-queue get-global ; -: schedule-sleep ( ms continuation -- ) - 2array sleep-queue get-global heap-push ; +: schedule-sleep ( continuation ms -- ) + sleep-queue get-global heap-push ; : wake-up ( -- continuation ) - sleep-queue get-global heap-pop second ; + sleep-queue get-global heap-pop drop ; PRIVATE> -: schedule-thread ( continuation -- ) run-queue push-front ; +: schedule-thread ( continuation -- ) + run-queue push-front ; : schedule-thread-with ( obj continuation -- ) 2array schedule-thread ; @@ -40,7 +41,7 @@ PRIVATE> : yield ( -- ) [ schedule-thread stop ] callcc0 ; : sleep ( ms -- ) - >fixnum millis + [ schedule-sleep stop ] callcc0 drop ; + >fixnum millis + [ schedule-sleep stop ] curry callcc0 ; : in-thread ( quot -- ) [ From 855c444ec50dcb03d836e12c089cc63a3302b203 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 5 Nov 2007 12:48:22 -0500 Subject: [PATCH 55/55] Heap unit test fixes --- core/heaps/heaps-docs.factor | 24 ++++++++++++++---------- core/heaps/heaps-tests.factor | 8 ++++---- core/heaps/heaps.factor | 10 +--------- 3 files changed, 19 insertions(+), 23 deletions(-) diff --git a/core/heaps/heaps-docs.factor b/core/heaps/heaps-docs.factor index b140b418aa..3605ec519a 100644 --- a/core/heaps/heaps-docs.factor +++ b/core/heaps/heaps-docs.factor @@ -1,4 +1,4 @@ -USING: heaps.private help.markup help.syntax kernel math ; +USING: heaps.private help.markup help.syntax kernel math assocs ; IN: heaps ARTICLE: "heaps" "Heaps" @@ -40,36 +40,40 @@ HELP: { $see-also } ; HELP: heap-push -{ $values { "key" "a comparable object" } { "value" object } { "heap" } } +{ $values { "key" "a comparable object" } { "value" object } { "heap" heap } } { $description "Push an pair onto a heap. The key must be comparable with all other keys by the " { $link <=> } " generic word." } +{ $side-effects "heap" } { $see-also heap-push-all heap-pop } ; HELP: heap-push-all -{ $values { "seq" "a sequence of pairs" } { "heap" } } -{ $description "Push a sequence of pairs onto a heap." } -{ $see-also heap-push heap-pop } ; +{ $values { "assoc" assoc } { "heap" heap } } +{ $description "Push every key/value pair of an assoc onto a heap." } +{ $side-effects "heap" } +{ $see-also heap-push heap-pop } ; HELP: heap-peek -{ $values { "heap" } { "key" object } { "value" object } } +{ $values { "heap" heap } { "key" object } { "value" object } } { $description "Outputs the first element in the heap, leaving it in the heap." } { $see-also heap-pop heap-pop* } ; HELP: heap-pop* -{ $values { "heap" } } +{ $values { "heap" heap } } { $description "Removes the first element from the heap." } +{ $side-effects "heap" } { $see-also heap-pop heap-push heap-peek } ; HELP: heap-pop -{ $values { "heap" } { "key" object } { "value" object } } +{ $values { "heap" heap } { "key" object } { "value" object } } { $description "Outputs the first element in the heap and removes it from the heap." } +{ $side-effects "heap" } { $see-also heap-pop* heap-push heap-peek } ; HELP: heap-empty? -{ $values { "heap" } { "?" "a boolean" } } +{ $values { "heap" heap } { "?" "a boolean" } } { $description "Tests if a " { $link heap } " has no nodes." } { $see-also heap-length heap-peek } ; HELP: heap-length -{ $values { "heap" } { "n" integer } } +{ $values { "heap" heap } { "n" integer } } { $description "Returns the number of key/value pairs in the heap." } { $see-also heap-empty? } ; diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index 68e667d80e..03e0816c19 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -25,11 +25,11 @@ IN: temporary 3 [ dup heap-pop* ] times ] unit-test -[ 2 t ] [ 300 t pick heap-push 200 t pick heap-push 400 t pick heap-push 3 t pick heap-push 2 t pick heap-push heap-pop ] unit-test +[ t 2 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push heap-pop ] unit-test -[ 1 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test +[ t 1 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test -[ 400 t ] [ 300 300 pick heap-push 200 200 pick heap-push 400 400 pick heap-push 3 3 pick heap-push 2 2 pick heap-push 1 1 pick heap-push heap-pop ] unit-test +[ t 400 ] [ t 300 pick heap-push t 200 pick heap-push t 400 pick heap-push t 3 pick heap-push t 2 pick heap-push t 1 pick heap-push heap-pop ] unit-test [ 0 ] [ heap-length ] unit-test -[ 1 ] [ 1 1 pick heap-push heap-length ] unit-test +[ 1 ] [ t 1 pick heap-push heap-length ] unit-test diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 14d3e20a60..73a37660f6 100644 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -92,7 +92,7 @@ PRIVATE> up-heap ; : heap-push-all ( assoc heap -- ) - [ swap heap-push ] curry assoc-each ; + [ swapd heap-push ] curry assoc-each ; : heap-peek ( heap -- value key ) heap-data first first2 swap ; @@ -111,11 +111,3 @@ PRIVATE> : heap-empty? ( heap -- ? ) heap-data empty? ; : heap-length ( heap -- n ) heap-data length ; - -: heap-pop-all ( heap -- seq ) - [ dup heap-empty? not ] - [ dup heap-pop drop ] - [ ] unfold nip ; - -: heap-sort ( assoc -- seq ) - tuck heap-push-all heap-pop-all ;