From 3f3a6ea1f772b2a288276692131dca7705d218a2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Feb 2008 16:16:00 -0600 Subject: [PATCH 01/17] Fix alarms with image saves --- core/heaps/heaps-tests.factor | 4 ++-- core/heaps/heaps.factor | 14 ++++++++++---- extra/alarms/alarms.factor | 13 ++++++++++--- 3 files changed, 22 insertions(+), 9 deletions(-) diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index ce9a417476..f199ba8837 100755 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -15,8 +15,8 @@ IN: temporary ! Binary Min Heap { 1 2 3 4 5 6 } [ 0 left 0 right 1 left 1 right 2 left 2 right ] unit-test -{ t } [ t 5 t 3 T{ min-heap } heap-compare ] unit-test -{ f } [ t 5 t 3 T{ max-heap } heap-compare ] unit-test +{ t } [ t 5 f t 3 f T{ min-heap } heap-compare ] unit-test +{ f } [ t 5 f t 3 f T{ max-heap } heap-compare ] 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 diff --git a/core/heaps/heaps.factor b/core/heaps/heaps.factor index 158e298631..caab0d8f8e 100755 --- a/core/heaps/heaps.factor +++ b/core/heaps/heaps.factor @@ -22,9 +22,9 @@ GENERIC: heap-size ( heap -- n ) : ( class -- heap ) >r V{ } clone r> construct-delegate ; inline -TUPLE: entry value key index ; +TUPLE: entry value key heap index ; -: ( value key -- entry ) f entry construct-boa ; +: ( value key heap -- entry ) f entry construct-boa ; PRIVATE> @@ -153,7 +153,7 @@ DEFER: down-heap PRIVATE> M: priority-queue heap-push* ( value key heap -- entry ) - >r dup r> [ data-push ] keep up-heap ; + [ dup ] keep [ data-push ] keep up-heap ; : heap-push ( value key heap -- ) heap-push* drop ; @@ -166,8 +166,14 @@ M: priority-queue heap-push* ( value key heap -- entry ) M: priority-queue heap-peek ( heap -- value key ) data-first >entry< ; +: entry>index ( entry heap -- n ) + over entry-heap eq? [ + "Invalid entry passed to heap-delete" throw + ] unless + entry-index ; + M: priority-queue heap-delete ( entry heap -- ) - >r entry-index r> + [ entry>index ] keep 2dup heap-size 1- = [ nip data-pop* ] [ diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index 7cac654b60..bbc20ea981 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar combinators generic init kernel math -namespaces sequences heaps boxes threads debugger quotations ; +namespaces sequences heaps boxes threads debugger quotations +assocs ; IN: alarms TUPLE: alarm quot time interval entry ; @@ -67,8 +68,13 @@ SYMBOL: alarm-thread dup trigger-alarms alarm-thread-loop ; +: cancel-alarms ( alarms -- ) + [ + heap-pop-all [ nip alarm-entry box> drop ] assoc-each + ] when* ; + : init-alarms ( -- ) - alarms set-global + alarms global [ cancel-alarms ] change-at [ alarm-thread-loop ] "Alarms" spawn alarm-thread set-global ; @@ -83,4 +89,5 @@ PRIVATE> from-now f add-alarm ; : cancel-alarm ( alarm -- ) - alarm-entry box> alarms get-global heap-delete ; + alarm-entry ?box + [ alarms get-global heap-delete ] [ drop ] if ; From 2d94e8e75693906406cce6f6a1963f8aae577146 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 22 Feb 2008 16:18:45 -0600 Subject: [PATCH 02/17] Updated alarms docs --- extra/alarms/alarms-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index d0fcc7bf66..868f161516 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -22,6 +22,7 @@ ARTICLE: "alarms" "Alarms" { $subsection alarm } { $subsection add-alarm } { $subsection later } -{ $subsection cancel-alarm } ; +{ $subsection cancel-alarm } +"Alarms do not persist across image saves. Saving and restoring an image has the effect of calling " { $link cancel-alarm } " on all " { $link alarm } " instances." ; ABOUT: "alarms" From 670aaa321af4555081ab8d1f04e5c97214d2be00 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 17:25:12 -0600 Subject: [PATCH 03/17] builder.common: stuff common to builder and builder.release --- extra/builder/common/common.factor | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) create mode 100644 extra/builder/common/common.factor diff --git a/extra/builder/common/common.factor b/extra/builder/common/common.factor new file mode 100644 index 0000000000..6ebe1d625a --- /dev/null +++ b/extra/builder/common/common.factor @@ -0,0 +1,18 @@ + +USING: kernel namespaces io.files sequences vars ; + +IN: builder.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SYMBOL: builds-dir + +: builds ( -- path ) + builds-dir get + home "/builds" append + or ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: stamp + From 99b5f9df3946c52527b27176f3f67c45e7162cbc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 17:25:42 -0600 Subject: [PATCH 04/17] builder.release: binary releases --- extra/builder/release/release.factor | 117 +++++++++++++++++++++++++++ 1 file changed, 117 insertions(+) create mode 100644 extra/builder/release/release.factor diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor new file mode 100644 index 0000000000..e1efddbf79 --- /dev/null +++ b/extra/builder/release/release.factor @@ -0,0 +1,117 @@ + +USING: kernel sequences combinators io.files io.launcher + combinators.cleave builder.common builder.util ; + +IN: builder.release + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: releases ( -- path ) builds "/releases" append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: common-files ( -- seq ) + { + "boot.x86.32.image" + "boot.x86.64.image" + "boot.macosx-ppc.boot" + "vm" + "temp" + "logs" + ".git" + ".gitignore" + "Makefile" + "cp_dir" + "unmaintained" + "misc/target" + "misc/wordsize" + "misc/wordsize.c" + "misc/macos-release.sh" + "misc/source-release.sh" + "misc/windows-release.sh" + "misc/version.sh" + } ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +USING: system sequences splitting ; + +: cpu- ( -- cpu ) cpu "." split "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: base-name ( -- string ) { "factor" os cpu- stamp> } to-strings "-" join ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: extension ( -- extension ) + os + { + { "linux" [ ".tar.gz" ] } + { "winnt" [ ".zip" ] } + { "macosx" [ ".dmg" ] } + } + case ; + +: archive-name ( -- string ) base-name extension append ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: move-file ( source destination -- ) swap { "mv" , , } run-process drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: linux-release ( -- ) + + { "rm" "-rf" "Factor.app" } run-process drop + + { "rm" "-rf" common-files } to-strings run-process drop + + ".." cd + + { "tar" "-cvzf" archive-name "factor" } to-strings run-process drop + + archive-name releases move-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: windows-release ( -- ) + + { "rm" "-rf" "Factor.app" } run-process drop + + { "rm" "-rf" common-files } to-strings run-process drop + + ".." cd + + { "zip" "-r" archive-name "factor" } to-strings run-process drop + + archive-name releases move-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: macosx-release ( -- ) + + { "rm" "-rf" common-files } to-strings run-process drop + + ".." cd + + { "hdiutil" "create" + "-srcfolder" "factor" + "-fs" "HFS+" + "-volname" "factor" + archive-name } + to-strings run-process drop + + archive-name releases move-file ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: release ( -- ) + os + { + { "linux" [ linux-release ] } + { "winnt" [ windows-release ] } + { "macosx" [ macosx-release ] } + } + case ; + \ No newline at end of file From 294a8da124ab77447748201aa72857e4bbf9eb6c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 17:26:09 -0600 Subject: [PATCH 05/17] builder: factor out stuff in builder.common --- extra/builder/builder.factor | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index d8305041ab..fe5e621a38 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,21 +2,14 @@ USING: kernel namespaces sequences splitting system combinators continuations parser io io.files io.launcher io.sockets prettyprint threads bootstrap.image benchmark vars bake smtp builder.util accessors - builder.benchmark ; + builder.common + builder.benchmark + builder.release ; IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SYMBOL: builds-dir - -: builds ( -- path ) - builds-dir get - home "/builds" append - or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : prepare-build-machine ( -- ) builds make-directory builds cd @@ -32,8 +25,6 @@ SYMBOL: builds-dir ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: stamp - : enter-build-dir ( -- ) datestamp >stamp builds cd From a0dfbf7d68c03150ddc0f97feb0f44684179eb89 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 17:32:40 -0600 Subject: [PATCH 06/17] builder.release: fix using --- extra/builder/release/release.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/builder/release/release.factor b/extra/builder/release/release.factor index e1efddbf79..db903c9501 100644 --- a/extra/builder/release/release.factor +++ b/extra/builder/release/release.factor @@ -1,5 +1,5 @@ -USING: kernel sequences combinators io.files io.launcher +USING: kernel namespaces sequences combinators io.files io.launcher combinators.cleave builder.common builder.util ; IN: builder.release From a5ee271bd0fd75a74432c0c3ba5ad5ddfc155c3e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 17:48:20 -0600 Subject: [PATCH 07/17] builder: sleep needs a dt --- extra/builder/builder.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index fe5e621a38..d9961f9452 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,6 +2,7 @@ USING: kernel namespaces sequences splitting system combinators continuations parser io io.files io.launcher io.sockets prettyprint threads bootstrap.image benchmark vars bake smtp builder.util accessors + calendar builder.common builder.benchmark builder.release ; @@ -80,7 +81,7 @@ IN: builder +closed+ >>stdin "../boot-log" >>stdout +stdout+ >>stderr - 20 minutes>ms >>timeout + 20 minutes >>timeout >desc ; : builder-test-cmd ( -- cmd ) @@ -92,7 +93,7 @@ IN: builder +closed+ >>stdin "../test-log" >>stdout +stdout+ >>stderr - 45 minutes>ms >>timeout + 45 minutes >>timeout >desc ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -216,7 +217,7 @@ USE: bootstrap.image.download ] [ drop ] recover - 5 minutes>ms sleep + 5 minutes sleep build-loop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From cbd393ee135383ac0b488267da6da1a6c1594d4f Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 22 Feb 2008 23:15:17 -0600 Subject: [PATCH 08/17] smtp: change timeout to a dt --- extra/smtp/smtp.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 47bc16e029..c74a6e72fb 100755 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -10,7 +10,7 @@ IN: smtp SYMBOL: smtp-domain SYMBOL: smtp-host "localhost" smtp-host set-global SYMBOL: smtp-port 25 smtp-port set-global -SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: read-timeout 1 minutes read-timeout set-global SYMBOL: esmtp t esmtp set-global : log-smtp-connection ( host port -- ) 2drop ; From 69da074d207107381607d2715f2b18aea2dc548f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 02:09:41 -0600 Subject: [PATCH 09/17] Pictured partial application and composition --- extra/fry/authors.txt | 2 ++ extra/fry/fry-tests.factor | 42 ++++++++++++++++++++++++++++++++++++++ extra/fry/fry.factor | 39 +++++++++++++++++++++++++++++++++++ extra/fry/summary.txt | 1 + extra/fry/tags.txt | 1 + 5 files changed, 85 insertions(+) create mode 100644 extra/fry/authors.txt create mode 100755 extra/fry/fry-tests.factor create mode 100755 extra/fry/fry.factor create mode 100644 extra/fry/summary.txt create mode 100644 extra/fry/tags.txt diff --git a/extra/fry/authors.txt b/extra/fry/authors.txt new file mode 100644 index 0000000000..e1907c6d91 --- /dev/null +++ b/extra/fry/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Eduardo Cavazos diff --git a/extra/fry/fry-tests.factor b/extra/fry/fry-tests.factor new file mode 100755 index 0000000000..fd21a4a4cd --- /dev/null +++ b/extra/fry/fry-tests.factor @@ -0,0 +1,42 @@ +IN: temporary +USING: fry tools.test math prettyprint kernel io arrays +sequences ; + +[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test + +[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test + +[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test + +[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test + +[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test + +[ [ "a" write "b" print ] ] +[ "a" "b" '[ , write , print ] ] unit-test + +[ [ 1 2 + 3 4 - ] ] +[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test + +[ 1/2 ] [ + 1 '[ , _ / ] 2 swap call +] unit-test + +[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [ + 1 '[ , _ _ 3array ] + { "a" "b" "c" } { "A" "B" "C" } rot 2map +] unit-test + +[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [ + '[ 1 _ 2array ] + { "a" "b" "c" } swap map +] unit-test + +[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [ + 1 2 '[ , _ , 3array ] + { "a" "b" "c" } swap map +] unit-test + +: funny-dip '[ @ _ ] call ; inline + +[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test diff --git a/extra/fry/fry.factor b/extra/fry/fry.factor new file mode 100755 index 0000000000..0b0b91f0d0 --- /dev/null +++ b/extra/fry/fry.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences combinators parser splitting +quotations ; +IN: fry + +: , "Only valid inside a fry" throw ; +: @ "Only valid inside a fry" throw ; +: _ "Only valid inside a fry" throw ; + +DEFER: (fry) + +: ((fry)) ( accum quot adder -- result ) + >r [ ] swap (fry) r> + append swap dup empty? [ drop ] [ + [ swap compose ] curry append + ] if ; inline + +: (fry) ( accum quot -- result ) + dup empty? [ + drop 1quotation + ] [ + unclip { + { , [ [ curry ] ((fry)) ] } + { @ [ [ compose ] ((fry)) ] } + [ swap >r add r> (fry) ] + } case + ] if ; + +: trivial-fry ( quot -- quot' ) [ ] swap (fry) ; + +: fry ( quot -- quot' ) + { _ } last-split1 [ + >r fry [ [ dip ] curry ] r> trivial-fry [ compose ] compose 3compose + ] [ + trivial-fry + ] if* ; + +: '[ \ ] parse-until fry over push-all ; parsing diff --git a/extra/fry/summary.txt b/extra/fry/summary.txt new file mode 100644 index 0000000000..340948a43c --- /dev/null +++ b/extra/fry/summary.txt @@ -0,0 +1 @@ +Syntax for pictured partial application and composition diff --git a/extra/fry/tags.txt b/extra/fry/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/fry/tags.txt @@ -0,0 +1 @@ +extensions From 564594c222f790cef614892d754dce2963e1c304 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 02:10:42 -0600 Subject: [PATCH 10/17] extra/partial-apply superseded by extra/fry --- extra/partial-apply/partial-apply.factor | 26 ------------------------ 1 file changed, 26 deletions(-) delete mode 100644 extra/partial-apply/partial-apply.factor diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor deleted file mode 100644 index 0340e53025..0000000000 --- a/extra/partial-apply/partial-apply.factor +++ /dev/null @@ -1,26 +0,0 @@ - -USING: kernel sequences quotations math parser - shuffle combinators.cleave combinators.lib sequences.lib ; - -IN: partial-apply - -! Basic conceptual implementation. Todo: get it to compile. - -: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ; - -SYMBOL: _ - -SYMBOL: ~ - -: blank-positions ( quot -- seq ) - [ length 2 - ] [ _ indices ] bi [ - ] map-with ; - -: partial-apply ( pattern -- quot ) - [ blank-positions length nrev ] - [ peek 1quotation ] - [ blank-positions ] - tri - [ apply-n ] each ; - -: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing - From 263476c3ea1ca09fbf44e3f321faa422eaf2c6db Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 23 Feb 2008 13:23:24 -0600 Subject: [PATCH 11/17] misc/target: fix case for x86-64 --- misc/target | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/misc/target b/misc/target index e55032784b..2be071c17d 100755 --- a/misc/target +++ b/misc/target @@ -8,7 +8,10 @@ then echo macosx-x86-`./misc/wordsize` elif [ \( `uname -s` = Linux \) -a \( `uname -m` = i686 \) ] then - echo linux-x86-`./misc/wordsize` + echo linux-x86-32 +elif [ \( `uname -s` = Linux \) -a \( `uname -m` = x86_64 \) ] +then + echo linux-x86-64 elif [ \( `uname -o` = Cygwin \) -a \( `uname -m` = i686 \) ] then echo winnt-x86-`./misc/wordsize` From 00333096e1e06e3665bb24348139ec84fb6165f8 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 23 Feb 2008 14:22:04 -0600 Subject: [PATCH 12/17] combinators.cleave: add general spread macro --- extra/combinators/cleave/cleave.factor | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index e1e3585813..ba49fac431 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -30,3 +30,16 @@ IN: combinators.cleave : tetra* ( obj obj obj obj quot quot quot quot -- val val val val ) >r roll >r tri* r> r> call ; inline + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General spread + +USING: sequences macros ; + +MACRO: spread ( seq -- ) + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] swap append ] map concat + append ; From 73ba7221af3e805ced4c05238a5e2b35ad3ee3b4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 23 Feb 2008 15:51:10 -0600 Subject: [PATCH 13/17] combinators.cleave: add general cleave macro --- extra/combinators/cleave/cleave.factor | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index ba49fac431..44555f7b1e 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,5 +1,5 @@ -USING: kernel ; +USING: kernel sequences macros ; IN: combinators.cleave @@ -19,6 +19,22 @@ IN: combinators.cleave : 2bi ( obj obj quot quot -- val val ) >r 2keep r> call ; inline +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! General cleave + +MACRO: cleave ( seq -- ) + dup + [ drop [ dup ] ] map concat + swap + dup + [ drop [ >r ] ] map concat + swap + [ [ r> ] append ] map concat + 3append + [ drop ] + append ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! The spread family ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -35,8 +51,6 @@ IN: combinators.cleave ! General spread -USING: sequences macros ; - MACRO: spread ( seq -- ) dup [ drop [ >r ] ] map concat From b44b334a02a61eb953b88df6668a2a6fa9a2ae71 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 22:29:29 -0600 Subject: [PATCH 14/17] Fix a smudging bug --- core/definitions/definitions.factor | 2 +- core/generic/generic.factor | 22 +++++++++++++--- core/parser/parser-tests.factor | 29 +++++++++++++++++++--- core/parser/parser.factor | 5 ++-- core/prettyprint/prettyprint.factor | 24 +++++++++++++++--- core/source-files/source-files.factor | 12 ++------- extra/editors/editors.factor | 2 +- extra/tools/crossref/crossref-tests.factor | 4 +-- extra/tools/crossref/crossref.factor | 8 +----- extra/ui/tools/search/search.factor | 6 ++--- 10 files changed, 78 insertions(+), 36 deletions(-) mode change 100644 => 100755 extra/editors/editors.factor mode change 100644 => 100755 extra/tools/crossref/crossref-tests.factor diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor index ad261df7d4..01f9643cdd 100755 --- a/core/definitions/definitions.factor +++ b/core/definitions/definitions.factor @@ -43,7 +43,7 @@ M: object uses drop f ; : xref ( defspec -- ) dup uses crossref get add-vertex ; -: usage ( defspec -- seq ) crossref get at keys ; +: usage ( defspec -- seq ) \ f or crossref get at keys ; GENERIC: redefined* ( defspec -- ) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 4bdd1ae40d..7cdaba7da5 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,11 +102,13 @@ M: method-body stack-effect ! Definition protocol M: method-spec where - dup first2 method [ method-loc ] [ second where ] ?if ; + dup first2 method [ method-word ] [ second ] ?if where ; -M: method-spec set-where first2 method set-method-loc ; +M: method-spec set-where + first2 method method-word set-where ; -M: method-spec definer drop \ M: \ ; ; +M: method-spec definer + drop \ M: \ ; ; M: method-spec definition first2 method dup [ method-def ] when ; @@ -116,7 +118,19 @@ M: method-spec definition [ delete-at* ] with-methods [ method-word forget ] [ drop ] if ; -M: method-spec forget* first2 forget-method ; +M: method-spec forget* + first2 forget-method ; + +M: method-body definer + drop \ M: \ ; ; + +M: method-body definition + "method" word-prop method-def ; + +M: method-body forget* + "method" word-prop + { method-specializer method-generic } get-slots + forget-method ; : implementors* ( classes -- words ) all-words [ diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b89f56334b..a0e7e4b909 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -351,13 +351,18 @@ IN: temporary << file get parsed >> file set : ~a ; - : ~b ~a ; + + DEFER: ~b + + "IN: temporary : ~b ~a ;" + "smudgy" parse-stream drop + : ~c ; : ~d ; - { H{ { ~a ~a } { ~c ~c } { ~d ~d } } H{ } } old-definitions set + { H{ { ~a ~a } { ~b ~b } { ~c ~c } { ~d ~d } } H{ } } old-definitions set - { H{ { ~d ~d } } H{ } } new-definitions set + { H{ { ~b ~b } { ~d ~d } } H{ } } new-definitions set [ V{ ~b } { ~a } { ~a ~c } ] [ smudged-usage @@ -365,6 +370,24 @@ IN: temporary ] unit-test ] with-scope +[ + << file get parsed >> file set + + GENERIC: ~e + + : ~f ~e ; + + : ~g ; + + { H{ { ~e ~e } { ~f ~f } { ~g ~g } } H{ } } old-definitions set + + { H{ { ~g ~g } } H{ } } new-definitions set + + [ V{ } { } { ~e ~f } ] + [ smudged-usage natural-sort ] + unit-test +] with-scope + [ ] [ "IN: temporary USE: kernel PREDICATE: object foo ( x -- y ) ;" eval ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 9bc02c763d..e2efdd8163 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -439,11 +439,12 @@ SYMBOL: interactive-vocabs "Warning: the following definitions were removed from sources," print "but are still referenced from other definitions:" print nl - dup stack. + dup sorted-definitions. nl "The following definitions need to be updated:" print nl - over stack. + over sorted-definitions. + nl ] when 2drop ; : filter-moved ( assoc -- newassoc ) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 0cbde2a586..2efc9b4e67 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -174,6 +174,12 @@ M: hook-generic synopsis* M: method-spec synopsis* dup definer. [ pprint-word ] each ; +M: method-body synopsis* + dup definer. + "method" word-prop dup + method-specializer pprint* + method-generic pprint* ; + M: mixin-instance synopsis* dup definer. dup mixin-instance-class pprint-word @@ -188,6 +194,15 @@ M: pathname synopsis* pprint* ; [ synopsis* ] with-in ] with-string-writer ; +: synopsis-alist ( definitions -- alist ) + [ dup synopsis swap ] { } map>assoc ; + +: definitions. ( alist -- ) + [ write-object nl ] assoc-each ; + +: sorted-definitions. ( definitions -- ) + synopsis-alist sort-keys definitions. ; + GENERIC: declarations. ( obj -- ) M: object declarations. drop ; @@ -253,7 +268,9 @@ M: builtin-class see-class* natural-sort [ nl see ] each ; : see-implementors ( class -- seq ) - dup implementors [ 2array ] with map ; + dup implementors + [ method method-word ] with map + natural-sort ; : see-class ( class -- ) dup class? [ @@ -263,8 +280,9 @@ M: builtin-class see-class* ] when drop ; : see-methods ( generic -- seq ) - [ "methods" word-prop keys natural-sort ] keep - [ 2array ] curry map ; + "methods" word-prop + [ nip method-word ] { } assoc>map + natural-sort ; M: word see dup see-class diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c7539ad3eb..dd5313383e 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -97,16 +97,8 @@ SYMBOL: file [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline -: smart-usage ( word -- definitions ) - \ f or usage [ - dup method-body? [ - "method" word-prop - { method-specializer method-generic } get-slots - 2array - ] when - ] map ; - : outside-usages ( seq -- usages ) dup [ - over smart-usage [ pathname? not ] subset seq-diff + over usage + [ dup pathname? not swap where and ] subset seq-diff ] curry { } map>assoc ; diff --git a/extra/editors/editors.factor b/extra/editors/editors.factor old mode 100644 new mode 100755 index 7d95c8ce8a..f0c5289dd9 --- a/extra/editors/editors.factor +++ b/extra/editors/editors.factor @@ -43,7 +43,7 @@ SYMBOL: edit-hook : fix ( word -- ) "Fixing " write dup pprint " and all usages..." print nl - dup smart-usage swap add* [ + dup usage swap add* [ "Editing " write dup . "RETURN moves on to the next usage, C+d stops." print flush diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor old mode 100644 new mode 100755 index 657b5fc030..afad3a2a49 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -8,5 +8,5 @@ M: integer foo + ; "resource:extra/tools/test/foo.factor" run-file -[ t ] [ { integer foo } \ + smart-usage member? ] unit-test -[ t ] [ \ foo smart-usage [ pathname? ] contains? ] unit-test +[ t ] [ integer \ foo method method-word \ + usage member? ] unit-test +[ t ] [ \ foo usage [ pathname? ] contains? ] unit-test diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index f6561e9f26..f4515a9ebe 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -6,14 +6,8 @@ generic tools.completion quotations parser inspector sorting hashtables vocabs parser source-files ; IN: tools.crossref -: synopsis-alist ( definitions -- alist ) - [ dup synopsis swap ] { } map>assoc ; - -: definitions. ( alist -- ) - [ write-object nl ] assoc-each ; - : usage. ( word -- ) - smart-usage synopsis-alist sort-keys definitions. ; + usage sorted-definitions. ; : words-matching ( str -- seq ) all-words [ dup word-name ] { } map>assoc completions ; diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index 978ca295ca..8041db3c77 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -3,8 +3,8 @@ USING: assocs ui.tools.interactor ui.tools.listener ui.tools.workspace help help.topics io.files io.styles kernel models namespaces prettyprint quotations sequences sorting -source-files strings tools.completion tools.crossref tuples -ui.commands ui.gadgets ui.gadgets.editors +source-files definitions strings tools.completion tools.crossref +tuples ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations vocabs words vocabs.loader tools.browser unicode.case calendar ; @@ -93,7 +93,7 @@ M: live-search pref-dim* drop { 400 200 } ; "Words in " rot vocab-name append show-titled-popup ; : show-word-usage ( workspace word -- ) - "" over smart-usage f + "" over usage f "Words and methods using " rot word-name append show-titled-popup ; From 46ab3bdd18971ed7a2a7047d84ef2000ba1d9e10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 22:29:46 -0600 Subject: [PATCH 15/17] Clean up alarms --- extra/alarms/alarms-docs.factor | 3 +-- extra/alarms/alarms.factor | 8 +++----- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index 868f161516..b609878c77 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -14,8 +14,7 @@ HELP: later HELP: cancel-alarm { $values { "alarm" alarm } } -{ $description "Cancels an alarm." } -{ $errors "Throws an error if the alarm is not active." } ; +{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ; ARTICLE: "alarms" "Alarms" "Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread." diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index bbc20ea981..92a7c488ef 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -56,15 +56,13 @@ SYMBOL: alarm-thread : trigger-alarms ( alarms -- ) now (trigger-alarms) ; -: next-alarm ( alarms -- ms ) +: next-alarm ( alarms -- timestamp/f ) dup heap-empty? - [ drop f ] - [ heap-peek drop alarm-time now timestamp- 1000 * 0 max ] - if ; + [ drop f ] [ heap-peek drop alarm-time ] if ; : alarm-thread-loop ( -- ) alarms get-global - dup next-alarm nap drop + dup next-alarm nap-until drop dup trigger-alarms alarm-thread-loop ; From cc600ad54fb42966a8f418e943eaa1ec804a8c62 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 22:48:45 -0600 Subject: [PATCH 16/17] Cleanups and fixes --- core/generic/generic.factor | 2 +- core/sequences/sequences.factor | 12 +++++------- extra/benchmark/sockets/sockets.factor | 10 +++++----- extra/sequences/next/next.factor | 2 ++ extra/smtp/server/server.factor | 2 +- extra/tools/crossref/crossref-tests.factor | 2 +- 6 files changed, 15 insertions(+), 15 deletions(-) mode change 100644 => 100755 extra/sequences/next/next.factor diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 7cdaba7da5..35cc471033 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -116,7 +116,7 @@ M: method-spec definition : forget-method ( class generic -- ) check-method [ delete-at* ] with-methods - [ method-word forget ] [ drop ] if ; + [ method-word forget-word ] [ drop ] if ; M: method-spec forget* first2 forget-method ; diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ee38d30750..7208e05af0 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -310,13 +310,11 @@ M: immutable-sequence clone-like like ; r dup length swap r> ; inline - : (each) ( seq quot -- n quot' ) - iterate-seq [ >r nth-unsafe r> call ] 2curry ; inline + >r dup length swap [ nth-unsafe ] curry r> compose ; inline : (collect) ( quot into -- quot' ) - [ >r over slip r> set-nth-unsafe ] 2curry ; inline + [ >r keep r> set-nth-unsafe ] 2curry ; inline : collect ( n quot into -- ) (collect) each-integer ; inline @@ -415,7 +413,7 @@ PRIVATE> >r dup length 1- swap r> (monotonic) all? ; inline : interleave ( seq between quot -- ) - [ (interleave) ] 2curry iterate-seq 2each ; inline + [ (interleave) ] 2curry >r dup length swap r> 2each ; inline : unfold ( pred quot tail -- seq ) V{ } clone [ @@ -695,9 +693,9 @@ PRIVATE> : sequence-hashcode-step ( oldhash newpart -- newhash ) swap [ - dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum + dup -2 fixnum-shift-fast swap 5 fixnum-shift-fast fixnum+fast fixnum+fast - ] keep bitxor ; inline + ] keep fixnum-bitxor ; inline : sequence-hashcode ( n seq -- x ) 0 -rot [ diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 36529facaa..6b1908afb1 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -34,10 +34,10 @@ IN: benchmark.sockets : socket-benchmarks 10 clients 20 clients - 40 clients - 80 clients - 160 clients - 320 clients - 640 clients ; + 40 clients ; + ! 80 clients + ! 160 clients + ! 320 clients + ! 640 clients ; MAIN: socket-benchmarks diff --git a/extra/sequences/next/next.factor b/extra/sequences/next/next.factor old mode 100644 new mode 100755 index 5483cdff4b..5919fb0701 --- a/extra/sequences/next/next.factor +++ b/extra/sequences/next/next.factor @@ -3,6 +3,8 @@ IN: sequences.next r dup length swap r> ; inline + : (map-next) ( i seq quot -- ) ! this uses O(n) more bounds checks than is really necessary >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor index eb628156f2..c28ec7745a 100755 --- a/extra/smtp/server/server.factor +++ b/extra/smtp/server/server.factor @@ -28,7 +28,7 @@ ! Connection closed by foreign host. USING: combinators kernel prettyprint io io.timeouts io.server -sequences namespaces io.sockets continuations ; +sequences namespaces io.sockets continuations calendar ; IN: smtp.server SYMBOL: data-mode diff --git a/extra/tools/crossref/crossref-tests.factor b/extra/tools/crossref/crossref-tests.factor index afad3a2a49..b616766597 100755 --- a/extra/tools/crossref/crossref-tests.factor +++ b/extra/tools/crossref/crossref-tests.factor @@ -1,5 +1,5 @@ USING: math kernel sequences io.files tools.crossref tools.test -parser namespaces source-files ; +parser namespaces source-files generic definitions ; IN: temporary GENERIC: foo From 268dfaeec923b1da82cee06e648bf60da8d8d40d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 23 Feb 2008 23:15:50 -0600 Subject: [PATCH 17/17] Get furnace to load again --- extra/furnace/furnace.factor | 12 +---- extra/furnace/sessions/sessions.factor | 51 +++++++++++-------- .../assoc-heaps/assoc-heaps-tests.factor | 0 .../assoc-heaps/assoc-heaps.factor | 0 .../assoc-heaps/authors.txt | 0 .../assoc-heaps/summary.txt | 0 6 files changed, 33 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/furnace/sessions/sessions.factor rename {extra => unmaintained}/assoc-heaps/assoc-heaps-tests.factor (100%) rename {extra => unmaintained}/assoc-heaps/assoc-heaps.factor (100%) rename {extra => unmaintained}/assoc-heaps/authors.txt (100%) rename {extra => unmaintained}/assoc-heaps/summary.txt (100%) diff --git a/extra/furnace/furnace.factor b/extra/furnace/furnace.factor index 9b7a8a8aa5..11ff697049 100755 --- a/extra/furnace/furnace.factor +++ b/extra/furnace/furnace.factor @@ -57,17 +57,9 @@ SYMBOL: validation-errors ] if* ] with map ; -: expire-sessions ( -- ) - sessions get-global - [ nip session-last-seen 20 minutes ago <=> 0 > ] - [ 2drop ] heap-pop-while ; - : lookup-session ( hash -- session ) - "furnace-session-id" over at sessions get-global at [ - nip - ] [ - new-session rot "furnace-session-id" swap set-at - ] if* ; + "furnace-session-id" over at get-session + [ ] [ new-session "furnace-session-id" roll set-at ] ?if ; : quot>query ( seq action -- hash ) >r >array r> "action-params" word-prop diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor old mode 100644 new mode 100755 index 523598efe7..579e5a607e --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -1,37 +1,48 @@ -USING: assoc-heaps assocs calendar crypto.sha2 heaps -init kernel math.parser namespaces random ; +USING: assocs calendar init kernel math.parser +namespaces random boxes alarms ; IN: furnace.sessions SYMBOL: sessions +: timeout ( -- dt ) 20 minutes ; + [ - H{ } clone - sessions set-global + H{ } clone sessions set-global ] "furnace.sessions" add-init-hook : new-session-id ( -- str ) - 4 big-random number>string string>sha-256-string - dup sessions get-global at [ drop new-session-id ] when ; + 4 big-random >hex + dup sessions get-global key? + [ drop new-session-id ] when ; -TUPLE: session created last-seen user-agent namespace ; +TUPLE: session id namespace alarm user-agent ; -M: session <=> ( session1 session2 -- n ) - [ session-last-seen ] 2apply <=> ; +: cancel-timeout ( session -- ) + session-alarm ?box [ cancel-alarm ] [ drop ] if ; -: ( -- obj ) - now dup H{ } clone - [ set-session-created set-session-last-seen set-session-namespace ] - \ session construct ; +: delete-session ( session -- ) + sessions get-global delete-at* + [ cancel-timeout ] [ drop ] if ; -: new-session ( -- obj id ) - new-session-id [ sessions get-global set-at ] 2keep ; +: touch-session ( session -- ) + dup cancel-timeout + dup [ session-id delete-session ] curry timeout later + swap session-alarm >box ; -: get-session ( id -- obj/f ) - sessions get-global at* [ "no session found 1" throw ] unless ; +: ( id -- session ) + H{ } clone f session construct-boa ; -! Delete from the assoc only, the heap will timeout -: destroy-session ( id -- ) - sessions get-global assoc-heap-assoc delete-at ; +: new-session ( -- session id ) + new-session-id [ + dup [ + [ sessions get-global set-at ] keep + touch-session + ] keep + ] keep ; + +: get-session ( id -- session/f ) + sessions get-global at* + [ dup touch-session ] when ; : session> ( str -- obj ) session get session-namespace at ; diff --git a/extra/assoc-heaps/assoc-heaps-tests.factor b/unmaintained/assoc-heaps/assoc-heaps-tests.factor similarity index 100% rename from extra/assoc-heaps/assoc-heaps-tests.factor rename to unmaintained/assoc-heaps/assoc-heaps-tests.factor diff --git a/extra/assoc-heaps/assoc-heaps.factor b/unmaintained/assoc-heaps/assoc-heaps.factor similarity index 100% rename from extra/assoc-heaps/assoc-heaps.factor rename to unmaintained/assoc-heaps/assoc-heaps.factor diff --git a/extra/assoc-heaps/authors.txt b/unmaintained/assoc-heaps/authors.txt similarity index 100% rename from extra/assoc-heaps/authors.txt rename to unmaintained/assoc-heaps/authors.txt diff --git a/extra/assoc-heaps/summary.txt b/unmaintained/assoc-heaps/summary.txt similarity index 100% rename from extra/assoc-heaps/summary.txt rename to unmaintained/assoc-heaps/summary.txt