From 7fa7ed962f3c0f0e490f95926e6b686c1bf1cfa5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:28:09 -0600 Subject: [PATCH 01/16] Fix prettyprinting of invalid curries and tuples --- core/prettyprint/backend/backend.factor | 13 ++++++++++++- core/prettyprint/prettyprint-tests.factor | 4 ++++ 2 files changed, 16 insertions(+), 1 deletion(-) diff --git a/core/prettyprint/backend/backend.factor b/core/prettyprint/backend/backend.factor index d1364a5986..226595aa4d 100755 --- a/core/prettyprint/backend/backend.factor +++ b/core/prettyprint/backend/backend.factor @@ -182,9 +182,20 @@ M: tuple pprint-narrow? drop t ; >pprint-sequence pprint-elements block> r> pprint-word block> ] check-recursion ; - + M: object pprint* pprint-object ; +M: curry pprint* + dup curry-quot callable? [ pprint-object ] [ + "( invalid curry )" swap present-text + ] if ; + +M: compose pprint* + dup compose-first over compose-second [ callable? ] both? + [ pprint-object ] [ + "( invalid compose )" swap present-text + ] if ; + M: wrapper pprint* dup wrapped word? [ diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 5907c22686..a7e087ffad 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -321,3 +321,7 @@ unit-test [ [ 2 . ] ] [ [ 2 \ break (step-into) . ] (remove-breakpoints) ] unit-test + +[ ] [ 1 \ + curry unparse drop ] unit-test + +[ ] [ 1 \ + compose unparse drop ] unit-test From c6be6bcfdf076fc95e7b065b1dfc49137e3fea60 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 15:53:42 -0600 Subject: [PATCH 02/16] New sockets benchmark --- extra/benchmark/sockets/sockets.factor | 29 ++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100755 extra/benchmark/sockets/sockets.factor diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor new file mode 100755 index 0000000000..876ff0b61d --- /dev/null +++ b/extra/benchmark/sockets/sockets.factor @@ -0,0 +1,29 @@ +USING: io.sockets io.server io kernel math threads debugger +concurrency tools.time prettyprint ; +IN: benchmark.sockets + +: simple-server ( -- ) + 7777 local-server "simple-server" [ + 10 [ read1 write1 flush ] times + ] with-server ; + +: simple-client ( -- ) + "localhost" 7777 [ + 10 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: socket-benchmark ( n -- ) + dup pprint " clients: " write + [ simple-server ] in-thread + yield yield + [ drop simple-client ] parallel-each ; + +: socket-benchmarks + [ 10 socket-benchmark ] time + [ 20 socket-benchmark ] time + [ 40 socket-benchmark ] time + [ 80 socket-benchmark ] time + [ 160 socket-benchmark ] time + [ 320 socket-benchmark ] time ; + +MAIN: socket-benchmarks From 80c9fe3c83b5890fe14cc7b499a268299e8b26ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:03 -0600 Subject: [PATCH 03/16] Add stop-server word --- extra/io/server/server.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index a23984c207..5cb5aa5592 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -26,8 +26,10 @@ LOG: accepted-connection NOTICE : server-loop ( server quot -- ) [ accept-loop ] curry with-disposal ; inline +SYMBOL: servers + : spawn-server ( addrspec quot -- ) - >r r> server-loop ; inline + >r dup servers get push r> server-loop ; inline \ spawn-server NOTICE add-error-logging @@ -39,9 +41,13 @@ LOG: accepted-connection NOTICE : with-server ( seq service quot -- ) [ + V{ } clone servers set [ spawn-server ] curry concurrency:parallel-each ] curry with-logging ; inline +: stop-server ( -- ) + servers get [ dispose ] each ; + : received-datagram ( addrspec -- ) drop ; \ received-datagram NOTICE add-input-logging From 5c0374ce3251f4145bab54bad89a136880a53c95 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:10:11 -0600 Subject: [PATCH 04/16] Improved sockets benchmark --- extra/benchmark/sockets/sockets.factor | 38 ++++++++++++++++++-------- 1 file changed, 26 insertions(+), 12 deletions(-) diff --git a/extra/benchmark/sockets/sockets.factor b/extra/benchmark/sockets/sockets.factor index 876ff0b61d..e8efc11c32 100755 --- a/extra/benchmark/sockets/sockets.factor +++ b/extra/benchmark/sockets/sockets.factor @@ -3,27 +3,41 @@ concurrency tools.time prettyprint ; IN: benchmark.sockets : simple-server ( -- ) - 7777 local-server "simple-server" [ - 10 [ read1 write1 flush ] times + 7777 local-server "benchmark.sockets" [ + read1 CHAR: x = [ + stop-server + ] [ + 20 [ read1 write1 flush ] times + ] if ] with-server ; : simple-client ( -- ) "localhost" 7777 [ - 10 [ CHAR: a dup write1 flush read1 assert= ] times + CHAR: b write1 flush + 20 [ CHAR: a dup write1 flush read1 assert= ] times + ] with-stream ; + +: stop-server ( -- ) + "localhost" 7777 [ + CHAR: x write1 ] with-stream ; : socket-benchmark ( n -- ) dup pprint " clients: " write - [ simple-server ] in-thread - yield yield - [ drop simple-client ] parallel-each ; + [ + [ simple-server ] in-thread + 100 sleep + [ drop simple-client ] parallel-each + stop-server + yield yield + ] time ; : socket-benchmarks - [ 10 socket-benchmark ] time - [ 20 socket-benchmark ] time - [ 40 socket-benchmark ] time - [ 80 socket-benchmark ] time - [ 160 socket-benchmark ] time - [ 320 socket-benchmark ] time ; + 10 socket-benchmark + 20 socket-benchmark + 40 socket-benchmark + 80 socket-benchmark + 160 socket-benchmark + 320 socket-benchmark ; MAIN: socket-benchmarks From bacc5dc61075198363019d88daa7d920960fde33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:19:10 -0600 Subject: [PATCH 05/16] Fix factor.sh for NetBSD --- misc/Factor.tmbundle/Commands/Eval Selection | 0 misc/Factor.tmbundle/Commands/Run Selection | 0 misc/factor.sh | 59 +++++++++++--------- 3 files changed, 33 insertions(+), 26 deletions(-) create mode 100644 misc/Factor.tmbundle/Commands/Eval Selection create mode 100644 misc/Factor.tmbundle/Commands/Run Selection diff --git a/misc/Factor.tmbundle/Commands/Eval Selection b/misc/Factor.tmbundle/Commands/Eval Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/Factor.tmbundle/Commands/Run Selection b/misc/Factor.tmbundle/Commands/Run Selection new file mode 100644 index 0000000000..e69de29bb2 diff --git a/misc/factor.sh b/misc/factor.sh index f0eb232821..5d7e7d0b94 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -1,4 +1,4 @@ -#!/bin/bash -e +#!/usr/bin/env bash # Programs returning != 0 will not cause script to exit set +e @@ -11,6 +11,9 @@ OS= ARCH= WORD= NO_UI= +GIT_PROTOCOL=${GIT_PROTOCOL:="git"} +GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"} + ensure_program_installed() { echo -n "Checking for $1..." @@ -51,6 +54,9 @@ check_installed_programs() { ensure_program_installed wget ensure_program_installed gcc ensure_program_installed make + case $OS in + netbsd) ensure_program_installed gmake;; + esac check_gcc_version } @@ -106,6 +112,7 @@ find_os() { *Darwin*) OS=macosx;; *linux*) OS=linux;; *Linux*) OS=linux;; + *NetBSD*) OS=netbsd;; esac } @@ -153,6 +160,8 @@ echo_build_info() { echo MAKE_TARGET=$MAKE_TARGET echo BOOT_IMAGE=$BOOT_IMAGE echo MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET + echo GIT_PROTOCOL=$GIT_PROTOCOL + echo GIT_URL=$GIT_URL } set_build_info() { @@ -188,22 +197,19 @@ find_build_info() { echo_build_info } +invoke_git() { + git $* + check_ret git +} + git_clone() { echo "Downloading the git repository from factorcode.org..." - git clone git://factorcode.org/git/factor.git - check_ret git + invoke_git clone $GIT_URL } git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git master - check_ret git -} - -http_git_pull_factorcode() { - echo "Updating the git repository from factorcode.org..." - git pull http://factorcode.org/git/factor.git master - check_ret git + invoke_git pull $GIT_URL master } cd_factor() { @@ -211,21 +217,28 @@ cd_factor() { check_ret cd } +invoke_make() { + case $OS in + netbsd) make='gmake';; + *) make='make';; + esac + $make $* + check_ret $make +} + make_clean() { - make clean - check_ret make + invoke_make clean } make_factor() { - make NO_UI=$NO_UI $MAKE_TARGET -j5 - check_ret make + invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5 } delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 - rm staging.*.image > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { @@ -257,8 +270,8 @@ maybe_download_dlls() { } get_config_info() { - check_installed_programs find_build_info + check_installed_programs check_libraries } @@ -285,13 +298,6 @@ update() { make_factor } -http_update() { - get_config_info - http_git_pull_factorcode - make_clean - make_factor -} - update_bootstrap() { delete_boot_images get_boot_image @@ -299,7 +305,7 @@ update_bootstrap() { } refresh_image() { - ./$FACTOR_BINARY -script -e="refresh-all save 0 USE: system exit" + ./$FACTOR_BINARY -script -e="USE: vocabs.loader refresh-all USE: memory save 0 USE: system exit" check_ret factor } @@ -316,6 +322,8 @@ install_libraries() { usage() { echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap" + echo "If you are behind a firewall, invoke as:" + echo "env GIT_PROTOCOL=http $0 " } case "$1" in @@ -324,7 +332,6 @@ case "$1" in self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; - http-update) http_update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; From 8db19c2ee5cb6e144d417084357d56a3631d1062 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:16 -0600 Subject: [PATCH 06/16] add ?first2 --- extra/sequences/lib/lib.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 048d63dc64..1d95f9fdf6 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -178,6 +178,10 @@ PRIVATE> : ?third ( seq -- third/f ) 2 swap ?nth ; inline : ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline +: ?first2 ( seq -- 1st/f 2nd/f ) dup ?first swap ?second ; inline +: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline +: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline + : accumulator ( quot -- quot vec ) V{ } clone [ [ push ] curry compose ] keep ; From 0699bacf86e862dcc569c4fca0eff907c420d40d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:21:59 -0600 Subject: [PATCH 07/16] add money library --- extra/money/authors.txt | 2 ++ extra/money/money-tests.factor | 21 +++++++++++++++++++++ extra/money/money.factor | 29 +++++++++++++++++++++++++++++ extra/money/summary.txt | 1 + 4 files changed, 53 insertions(+) create mode 100644 extra/money/authors.txt create mode 100644 extra/money/money-tests.factor create mode 100644 extra/money/money.factor create mode 100644 extra/money/summary.txt diff --git a/extra/money/authors.txt b/extra/money/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/extra/money/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/extra/money/money-tests.factor b/extra/money/money-tests.factor new file mode 100644 index 0000000000..19d6b6c2aa --- /dev/null +++ b/extra/money/money-tests.factor @@ -0,0 +1,21 @@ +USING: money parser tools.test ; +IN: temporary + +[ -1/10 ] [ DECIMAL: -.1 ] unit-test +[ -1/10 ] [ DECIMAL: -0.1 ] unit-test +[ -1/10 ] [ DECIMAL: -00.10 ] unit-test + +[ 0 ] [ DECIMAL: .0 ] unit-test +[ 0 ] [ DECIMAL: 0.0 ] unit-test +[ 0 ] [ DECIMAL: 0. ] unit-test +[ 0 ] [ DECIMAL: 0 ] unit-test +[ 1/10 ] [ DECIMAL: .1 ] unit-test +[ 1/10 ] [ DECIMAL: 0.1 ] unit-test +[ 1/10 ] [ DECIMAL: 00.10 ] unit-test + + + +[ "DECIMAL: ." eval ] must-fail +[ "DECIMAL: f" eval ] must-fail +[ "DECIMAL: 0.f" eval ] must-fail +[ "DECIMAL: f.0" eval ] must-fail diff --git a/extra/money/money.factor b/extra/money/money.factor new file mode 100644 index 0000000000..d742a3be5a --- /dev/null +++ b/extra/money/money.factor @@ -0,0 +1,29 @@ +USING: io kernel math math.functions math.parser parser +namespaces sequences splitting combinators continuations +sequences.lib ; +IN: money + +: dollars/cents ( dollars -- dollars cents ) + 100 * 100 /mod round ; + +: money. ( object -- ) + dollars/cents + [ + "$" % + swap number>string + 3 group "," join % + "." % number>string 2 48 pad-left % + ] "" make print ; + +TUPLE: not-a-decimal ; +: DECIMAL: + scan + "." split dup length 1 2 between? [ + T{ not-a-decimal } throw + ] unless + ?first2 + >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + [ dup empty? [ drop "0" ] when ] 2apply + dup length + >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when parsed ; parsing diff --git a/extra/money/summary.txt b/extra/money/summary.txt new file mode 100644 index 0000000000..fcfaf151f6 --- /dev/null +++ b/extra/money/summary.txt @@ -0,0 +1 @@ +Utility for calculating money with rationals From 0e9ec0dd6a4a4c62ea3afcf99a36ce4f330cf150 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:22 -0600 Subject: [PATCH 08/16] Add taxes library --- extra/taxes/authors.txt | 1 + extra/taxes/summary.txt | 1 + extra/taxes/taxes-tests.factor | 98 +++++++++++++++++++++++ extra/taxes/taxes.factor | 140 +++++++++++++++++++++++++++++++++ 4 files changed, 240 insertions(+) create mode 100644 extra/taxes/authors.txt create mode 100644 extra/taxes/summary.txt create mode 100644 extra/taxes/taxes-tests.factor create mode 100644 extra/taxes/taxes.factor diff --git a/extra/taxes/authors.txt b/extra/taxes/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/taxes/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/taxes/summary.txt b/extra/taxes/summary.txt new file mode 100644 index 0000000000..e983139ccb --- /dev/null +++ b/extra/taxes/summary.txt @@ -0,0 +1 @@ +Calculate federal and state tax withholdings diff --git a/extra/taxes/taxes-tests.factor b/extra/taxes/taxes-tests.factor new file mode 100644 index 0000000000..4091156558 --- /dev/null +++ b/extra/taxes/taxes-tests.factor @@ -0,0 +1,98 @@ +USING: kernel money taxes tools.test ; +IN: temporary + +[ + 426 23 +] [ + 12000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 426 23 +] [ + 12000 2008 3 t net biweekly + dollars/cents +] unit-test + +[ + 684 4 +] [ + 20000 2008 3 f net biweekly + dollars/cents +] unit-test + + + +[ + 804 58 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 831 31 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 780 81 +] [ + 24000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 818 76 +] [ + 24000 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2124 39 +] [ + 78250 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 2321 76 +] [ + 78250 2008 3 t net biweekly + dollars/cents +] unit-test + + +[ + 2612 63 +] [ + 100000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 22244 52 +] [ + 1000000 2008 3 f net biweekly + dollars/cents +] unit-test + +[ + 578357 40 +] [ + 1000000 2008 3 f net + dollars/cents +] unit-test + +[ + 588325 41 +] [ + 1000000 2008 3 t net + dollars/cents +] unit-test diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor new file mode 100644 index 0000000000..0f51d7ab6a --- /dev/null +++ b/extra/taxes/taxes.factor @@ -0,0 +1,140 @@ +USING: arrays assocs kernel math math.intervals namespaces +sequences combinators.lib money ; +IN: taxes + +: monthly ( x -- y ) 12 / ; +: semimonthly ( x -- y ) 24 / ; +: biweekly ( x -- y ) 26 / ; +: weekly ( x -- y ) 52 / ; +: daily ( x -- y ) 360 / ; + +! Each employee fills out a w4 +TUPLE: w4 year allowances married? ; +C: w4 + +: allowance ( -- x ) 3500 ; inline + +: calculate-w4-allowances ( w4 -- x ) + w4-allowances allowance * ; + +! Withhold: FICA, Medicare, Federal (FICA is social security) +: fica-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! Base rate -- income over this rate is not taxed +TUPLE: fica-base-unknown ; +: fica-base-rate ( year -- x ) + H{ + { 2008 102000 } + { 2007 97500 } + } at* [ T{ fica-base-unknown } throw ] unless ; + +: fica-tax ( salary w4 -- x ) + w4-year fica-base-rate min fica-tax-rate * ; + +! Employer tax only, not withheld +: futa-tax-rate ( -- x ) DECIMAL: .062 ; inline + +! No base rate for medicare; all wages subject +: medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline +: medicare-tax ( salary w4 -- x ) drop medicare-tax-rate * ; + +MIXIN: collector +GENERIC: adjust-allowances ( salary w4 collector -- newsalary ) +GENERIC: withholding ( salary w4 collector -- x ) +GENERIC: net ( salary w4 collector -- x ) + +TUPLE: tax-table single married ; + +: ( single married class -- obj ) + >r tax-table construct-boa r> construct-delegate ; + +: tax-bracket-range dup second swap first - ; + +: tax-bracket ( tax salary triples -- tax salary ) + [ [ tax-bracket-range min ] keep third * + ] 2keep + tax-bracket-range [-] ; + +: tax ( salary triples -- x ) + 0 -rot [ tax-bracket ] each drop ; + +: marriage-table ( w4 tax-table -- triples ) + swap w4-married? + [ tax-table-married ] [ tax-table-single ] if ; + +: federal-tax ( salary w4 tax-table -- n ) + [ adjust-allowances ] 2keep marriage-table tax ; + +! http://www.irs.gov/pub/irs-pdf/p15.pdf +! Table 7 ANNUAL Payroll Period + +: federal-single ( -- triples ) + { + { 0 2650 DECIMAL: 0 } + { 2650 10300 DECIMAL: .10 } + { 10300 33960 DECIMAL: .15 } + { 33960 79725 DECIMAL: .25 } + { 79725 166500 DECIMAL: .28 } + { 166500 359650 DECIMAL: .33 } + { 359650 1/0. DECIMAL: .35 } + } ; + +: federal-married ( -- triples ) + { + { 0 8000 DECIMAL: 0 } + { 8000 23550 DECIMAL: .10 } + { 23550 72150 DECIMAL: .15 } + { 72150 137850 DECIMAL: .25 } + { 137850 207700 DECIMAL: .28 } + { 207700 365100 DECIMAL: .33 } + { 365100 1/0. DECIMAL: .35 } + } ; + +TUPLE: federal ; +INSTANCE: federal collector +: ( -- obj ) + federal-single federal-married federal ; + +M: federal adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: federal withholding ( salary w4 tax-table -- x ) + [ federal-tax ] 3keep drop + [ fica-tax ] 2keep + medicare-tax + + ; + +M: federal net ( salary w4 collector -- x ) + >r dupd r> withholding - ; + +M: collector net ( salary w4 collector -- x ) + >r dupd r> + [ withholding ] 3keep + drop withholding + - ; + + +! Minnesota +: minnesota-single ( -- triples ) + { + { 0 1950 DECIMAL: 0 } + { 1950 23750 DECIMAL: .0535 } + { 23750 73540 DECIMAL: .0705 } + { 73540 1/0. DECIMAL: .0785 } + } ; + +: minnesota-married ( -- triples ) + { + { 0 7400 DECIMAL: 0 } + { 7400 39260 DECIMAL: .0535 } + { 39260 133980 DECIMAL: .0705 } + { 133980 1/0. DECIMAL: .0785 } + } ; + +TUPLE: minnesota ; +INSTANCE: minnesota collector +: ( -- obj ) + minnesota-single minnesota-married minnesota ; + +M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) + drop calculate-w4-allowances - ; + +M: minnesota withholding ( salary w4 collector -- x ) + [ adjust-allowances ] 2keep marriage-table tax ; From 34c1170963820b19c728453d00c46ba870443b2a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:27:40 -0600 Subject: [PATCH 09/16] add a few utility words --- extra/html/parser/analyzer/analyzer.factor | 35 +++++++++------------- 1 file changed, 14 insertions(+), 21 deletions(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index e4f11cd91e..dcfbd1e197 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,5 @@ -USING: assocs html.parser kernel math sequences strings unicode.categories - unicode.case ; +USING: assocs html.parser kernel math sequences strings ascii +arrays shuffle unicode.case namespaces ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -65,28 +65,21 @@ IN: html.parser.analyzer [ tag-attributes "href" swap at ] map [ ] subset ; +: (find-all) ( n seq quot -- ) + 2dup >r >r find* [ + dupd 2array , 1+ r> r> (find-all) + ] [ + r> r> 3drop + ] if* ; +: find-all ( seq quot -- alist ) + [ 0 -rot (find-all) ] { } make ; -! : find-last-tag ( name vector -- index tag ) - ! [ - ! dup tag-matched? [ 2drop f ] [ tag-name = ] if - ! ] with find-last ; +: find-opening-tags-by-name ( name seq -- seq ) + [ [ tag-name = ] keep tag-closing? not and ] with find-all ; -! : find-last-tag* ( name n vector -- tag ) - ! 0 -rot find-last-tag ; +: href-contains? ( str tag -- ? ) + tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; -! : find-matching-tag ( tag -- tag ) - ! dup tag-closing? [ - ! find-last-tag - ! ] [ - ! ] if ; - - -! clear "/Users/erg/web/fark.html" file-contents parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map -! clear "/Users/erg/web/hostels.html" file-contents parse-html "Currency" "name" pick find-first-attribute-key-value - -! clear "/Users/erg/web/hostels.html" file-contents parse-html -! "Currency" "name" pick find-first-attribute-key-value -! pick find-between remove-blank-text From a345d4fc37e8142b2c91f14c1fdae2c2e5bb15a5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:32:36 -0600 Subject: [PATCH 10/16] delete a couple files in misc/Factor.tmbundle --- .../Commands/Eval Selection:Line.tmCommand | 27 ------------------- .../Run Selection:Line in Listener.tmCommand | 27 ------------------- 2 files changed, 54 deletions(-) delete mode 100644 misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand delete mode 100644 misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand diff --git a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand b/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand deleted file mode 100644 index 37867a2737..0000000000 --- a/misc/Factor.tmbundle/Commands/Eval Selection:Line.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -puts factor_eval(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^E - name - Eval Selection/Line - output - replaceSelectedText - scope - source.factor - uuid - 8E01DDAF-959B-4237-ADB9-C133A4ACCE90 - - diff --git a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand b/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand deleted file mode 100644 index 5028bd8db3..0000000000 --- a/misc/Factor.tmbundle/Commands/Run Selection:Line in Listener.tmCommand +++ /dev/null @@ -1,27 +0,0 @@ - - - - - beforeRunningCommand - nop - command - #!/usr/bin/env ruby - -require "#{ENV["TM_BUNDLE_SUPPORT"]}/lib/tm_factor" -factor_run(STDIN.read) - fallbackInput - line - input - selection - keyEquivalent - ^~e - name - Run Selection/Line in Listener - output - discard - scope - source.factor - uuid - 15A984BD-BC65-43E8-878A-267788C8DA70 - - From d976b114455c819363ffd9c7b350a9757aca40cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:44:13 -0600 Subject: [PATCH 11/16] Fix multiple reload issue --- core/vocabs/loader/loader.factor | 32 +++++++++++++++++++++++++++----- 1 file changed, 27 insertions(+), 5 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 50ae55f506..8e548b3043 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -160,13 +160,18 @@ SYMBOL: load-help? : load-failures. ( failures -- ) [ load-error. nl ] each ; +SYMBOL: blacklist + : require-all ( vocabs -- failures ) [ + V{ } clone blacklist set [ [ [ require ] - [ error-continuation get 3array , ] - recover + [ + over vocab-name blacklist get push + error-continuation get 3array , + ] recover ] each ] { } make ] with-compiler-errors ; @@ -182,7 +187,7 @@ SYMBOL: load-help? : refresh-all ( -- ) "" refresh ; GENERIC: (load-vocab) ( name -- vocab ) - +! M: vocab (load-vocab) dup vocab-root [ dup vocab-source-loaded? [ dup load-source ] unless @@ -195,8 +200,25 @@ M: string (load-vocab) M: vocab-link (load-vocab) vocab-name (load-vocab) ; -[ [ dup vocab [ ] [ ] ?if (load-vocab) ] with-compiler-errors ] -load-vocab-hook set-global +TUPLE: blacklisted-vocab name ; +! +: blacklisted-vocab ( name -- * ) + \ blacklisted-vocab construct-boa throw ; + +M: blacklisted-vocab error. + "This vocabulary depends on the " write + blacklisted-vocab-name write + " vocabulary which failed to load" print ; + +[ + dup vocab-name blacklist get member? [ + vocab-name blacklisted-vocab + ] [ + [ + dup vocab [ ] [ ] ?if (load-vocab) + ] with-compiler-errors + ] if +] load-vocab-hook set-global : vocab-where ( vocab -- loc ) vocab-source-path dup [ 1 2array ] when ; From 008da8a6baf32758726e55d4217008c1514b5e7b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 16:45:38 -0600 Subject: [PATCH 12/16] cleanup on aisle DECIMAL: --- extra/money/money.factor | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/extra/money/money.factor b/extra/money/money.factor index d742a3be5a..4058ee9e6a 100644 --- a/extra/money/money.factor +++ b/extra/money/money.factor @@ -12,18 +12,21 @@ IN: money "$" % swap number>string 3 group "," join % - "." % number>string 2 48 pad-left % + "." % number>string 2 CHAR: 0 pad-left % ] "" make print ; TUPLE: not-a-decimal ; -: DECIMAL: - scan - "." split dup length 1 2 between? [ - T{ not-a-decimal } throw - ] unless - ?first2 - >r dup ?first CHAR: - = [ drop t "0" ] [ f swap ] if r> + +: not-a-decimal ( -- * ) + T{ not-a-decimal } throw ; + +: parse-decimal ( str -- ratio ) + "." split1 + >r dup "-" head? [ drop t "0" ] [ f swap ] if r> [ dup empty? [ drop "0" ] when ] 2apply dup length - >r [ string>number dup [ T{ not-a-decimal } throw ] unless ] 2apply r> - 10 swap ^ / + swap [ neg ] when parsed ; parsing + >r [ string>number dup [ not-a-decimal ] unless ] 2apply r> + 10 swap ^ / + swap [ neg ] when ; + +: DECIMAL: + scan parse-decimal parsed ; parsing From a6ba0cb392217eb0a0fafbb76ab9308f72b6858f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:47:35 -0600 Subject: [PATCH 13/16] Clean up code a bit --- core/vocabs/loader/loader.factor | 18 +++++++----------- 1 file changed, 7 insertions(+), 11 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 8e548b3043..5e8a5630b2 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -155,7 +155,6 @@ SYMBOL: load-help? dup first vocab-heading. dup second print-error drop ; - ! third "Traceback" swap write-object ; : load-failures. ( failures -- ) [ load-error. nl ] each ; @@ -166,14 +165,11 @@ SYMBOL: blacklist [ V{ } clone blacklist set [ - [ - [ require ] - [ - over vocab-name blacklist get push - error-continuation get 3array , - ] recover - ] each - ] { } make + [ require ] + [ >r vocab-name r> 2array blacklist get push ] + recover + ] each + blacklist get ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) @@ -201,7 +197,7 @@ M: vocab-link (load-vocab) vocab-name (load-vocab) ; TUPLE: blacklisted-vocab name ; -! + : blacklisted-vocab ( name -- * ) \ blacklisted-vocab construct-boa throw ; @@ -211,7 +207,7 @@ M: blacklisted-vocab error. " vocabulary which failed to load" print ; [ - dup vocab-name blacklist get member? [ + dup vocab-name blacklist get key? [ vocab-name blacklisted-vocab ] [ [ From 41c85c7edc56d49aa11a04f7dd2891cd4e7085b3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 11 Feb 2008 16:56:48 -0600 Subject: [PATCH 14/16] Structure alignment fixes --- core/cpu/ppc/ppc.factor | 4 ++++ core/cpu/x86/32/32.factor | 6 +++--- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/core/cpu/ppc/ppc.factor b/core/cpu/ppc/ppc.factor index 901b339d7e..75de49acda 100755 --- a/core/cpu/ppc/ppc.factor +++ b/core/cpu/ppc/ppc.factor @@ -13,3 +13,7 @@ namespaces alien.c-types kernel system combinators ; } cond T{ ppc-backend } compiler-backend set-global + +macosx? [ + 4 "double" c-type set-c-type-align +] when diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 4ed186d769..ecae55e69a 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,9 +261,9 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless -macosx? [ - cell "double" c-type set-c-type-align -] when +windows? [ + 4 "double" c-type set-c-type-align +] unless T{ x86-backend f 4 } compiler-backend set-global From 3b6e6a1e1395497b4264be2c194c3f0f100fa155 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 17:19:27 -0600 Subject: [PATCH 15/16] add query>hash* to html.parser.analyzer --- extra/html/parser/analyzer/analyzer.factor | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index dcfbd1e197..fca15d9b07 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,5 +1,6 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces ; +arrays shuffle unicode.case namespaces splitting +http.server.responders ; IN: html.parser.analyzer : remove-blank-text ( vector -- vector' ) @@ -81,5 +82,14 @@ IN: html.parser.analyzer : href-contains? ( str tag -- ? ) tag-attributes "href" swap at* [ subseq? ] [ 2drop f ] if ; +: query>hash* ( str -- hash ) + "?" split1 nip query>hash ; + ! clear "http://fark.com" http-get parse-html find-links [ "go.pl" swap start ] subset [ "=" split peek ] map +! clear "http://www.sailwx.info/shiptrack/cruiseships.phtml" http-get parse-html remove-blank-text +! "a" over find-opening-tags-by-name +! [ nip "shipposition.phtml?call=GBTT" swap href-contains? ] assoc-subset +! first first 8 + over nth +! tag-attributes "href" swap at query>hash* +! "lat" over at "lon" rot at From 0b9d1c5141cd666e74f8328b0e9c4e311b13bc62 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 11 Feb 2008 18:11:29 -0600 Subject: [PATCH 16/16] add total collector to taxes --- extra/taxes/taxes.factor | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 0f51d7ab6a..2c5501c357 100644 --- a/extra/taxes/taxes.factor +++ b/extra/taxes/taxes.factor @@ -105,11 +105,6 @@ M: federal withholding ( salary w4 tax-table -- x ) M: federal net ( salary w4 collector -- x ) >r dupd r> withholding - ; -M: collector net ( salary w4 collector -- x ) - >r dupd r> - [ withholding ] 3keep - drop withholding + - ; - ! Minnesota : minnesota-single ( -- triples ) @@ -138,3 +133,15 @@ M: minnesota adjust-allowances ( salary w4 collector -- newsalary ) M: minnesota withholding ( salary w4 collector -- x ) [ adjust-allowances ] 2keep marriage-table tax ; + +TUPLE: total ; +INSTANCE: total collector + +! Totals +M: total net ( salary w4 collector -- x ) + >r dupd r> + [ withholding ] 3keep + drop withholding + - ; + +M: total withholding ( salary w4 collector -- x ) + >r >r dup r> r> net - ;