From 80782f699a73bd5a07175aa229a7b4dc26d116b6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 7 Jan 2009 13:38:34 -0600 Subject: [PATCH 01/56] fix a couple more typos in grouping --- basis/grouping/grouping-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor index 1eff4820dd..b9af98d1f8 100644 --- a/basis/grouping/grouping-docs.factor +++ b/basis/grouping/grouping-docs.factor @@ -49,7 +49,7 @@ HELP: } { $example "USING: kernel prettyprint sequences grouping ;" - "{ 1 2 3 4 5 6 } 3 0 swap nth ." + "{ 1 2 3 4 5 6 } 3 first ." "{ 1 2 3 }" } } ; @@ -66,7 +66,7 @@ HELP: } { $example "USING: kernel prettyprint sequences grouping ;" - "{ 1 2 3 4 5 6 } 3 1 swap nth ." + "{ 1 2 3 4 5 6 } 3 second ." "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }" } } ; From 638f1f4cebdd9fb53b684e5586004c75a4919aa3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 7 Jan 2009 14:53:43 -0600 Subject: [PATCH 02/56] fix group-name word, rename username -> user-name because of symmetry with group-name, use cleave>array in a couple places to eliminate counting items in an array manually --- basis/tools/files/files.factor | 2 ++ basis/tools/files/unix/unix.factor | 13 ++++++----- basis/unix/groups/groups.factor | 2 +- basis/unix/users/users-docs.factor | 34 ++++++++++++++--------------- basis/unix/users/users-tests.factor | 10 ++++----- basis/unix/users/users.factor | 16 +++++++------- 6 files changed, 41 insertions(+), 36 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 3670891e41..e6ca02d5f9 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -5,6 +5,8 @@ io.directories kernel math.parser sequences system vocabs.loader calendar math fry prettyprint ; IN: tools.files +SYMBOLS: permissions file-name nlinks file-size date ; + array ( array -- quot ) + dup length '[ _ cleave _ narray ] ; + string ( str bools -- str' ) @@ -28,7 +31,7 @@ IN: tools.files.unix [ other-read? read>string ] [ other-write? write>string ] [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] - } cleave 10 narray concat ; + } cleave>array concat ; : mode>symbol ( mode -- ch ) S_IFMT bitand @@ -49,11 +52,11 @@ M: unix (directory.) ( path -- lines ) { [ permissions-string ] [ nlink>> number>string 3 CHAR: \s pad-left ] - ! [ uid>> ] - ! [ gid>> ] + [ uid>> user-name ] + [ gid>> group-name ] [ size>> number>string 15 CHAR: \s pad-left ] [ modified>> ls-timestamp ] - } cleave 4 narray swap suffix " " join + } cleave>array swap suffix " " join ] map ] with-group-cache ] with-user-cache ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 60785a5b17..41cd80f456 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -43,7 +43,7 @@ PRIVATE> : group-name ( id -- string ) dup group-cache get [ - at + dupd at* [ name>> nip ] [ drop number>string ] if ] [ group-struct group-gr_name ] if* diff --git a/basis/unix/users/users-docs.factor b/basis/unix/users/users-docs.factor index 0740561cc1..2d46ab2d81 100644 --- a/basis/unix/users/users-docs.factor +++ b/basis/unix/users/users-docs.factor @@ -7,13 +7,13 @@ HELP: all-users { $values { "seq" sequence } } { $description "Returns a sequence of high-level " { $link passwd } " tuples that are platform-dependent and field for field complete with the Unix " { $link passwd } " structure." } ; -HELP: effective-username +HELP: effective-user-name { $values { "string" string } } -{ $description "Returns the effective username for the current user." } ; +{ $description "Returns the effective user-name for the current user." } ; HELP: effective-user-id { $values { "id" integer } } -{ $description "Returns the effective username id for the current user." } ; +{ $description "Returns the effective user-name id for the current user." } ; HELP: new-passwd { $values { "passwd" passwd } } @@ -31,9 +31,9 @@ HELP: passwd>new-passwd { "new-passwd" "a passwd tuple" } } { $description "A platform-specific conversion routine from a passwd structure to a passwd tuple." } ; -HELP: real-username +HELP: real-user-name { $values { "string" string } } -{ $description "The real username of the current user." } ; +{ $description "The real user-name of the current user." } ; HELP: real-user-id { $values { "id" integer } } @@ -41,34 +41,34 @@ HELP: real-user-id HELP: set-effective-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current effective user given a username or a user id." } ; +{ $description "Sets the current effective user given a user-name or a user id." } ; HELP: set-real-user { $values { "string/id" "a string or a user id" } } -{ $description "Sets the current real user given a username or a user id." } ; +{ $description "Sets the current real user given a user-name or a user id." } ; HELP: user-passwd { $values { "obj" object } { "passwd/f" "passwd or f" } } -{ $description "Returns the passwd tuple given a username string or user id." } ; +{ $description "Returns the passwd tuple given a user-name string or user id." } ; -HELP: username +HELP: user-name { $values { "id" integer } { "string" string } } -{ $description "Returns the username associated with the user id." } ; +{ $description "Returns the user-name associated with the user id." } ; HELP: user-id { $values { "string" string } { "id" integer } } -{ $description "Returns the user id associated with the username." } ; +{ $description "Returns the user id associated with the user-name." } ; HELP: with-effective-user { $values { "string/id" "a string or a uid" } { "quot" quotation } } -{ $description "Sets the effective username and calls the quotation. Restores the current username on success or on error after the call." } ; +{ $description "Sets the effective user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ; HELP: with-user-cache { $values @@ -78,11 +78,11 @@ HELP: with-user-cache HELP: with-real-user { $values { "string/id" "a string or a uid" } { "quot" quotation } } -{ $description "Sets the real username and calls the quotation. Restores the current username on success or on error after the call." } ; +{ $description "Sets the real user-name and calls the quotation. Restores the current user-name on success or on error after the call." } ; { - real-username real-user-id set-real-user - effective-username effective-user-id + real-user-name real-user-id set-real-user + effective-user-name effective-user-id set-effective-user } related-words @@ -93,11 +93,11 @@ $nl { $subsection all-users } "Returning a passwd tuple:" "Real user:" -{ $subsection real-username } +{ $subsection real-user-name } { $subsection real-user-id } { $subsection set-real-user } "Effective user:" -{ $subsection effective-username } +{ $subsection effective-user-name } { $subsection effective-user-id } { $subsection set-effective-user } "Combinators to change users:" diff --git a/basis/unix/users/users-tests.factor b/basis/unix/users/users-tests.factor index 5a4639c856..f2a4b7bc27 100644 --- a/basis/unix/users/users-tests.factor +++ b/basis/unix/users/users-tests.factor @@ -8,8 +8,8 @@ IN: unix.users.tests \ all-users must-infer -[ t ] [ real-username string? ] unit-test -[ t ] [ effective-username string? ] unit-test +[ t ] [ real-user-name string? ] unit-test +[ t ] [ effective-user-name string? ] unit-test [ t ] [ real-user-id integer? ] unit-test [ t ] [ effective-user-id integer? ] unit-test @@ -17,14 +17,14 @@ IN: unix.users.tests [ ] [ real-user-id set-real-user ] unit-test [ ] [ effective-user-id set-effective-user ] unit-test -[ ] [ real-username [ ] with-real-user ] unit-test +[ ] [ real-user-name [ ] with-real-user ] unit-test [ ] [ real-user-id [ ] with-real-user ] unit-test -[ ] [ effective-username [ ] with-effective-user ] unit-test +[ ] [ effective-user-name [ ] with-effective-user ] unit-test [ ] [ effective-user-id [ ] with-effective-user ] unit-test [ ] [ [ ] with-user-cache ] unit-test -[ "9999999999999999999" ] [ 9999999999999999999 username ] unit-test +[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test [ f ] [ 89898989898989898989898989898 user-passwd ] unit-test diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index 21538080c9..da38972955 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -7,7 +7,7 @@ accessors math.parser fry assocs namespaces continuations vocabs.loader system ; IN: unix.users -TUPLE: passwd username password uid gid gecos dir shell ; +TUPLE: passwd user-name password uid gid gecos dir shell ; HOOK: new-passwd os ( -- passwd ) HOOK: passwd>new-passwd os ( passwd -- new-passwd ) @@ -20,7 +20,7 @@ M: unix new-passwd ( -- passwd ) M: unix passwd>new-passwd ( passwd -- seq ) [ new-passwd ] dip { - [ passwd-pw_name >>username ] + [ passwd-pw_name >>user-name ] [ passwd-pw_passwd >>password ] [ passwd-pw_uid >>uid ] [ passwd-pw_gid >>gid ] @@ -56,9 +56,9 @@ M: integer user-passwd ( id -- passwd/f ) M: string user-passwd ( string -- passwd/f ) getpwnam dup [ passwd>new-passwd ] when ; -: username ( id -- string ) +: user-name ( id -- string ) dup user-passwd - [ nip username>> ] [ number>string ] if* ; + [ nip user-name>> ] [ number>string ] if* ; : user-id ( string -- id ) user-passwd uid>> ; @@ -66,14 +66,14 @@ M: string user-passwd ( string -- passwd/f ) : real-user-id ( -- id ) getuid ; inline -: real-username ( -- string ) - real-user-id username ; inline +: real-user-name ( -- string ) + real-user-id user-name ; inline : effective-user-id ( -- id ) geteuid ; inline -: effective-username ( -- string ) - effective-user-id username ; inline +: effective-user-name ( -- string ) + effective-user-id user-name ; inline GENERIC: set-real-user ( string/id -- ) From 6d6e6910838a8a9e1a61d257a180ad2f353228d2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 7 Jan 2009 15:58:33 -0600 Subject: [PATCH 03/56] Make human-sort behave like sort --- basis/sorting/human/human.factor | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index 1c2ba419c7..f338e21887 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -1,10 +1,20 @@ ! Copyright (C) 2008 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: peg.ebnf math.parser kernel assocs sorting ; +USING: peg.ebnf math.parser kernel assocs sorting fry +math.order sequences ascii splitting.monotonic ; IN: sorting.human : find-numbers ( string -- seq ) [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ; -: human-sort ( seq -- seq' ) - [ dup find-numbers ] { } map>assoc sort-values keys ; +: human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ; + +: human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ; + +: human-sort ( seq -- seq' ) [ human-<=> ] sort ; + +: human-sort-keys ( seq -- sortedseq ) + [ [ first ] human-compare ] sort ; + +: human-sort-values ( seq -- sortedseq ) + [ [ second ] human-compare ] sort ; From d3220a607f53b2507177c3f6d0b6493476a111c7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 7 Jan 2009 16:04:42 -0600 Subject: [PATCH 04/56] add unit test for group-name --- basis/unix/groups/groups-tests.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 7e7ebd902a..a1b5e6973f 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -3,7 +3,6 @@ USING: tools.test unix.groups kernel strings math ; IN: unix.groups.tests - [ ] [ all-groups drop ] unit-test \ all-groups must-infer @@ -24,3 +23,5 @@ IN: unix.groups.tests [ ] [ effective-group-id [ ] with-effective-group ] unit-test [ ] [ [ ] with-group-cache ] unit-test + +[ ] [ real-group-id group-name drop ] unit-test From 3026f1c8e3f91979ba659f92dfa69e4cdb635684 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 7 Jan 2009 16:05:48 -0600 Subject: [PATCH 05/56] add another test for group-name --- basis/unix/groups/groups-tests.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index a1b5e6973f..75f5d64b5f 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -25,3 +25,5 @@ IN: unix.groups.tests [ ] [ [ ] with-group-cache ] unit-test [ ] [ real-group-id group-name drop ] unit-test + +[ "888888888888888" ] [ 888888888888888 group-name ] unit-test From 1aa0684d4580d5caece99e0d0b38dc5ee2629485 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 7 Jan 2009 23:54:19 -0600 Subject: [PATCH 06/56] Case conversion title case fixed --- basis/unicode/breaks/breaks.factor | 13 +++---- basis/unicode/case/case-tests.factor | 2 +- basis/unicode/case/case.factor | 35 +++++++++++-------- .../unicode/collation/collation-tests.factor | 4 +-- basis/unicode/normalize/normalize.factor | 6 ++-- 5 files changed, 31 insertions(+), 29 deletions(-) diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index b85e8879e1..1d2f821750 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -3,7 +3,7 @@ USING: combinators.short-circuit unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces make math.ranges unicode.normalize.private values -io.encodings.ascii unicode.syntax unicode.data compiler.units +io.encodings.ascii unicode.syntax unicode.data compiler.units fry alien.syntax sets accessors interval-maps memoize locals words ; IN: unicode.breaks @@ -111,14 +111,9 @@ PRIVATE> pieces) ( str quot -- ) - str [ - dup quot call cut-slice - swap , quot (>pieces) - ] unless-empty ; inline recursive - -: >pieces ( str quot -- graphemes ) - [ (>pieces) ] { } make ; inline +: >pieces ( str quot: ( str -- i ) -- graphemes ) + [ dup empty? not ] swap '[ dup @ cut-slice swap ] + [ ] produce nip ; inline PRIVATE> diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 0083e49672..f9d304e05c 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -4,7 +4,7 @@ USING: unicode.case tools.test namespaces ; \ >lower must-infer \ >title must-infer -[ "Hello How Are You? I'M Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test +[ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test [ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 7e61831f36..5d103e2dd0 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: unicode.data sequences sequences.next namespaces make unicode.normalize math unicode.categories combinators -assocs strings splitting kernel accessors ; +assocs strings splitting kernel accessors unicode.breaks ; IN: unicode.case -: >lower ( string -- lower ) - i-dot? [ turk>lower ] when - final-sigma [ lower>> ] [ ch>lower ] map-case ; -: >upper ( string -- upper ) - i-dot? [ turk>upper ] when +: (>lower) ( string -- lower ) + [ lower>> ] [ ch>lower ] map-case ; + +: (>title) ( string -- title ) + [ title>> ] [ ch>title ] map-case ; + +: (>upper) ( string -- upper ) [ upper>> ] [ ch>upper ] map-case ; +: title-word ( string -- title ) + unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ; + +PRIVATE> + +: >lower ( string -- lower ) + i-dot? [ turk>lower ] when + final-sigma (>lower) ; + +: >upper ( string -- upper ) + i-dot? [ turk>upper ] when (>upper) ; + : >title ( string -- title ) - final-sigma - CHAR: \s swap - [ tuck word-boundary swapd - [ title>> ] [ lower>> ] if ] - [ tuck word-boundary swapd - [ ch>title ] [ ch>lower ] if ] - map-case nip ; + final-sigma >words [ title-word ] map concat ; : >case-fold ( string -- fold ) >upper >lower ; diff --git a/basis/unicode/collation/collation-tests.factor b/basis/unicode/collation/collation-tests.factor index be6af2d920..d3d0b8199d 100644 --- a/basis/unicode/collation/collation-tests.factor +++ b/basis/unicode/collation/collation-tests.factor @@ -1,6 +1,6 @@ USING: io io.files splitting grouping unicode.collation sequences kernel io.encodings.utf8 math.parser math.order -tools.test assocs io.streams.null words ; +tools.test assocs words ; IN: unicode.collation.tests : parse-test ( -- strings ) @@ -25,4 +25,4 @@ IN: unicode.collation.tests unit-test parse-test 2 -[ [ test-two ] assoc-each ] with-null-writer +[ test-two ] assoc-each diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index f13eb07594..58ce412a2e 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -155,7 +155,7 @@ DEFER: compose-iter ] if (compose) ] when* ; -: compose ( str -- comp ) +: combine ( str -- comp ) [ main-str set 0 ind set @@ -166,7 +166,7 @@ DEFER: compose-iter PRIVATE> : nfc ( string -- nfc ) - nfd compose ; + nfd combine ; : nfkc ( string -- nfkc ) - nfkd compose ; + nfkd combine ; From 3b44c824ee8cd98955825bbc01ccb4bd4715d102 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 8 Jan 2009 17:00:48 +0100 Subject: [PATCH 07/56] FUEL: Better word extraction. --- misc/fuel/README | 3 ++- misc/fuel/fuel-mode.el | 3 ++- misc/fuel/fuel-refactor.el | 37 +++++++++++++++++++++++++------------ 3 files changed, 29 insertions(+), 14 deletions(-) diff --git a/misc/fuel/README b/misc/fuel/README index f5d366a22e..4747adb4a0 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -74,7 +74,8 @@ beast. - C-cM-<, C-cC-d< : show callers of word at point - C-cM->, C-cC-d> : show callees of word at point - - C-cC-xw : extract region as a separate word + - C-cC-xs : extract innermost sexp (up to point) as a separate word + - C-cC-xr : extract region as a separate word *** In the listener: diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index c1abcf414b..467270651a 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -225,7 +225,8 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?e ?w 'fuel-edit-word) (fuel-mode--key ?e ?x 'fuel-eval-definition) -(fuel-mode--key ?x ?w 'fuel-refactor-extract-word) +(fuel-mode--key ?x ?s 'fuel-refactor-extract-sexp) +(fuel-mode--key ?x ?r 'fuel-refactor-extract-region) (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index 547da19552..a414f17795 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -20,23 +20,13 @@ ;;; Extract word: -(defun fuel-refactor-extract-word (begin end) - "Extracts current region as a separate word." - (interactive "r") +(defun fuel-refactor--extract (begin end) (let* ((word (read-string "New word name: ")) - (begin (save-excursion - (goto-char begin) - (when (zerop (skip-syntax-backward "w")) - (skip-syntax-forward "-")) - (point))) - (end (save-excursion - (goto-char end) - (skip-syntax-forward "w") - (point))) (code (buffer-substring begin end)) (code-str (fuel--region-to-string begin end)) (stack-effect (or (fuel-stack--infer-effect code-str) (read-string "Stack effect: ")))) + (unless (< begin end) (error "No proper region to extract")) (goto-char begin) (delete-region begin end) (insert word) @@ -52,6 +42,29 @@ (sit-for fuel-stack-highlight-period) (delete-overlay fuel-stack--overlay)))) +(defun fuel-refactor-extract-region (begin end) + "Extracts current region as a separate word." + (interactive "r") + (let ((begin (save-excursion + (goto-char begin) + (when (zerop (skip-syntax-backward "w")) + (skip-syntax-forward "-")) + (point))) + (end (save-excursion + (goto-char end) + (skip-syntax-forward "w") + (point)))) + (fuel-refactor--extract begin end))) + +(defun fuel-refactor-extract-sexp () + "Extracts current innermost sexp (up to point) as a separate +word." + (interactive) + (fuel-refactor-extract-region (1+ (fuel-syntax--beginning-of-sexp-pos)) + (if (looking-at-p ";") (point) + (fuel-syntax--end-of-symbol-pos)))) + + (provide 'fuel-refactor) ;;; fuel-refactor.el ends here From c5f55dc36d1d1467358178223f4446d07dfb9a16 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 8 Jan 2009 18:47:17 +0100 Subject: [PATCH 08/56] FUEL: New command: fuel-show-file-words. --- extra/fuel/fuel.factor | 3 ++ misc/fuel/README | 1 + misc/fuel/fuel-mode.el | 32 +------------- misc/fuel/fuel-syntax.el | 11 +++-- misc/fuel/fuel-xref.el | 93 +++++++++++++++++++++++++++++++++------- 5 files changed, 89 insertions(+), 51 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index becbf2161a..50f02f1a1a 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -201,6 +201,9 @@ SYMBOL: :uses : fuel-apropos-xref ( str -- ) words-matching fuel-format-xrefs fuel-eval-set-result ; inline +: fuel-vocab-xref ( vocab -- ) + words fuel-format-xrefs fuel-eval-set-result ; inline + ! Completion support : fuel-filter-prefix ( seq prefix -- seq ) diff --git a/misc/fuel/README b/misc/fuel/README index 4747adb4a0..f722b18598 100644 --- a/misc/fuel/README +++ b/misc/fuel/README @@ -70,6 +70,7 @@ beast. - C-cC-ds : short help word at point - C-cC-de : show stack effect of current sexp (with prefix, region) - C-cC-dp : find words containing given substring (M-x fuel-apropos) + - C-cC-dv : show words in current file (with prefix, ask for vocab) - C-cM-<, C-cC-d< : show callers of word at point - C-cM->, C-cC-d> : show callees of word at point diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index 467270651a..f448e67d57 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -132,37 +132,6 @@ With prefix argument, ask for the file name." (let ((file (car (fuel-mode--read-file arg)))) (when file (fuel-debug--uses-for-file file)))) -(defvar fuel-mode--word-history nil) - -(defun fuel-show-callers (&optional arg) - "Show a list of callers of word at point. -With prefix argument, ask for word." - (interactive "P") - (let ((word (if arg (fuel-completion--read-word "Find callers for: " - (fuel-syntax-symbol-at-point) - fuel-mode--word-history) - (fuel-syntax-symbol-at-point)))) - (when word - (message "Looking up %s's callers ..." word) - (fuel-xref--show-callers word)))) - -(defun fuel-show-callees (&optional arg) - "Show a list of callers of word at point. -With prefix argument, ask for word." - (interactive "P") - (let ((word (if arg (fuel-completion--read-word "Find callees for: " - (fuel-syntax-symbol-at-point) - fuel-mode--word-history) - (fuel-syntax-symbol-at-point)))) - (when word - (message "Looking up %s's callees ..." word) - (fuel-xref--show-callees word)))) - -(defun fuel-apropos (str) - "Show a list of words containing the given substring." - (interactive "MFind words containing: ") - (message "Looking up %s's references ..." str) - (fuel-xref--apropos str)) ;;; Minor mode definition: @@ -230,6 +199,7 @@ interacting with a factor listener is at your disposal. (fuel-mode--key ?d ?> 'fuel-show-callees) (fuel-mode--key ?d ?< 'fuel-show-callers) +(fuel-mode--key ?d ?v 'fuel-show-file-words) (fuel-mode--key ?d ?a 'fuel-autodoc-mode) (fuel-mode--key ?d ?p 'fuel-apropos) (fuel-mode--key ?d ?d 'fuel-help) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 2c3de32d4f..e1981eff47 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -312,6 +312,12 @@ (defsubst fuel-syntax--usings () (funcall fuel-syntax--usings-function)) +(defun fuel-syntax--file-has-private () + (save-excursion + (goto-char (point-min)) + (and (re-search-forward "\\_<" nil t) + (re-search-forward "\\_\\_>" nil t)))) + (defun fuel-syntax--find-usings (&optional no-private) (save-excursion (let ((usings)) @@ -319,10 +325,7 @@ (while (re-search-backward fuel-syntax--using-lines-regex nil t) (dolist (u (split-string (match-string-no-properties 1) nil t)) (push u usings))) - (goto-char (point-min)) - (when (and (not no-private) - (re-search-forward "\\_<" nil t) - (re-search-forward "\\_\\_>" nil t)) + (when (and (not no-private) (fuel-syntax--file-has-private)) (goto-char (point-max)) (push (concat (fuel-syntax--find-in) ".private") usings)) usings))) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 470c2a8762..f754c626f7 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -13,6 +13,8 @@ ;;; Code: +(require 'fuel-edit) +(require 'fuel-completion) (require 'fuel-help) (require 'fuel-eval) (require 'fuel-syntax) @@ -82,7 +84,7 @@ cursor at the first ocurrence of the used word." ((= 1 count) (format "1 word %s %s:" cc word)) (t (format "%s words %s %s:" count cc word)))) -(defun fuel-xref--insert-ref (ref) +(defun fuel-xref--insert-ref (ref &optional no-vocab) (when (and (stringp (first ref)) (stringp (third ref)) (numberp (fourth ref))) @@ -94,29 +96,28 @@ cursor at the first ocurrence of the used word." (fourth ref)) 'file (third ref) 'line (fourth ref)) - (when (stringp (second ref)) + (when (and (not no-vocab) (stringp (second ref))) (insert (format " (in %s)" (second ref)))) (newline) t)) -(defun fuel-xref--fill-buffer (word cc refs) +(defun fuel-xref--fill-buffer (word cc refs &optional no-vocab app) (let ((inhibit-read-only t) (count 0)) (with-current-buffer (fuel-xref--buffer) - (erase-buffer) - (dolist (ref refs) - (when (fuel-xref--insert-ref ref) (setq count (1+ count)))) - (goto-char (point-min)) - (insert (fuel-xref--title word cc count) "\n\n") - (when (> count 0) - (setq fuel-xref--word (and cc word)) - (goto-char (point-max)) - (insert "\n" fuel-xref--help-string "\n")) - (goto-char (point-min)) - count))) + (let ((start (if app (goto-char (point-max)) + (erase-buffer) + (point-min)))) + (dolist (ref refs) + (when (fuel-xref--insert-ref ref no-vocab) (setq count (1+ count)))) + (newline) + (goto-char start) + (save-excursion + (insert (fuel-xref--title word cc count) "\n\n")) + count)))) -(defun fuel-xref--fill-and-display (word cc refs) - (let ((count (fuel-xref--fill-buffer word cc refs))) +(defun fuel-xref--fill-and-display (word cc refs &optional no-vocab) + (let ((count (fuel-xref--fill-buffer word cc refs no-vocab))) (if (zerop count) (error (fuel-xref--title word cc 0)) (message "") @@ -137,6 +138,65 @@ cursor at the first ocurrence of the used word." (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) (fuel-xref--fill-and-display str "containing" res))) +(defun fuel-xref--show-vocab (vocab &optional app) + (let* ((cmd `(:fuel* ((,vocab fuel-vocab-xref)) ,vocab)) + (res (fuel-eval--retort-result (fuel-eval--send/wait cmd)))) + (fuel-xref--fill-buffer vocab "in vocabulary" res t app))) + +(defun fuel-xref--show-vocab-words (vocab &optional private) + (fuel-xref--show-vocab vocab) + (when private + (fuel-xref--show-vocab (format "%s.private" (substring-no-properties vocab)) + t)) + (fuel-popup--display (fuel-xref--buffer)) + (goto-char (point-min))) + + +;;; User commands: + +(defvar fuel-xref--word-history nil) + +(defun fuel-show-callers (&optional arg) + "Show a list of callers of word at point. +With prefix argument, ask for word." + (interactive "P") + (let ((word (if arg (fuel-completion--read-word "Find callers for: " + (fuel-syntax-symbol-at-point) + fuel-xref--word-history) + (fuel-syntax-symbol-at-point)))) + (when word + (message "Looking up %s's callers ..." word) + (fuel-xref--show-callers word)))) + +(defun fuel-show-callees (&optional arg) + "Show a list of callers of word at point. +With prefix argument, ask for word." + (interactive "P") + (let ((word (if arg (fuel-completion--read-word "Find callees for: " + (fuel-syntax-symbol-at-point) + fuel-xref--word-history) + (fuel-syntax-symbol-at-point)))) + (when word + (message "Looking up %s's callees ..." word) + (fuel-xref--show-callees word)))) + +(defun fuel-apropos (str) + "Show a list of words containing the given substring." + (interactive "MFind words containing: ") + (message "Looking up %s's references ..." str) + (fuel-xref--apropos str)) + +(defun fuel-show-file-words (&optional arg) + "Show a list of words in current file. +With prefix argument, ask for the vocab." + (interactive "P") + (let ((vocab (or (and (not arg) (fuel-syntax--current-vocab)) + (fuel-edit--read-vocabulary-name)))) + (when vocab + (fuel-xref--show-vocab-words vocab + (fuel-syntax--file-has-private))))) + + ;;; Xref mode: @@ -159,6 +219,7 @@ cursor at the first ocurrence of the used word." (kill-all-local-variables) (buffer-disable-undo) (use-local-map fuel-xref-mode-map) + (set-syntax-table fuel-syntax--syntax-table) (setq mode-name "FUEL Xref") (setq major-mode 'fuel-xref-mode) (font-lock-add-keywords nil '(("(in \\(.+\\))" 1 'fuel-font-lock-xref-vocab))) From 4f4198d85040ae4c16002489074aaa49d4c52478 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 15:00:59 -0600 Subject: [PATCH 09/56] Cleaning up case conversion (still need Lithuanian tests) --- basis/unicode/case/case-tests.factor | 4 +- basis/unicode/case/case.factor | 105 ++++++++++++++------------- 2 files changed, 55 insertions(+), 54 deletions(-) diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index f9d304e05c..6e26a36a19 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -6,12 +6,12 @@ USING: unicode.case tools.test namespaces ; [ "Hello How Are You? I'm Good" ] [ "hEllo how ARE yOU? I'm good" >title ] unit-test [ "FUSS" ] [ "Fu\u0000DF" >upper ] unit-test -[ "\u0003C3\u0003C2" ] [ "\u0003A3\u0003A3" >lower ] unit-test +[ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test [ "tr" locale set [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test -! [ "I\u00307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test + [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test "lt" locale set ! Lithuanian casing tests diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 5d103e2dd0..b0472cd9cb 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: unicode.data sequences sequences.next namespaces make -unicode.normalize math unicode.categories combinators -assocs strings splitting kernel accessors unicode.breaks ; +unicode.normalize math unicode.categories combinators unicode.syntax +assocs strings splitting kernel accessors unicode.breaks fry ; IN: unicode.case SYMBOL: locale ! Just casing locale, or overall? upper ( ? next ch -- ? ) - rot [ 2drop f ] - [ swap dot-over = over "ij" member? and swap , ] if ; - : lithuanian>upper ( string -- lower ) - [ f swap [ lithuanian-ch>upper ] each-next drop ] "" make ; + "i\u000307" "i" replace + "j\u000307" "j" replace ; : mark-above? ( ch -- ? ) combining-class 230 = ; -: lithuanian-ch>lower ( next ch -- ) - ! This fails to add a dot above in certain edge cases - ! where there is a non-above combining mark before an above one - ! in Lithuanian - dup , "IJ" member? swap mark-above? and [ dot-over , ] when ; +: with-rest ( seq quot: ( seq -- seq ) -- seq ) + [ unclip ] dip swap slip prefix ; inline + +: add-dots ( seq -- seq ) + [ [ "" ] [ + dup first mark-above? + [ CHAR: combining-dot-above prefix ] when + ] if-empty ] with-rest ; : lithuanian>lower ( string -- lower ) - [ [ lithuanian-ch>lower ] each-next ] "" make ; - -: turk-ch>upper ( ch -- ) - dup CHAR: i = - [ drop CHAR: I , dot-over , ] [ , ] if ; + "i" split add-dots "i" join + "j" split add-dots "i" join ; : turk>upper ( string -- upper-i ) - [ [ turk-ch>upper ] each ] "" make ; - -: turk-ch>lower ( ? next ch -- ? ) - { - { [ rot ] [ 2drop f ] } - { [ dup CHAR: I = ] [ - drop dot-over = - dup CHAR: i HEX: 131 ? , - ] } - [ , drop f ] - } cond ; + "i" "I\u000307" replace ; : turk>lower ( string -- lower-i ) - [ f swap [ turk-ch>lower ] each-next drop ] "" make ; + "I\u000307" "i" replace + "I" "\u000131" replace ; -: word-boundary ( prev char -- new ? ) - dup non-starter? [ drop dup ] when - swap uncased? ; +: fix-sigma-end ( string -- string ) + [ "" ] [ + dup peek CHAR: greek-small-letter-sigma = + [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when + ] if-empty ; : sigma-map ( string -- string ) - [ - swap [ uncased? ] keep not or - [ drop HEX: 3C2 ] when - ] map-next ; + { CHAR: greek-capital-letter-sigma } split [ [ + [ { CHAR: greek-small-letter-sigma } ] [ + dup first uncased? + CHAR: greek-small-letter-final-sigma + CHAR: greek-small-letter-sigma ? prefix + ] if-empty + ] map ] with-rest concat fix-sigma-end ; : final-sigma ( string -- string ) - HEX: 3A3 over member? [ sigma-map ] when ; + CHAR: greek-capital-letter-sigma + over member? [ sigma-map ] when ; : map-case ( string string-quot char-quot -- case ) [ @@ -83,26 +84,26 @@ SYMBOL: locale ! Just casing locale, or overall? ] 2curry each ] "" make ; inline -: (>lower) ( string -- lower ) - [ lower>> ] [ ch>lower ] map-case ; - -: (>title) ( string -- title ) - [ title>> ] [ ch>title ] map-case ; - -: (>upper) ( string -- upper ) - [ upper>> ] [ ch>upper ] map-case ; - -: title-word ( string -- title ) - unclip 1string [ (>lower) ] [ (>title) ] bi* prepend ; - PRIVATE> : >lower ( string -- lower ) - i-dot? [ turk>lower ] when - final-sigma (>lower) ; + i-dot? [ turk>lower ] when final-sigma + [ lower>> ] [ ch>lower ] map-case ; : >upper ( string -- upper ) - i-dot? [ turk>upper ] when (>upper) ; + i-dot? [ turk>upper ] when + [ upper>> ] [ ch>upper ] map-case ; + +title) ( string -- title ) + i-dot? [ turk>upper ] when + [ title>> ] [ ch>title ] map-case ; + +: title-word ( string -- title ) + unclip 1string [ >lower ] [ (>title) ] bi* prepend ; + +PRIVATE> : >title ( string -- title ) final-sigma >words [ title-word ] map concat ; From e927d844045e00d34f48aa5dbd279c403da8c7e1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 15:38:03 -0600 Subject: [PATCH 10/56] Fixing doc errors --- basis/unicode/case/case-docs.factor | 2 +- .../unicode/categories/categories-docs.factor | 72 ++++++++----------- basis/unicode/data/data-docs.factor | 18 ++--- basis/unicode/data/data.factor | 4 +- basis/unicode/normalize/normalize-docs.factor | 2 +- 5 files changed, 44 insertions(+), 54 deletions(-) diff --git a/basis/unicode/case/case-docs.factor b/basis/unicode/case/case-docs.factor index 86b791ed81..da582c659a 100644 --- a/basis/unicode/case/case-docs.factor +++ b/basis/unicode/case/case-docs.factor @@ -35,7 +35,7 @@ HELP: >title { $description "Converts a string to title case." } ; HELP: >case-fold -{ $values { "string" string } { "case-fold" string } } +{ $values { "string" string } { "fold" string } } { $description "Converts a string to case-folded form." } ; HELP: upper? diff --git a/basis/unicode/categories/categories-docs.factor b/basis/unicode/categories/categories-docs.factor index 421fa90dd2..a7fe8d1e02 100644 --- a/basis/unicode/categories/categories-docs.factor +++ b/basis/unicode/categories/categories-docs.factor @@ -3,57 +3,47 @@ USING: help.markup help.syntax kernel ; IN: unicode.categories -HELP: LETTER? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether the code point is an upper-cased letter" } ; +HELP: LETTER +{ $class-description "The class of upper cased letters" } ; -HELP: Letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether the code point is a letter of any case" } ; +HELP: Letter +{ $class-description "The class of letters" } ; -HELP: alpha? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether the code point is alphanumeric" } ; +HELP: alpha +{ $class-description "The class of code points which are alphanumeric" } ; -HELP: blank? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether the code point is whitespace" } ; +HELP: blank +{ $class-description "The class of code points which are whitespace" } ; -HELP: character? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a number is a code point which has been assigned" } ; +HELP: character +{ $class-description "The class of numbers which are pre-defined Unicode code points" } ; -HELP: control? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a code point is a control character" } ; +HELP: control +{ $class-description "The class of control characters" } ; -HELP: digit? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a code point is a digit" } ; +HELP: digit +{ $class-description "The class of code coints which are digits" } ; -HELP: letter? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a code point is a lower-cased letter" } ; +HELP: letter +{ $class-description "The class of code points which are lower-cased letters" } ; -HELP: printable? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a code point is printable, as opposed to being a control character or formatting character" } ; +HELP: printable +{ $class-description "The class of characters which are printable, as opposed to being control or formatting characters" } ; -HELP: uncased? -{ $values { "ch" "a character" } { "?" "a boolean" } } -{ $description "Determines whether a character has a case" } ; +HELP: uncased +{ $class-description "The class of letters which don't have a case" } ; ARTICLE: "unicode.categories" "Character classes" -{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ASCII" "ascii" } " equivalents in most cases. Below are links to the useful predicates, but note that each of these is defined to be a predicate class." -{ $subsection blank? } -{ $subsection letter? } -{ $subsection LETTER? } -{ $subsection Letter? } -{ $subsection digit? } -{ $subsection printable? } -{ $subsection alpha? } -{ $subsection control? } -{ $subsection uncased? } -{ $subsection character? } ; +{ $vocab-link "unicode.categories" } " is a vocabulary which provides predicates for determining if a code point has a particular property, for example being a lower cased letter. These should be used in preference to the " { $vocab-link "ascii" } " equivalents in most cases. Below are links to classes of characters, but note that each of these also has a predicate defined, which is usually more useful." +{ $subsection blank } +{ $subsection letter } +{ $subsection LETTER } +{ $subsection Letter } +{ $subsection digit } +{ $subsection printable } +{ $subsection alpha } +{ $subsection control } +{ $subsection uncased } +{ $subsection character } ; ABOUT: "unicode.categories" diff --git a/basis/unicode/data/data-docs.factor b/basis/unicode/data/data-docs.factor index a918728285..55fed31386 100644 --- a/basis/unicode/data/data-docs.factor +++ b/basis/unicode/data/data-docs.factor @@ -15,37 +15,37 @@ ARTICLE: "unicode.data" "Unicode data tables" { $subsection property? } ; HELP: load-script -{ $value { "filename" string } { "table" "an interval map" } } +{ $values { "filename" string } { "table" "an interval map" } } { $description "This loads a file that looks like Script.txt in the Unicode Character Database and converts it into an efficient interval map, where the keys are characters and the values are strings for the properties." } ; HELP: canonical-entry -{ $value { "char" "a code point" } { "seq" string } } +{ $values { "char" "a code point" } { "seq" string } } { $description "Finds the canonical decomposition (NFD) for a code point" } ; HELP: combine-chars -{ $value { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } } +{ $values { "a" "a code point" } { "b" "a code point" } { "char/f" "a code point" } } { $description "If a followed by b can be combined in NFC, this returns the code point of their combination." } ; HELP: compatibility-entry -{ $value { "char" "a code point" } { "seq" string } } +{ $values { "char" "a code point" } { "seq" string } } { $description "This returns the compatibility decomposition (NFKD) for a code point" } ; HELP: combining-class -{ $value { "char" "a code point" } { "n" "an integer" } } +{ $values { "char" "a code point" } { "n" "an integer" } } { $description "Finds the combining class of a code point." } ; HELP: non-starter? -{ $value { "char" "a code point" } { "?" "a boolean" } } +{ $values { "char" "a code point" } { "?" "a boolean" } } { $description "Returns true if the code point has a combining class." } ; HELP: char>name -{ $value { "char" "a code point" } { "name" string } } +{ $values { "char" "a code point" } { "name" string } } { $description "Looks up the name of a given code point. Warning: this is not optimized for speed, to save space." } ; HELP: name>char -{ $value { "name" string } { "char" "a code point" } } +{ $values { "name" string } { "char" "a code point" } } { $description "Looks up the code point corresponding to a given name." } ; HELP: property? -{ $value { "char" "a code point" } { "property" string } { "?" "a boolean" } } +{ $values { "char" "a code point" } { "property" string } { "?" "a boolean" } } { $description "Tests whether the code point is listed under the given property in PropList.txt in the Unicode Character Database." } ; diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 8f99b6c160..cf4130ca4d 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -24,8 +24,8 @@ VALUE: properties : compatibility-entry ( char -- seq ) compatibility-map at ; : combining-class ( char -- n ) class-map at ; : non-starter? ( char -- ? ) class-map key? ; -: name>char ( string -- char ) name-map at ; -: char>name ( char -- string ) name-map value-at ; +: name>char ( name -- char ) name-map at ; +: char>name ( char -- name ) name-map value-at ; : property? ( char property -- ? ) properties at interval-key? ; ! Loading data from UnicodeData.txt diff --git a/basis/unicode/normalize/normalize-docs.factor b/basis/unicode/normalize/normalize-docs.factor index 65f50ab0ae..4b1e3485ef 100644 --- a/basis/unicode/normalize/normalize-docs.factor +++ b/basis/unicode/normalize/normalize-docs.factor @@ -23,5 +23,5 @@ HELP: nfkc { $description "Converts a string to Normalization Form KC" } ; HELP: nfkd -{ $values { "string" string } { "nfc" "a string in NFKD" } } +{ $values { "string" string } { "nfkd" "a string in NFKD" } } { $description "Converts a string to Normalization Form KD" } ; From 076b2d0893d60e5b019f6989743afa685796cf16 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 16:06:01 -0600 Subject: [PATCH 11/56] add >=< word to math.order --- core/math/order/order-docs.factor | 7 +++++++ core/math/order/order.factor | 2 ++ 2 files changed, 9 insertions(+) diff --git a/core/math/order/order-docs.factor b/core/math/order/order-docs.factor index ef006bbc21..1bdd1009e9 100644 --- a/core/math/order/order-docs.factor +++ b/core/math/order/order-docs.factor @@ -15,6 +15,12 @@ HELP: <=> } } ; +HELP: >=< +{ $values { "obj1" object } { "obj2" object } { ">=<" "an ordering specifier" } } +{ $description "Compares two objects using the " { $link <=> } " comparator and inverts the output." } ; + +{ <=> >=< } related-words + HELP: +lt+ { $description "Output by " { $link <=> } " when the first object is strictly less than the second object." } ; @@ -85,6 +91,7 @@ ARTICLE: "order-specifiers" "Ordering specifiers" ARTICLE: "math.order" "Linear order protocol" "Some classes have an intrinsic order amongst instances:" { $subsection <=> } +{ $subsection >=< } { $subsection compare } { $subsection invert-comparison } "The above words output order specifiers." diff --git a/core/math/order/order.factor b/core/math/order/order.factor index aae5841185..a06209bf63 100644 --- a/core/math/order/order.factor +++ b/core/math/order/order.factor @@ -13,6 +13,8 @@ SYMBOL: +gt+ GENERIC: <=> ( obj1 obj2 -- <=> ) +: >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline + M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ; GENERIC: before? ( obj1 obj2 -- ? ) From 6414426373bd82f6daa1d91e8dd8ad584e3371df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 16:32:26 -0600 Subject: [PATCH 12/56] Add docs for sorting.human, add human>=< --- basis/sorting/human/human-docs.factor | 71 +++++++++++++++++++++++++++ basis/sorting/human/human.factor | 2 + 2 files changed, 73 insertions(+) create mode 100644 basis/sorting/human/human-docs.factor diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor new file mode 100644 index 0000000000..5342b28317 --- /dev/null +++ b/basis/sorting/human/human-docs.factor @@ -0,0 +1,71 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel math.order quotations +sequences strings ; +IN: sorting.human + +HELP: find-numbers +{ $values + { "string" string } + { "seq" sequence } +} +{ $description "Splits a string on numbers and returns a sequence of sequences and integers." } ; + +HELP: human-<=> +{ $values + { "obj1" object } { "obj2" object } + { "<=>" "an ordering specifier" } +} +{ $description "Compares two objects after converting numbers in the string into integers." } ; + +HELP: human->=< +{ $values + { "obj1" object } { "obj2" object } + { ">=<" "an ordering specifier" } +} +{ $description "Compares two objects using the " { $link human-<=> } " word and inverts the result." } ; + +HELP: human-compare +{ $values + { "obj1" object } { "obj2" object } { "quot" quotation } + { "<=>" "an ordering specifier" } +} +{ $description "Compares the results of applying the quotation to both objects via <=>." } ; + +HELP: human-sort +{ $values + { "seq" sequence } + { "seq'" sequence } +} +{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ; + +HELP: human-sort-keys +{ $values + { "seq" "an alist" } + { "sortedseq" "a new sorted sequence" } +} +{ $description "Sorts the elements comparing first elements of pairs using the " { $link human-<=> } " word." } ; + +HELP: human-sort-values +{ $values + { "seq" "an alist" } + { "sortedseq" "a new sorted sequence" } +} +{ $description "Sorts the elements comparing second elements of pairs using the " { $link human-<=> } " word." } ; + +{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words + +ARTICLE: "sorting.human" "sorting.human" +"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl +"Comparing two objects:" +{ $subsection human-<=> } +{ $subsection human->=< } +{ $subsection human-compare } +"Sort a sequence:" +{ $subsection human-sort } +{ $subsection human-sort-keys } +{ $subsection human-sort-values } +"Splitting a string into substrings and integers:" +{ $subsection find-numbers } ; + +ABOUT: "sorting.human" diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor index f338e21887..2c4d391a60 100644 --- a/basis/sorting/human/human.factor +++ b/basis/sorting/human/human.factor @@ -9,6 +9,8 @@ IN: sorting.human : human-<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ; +: human->=< ( obj1 obj2 -- >=< ) human-<=> invert-comparison ; inline + : human-compare ( obj1 obj2 quot -- <=> ) bi@ human-<=> ; : human-sort ( seq -- seq' ) [ human-<=> ] sort ; From d9d349993a78a66ceef9b31596687cffd2563e9f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 16:38:44 -0600 Subject: [PATCH 13/56] Sorting by sequences of accessor/comparator pairs --- basis/sorting/slots/authors.txt | 2 ++ basis/sorting/slots/slots-docs.factor | 42 ++++++++++++++++++++++ basis/sorting/slots/slots-tests.factor | 50 ++++++++++++++++++++++++++ basis/sorting/slots/slots.factor | 19 ++++++++++ 4 files changed, 113 insertions(+) create mode 100644 basis/sorting/slots/authors.txt create mode 100644 basis/sorting/slots/slots-docs.factor create mode 100644 basis/sorting/slots/slots-tests.factor create mode 100644 basis/sorting/slots/slots.factor diff --git a/basis/sorting/slots/authors.txt b/basis/sorting/slots/authors.txt new file mode 100644 index 0000000000..5674120196 --- /dev/null +++ b/basis/sorting/slots/authors.txt @@ -0,0 +1,2 @@ +Doug Coleman +Slava Pestov diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor new file mode 100644 index 0000000000..64d0a1efdf --- /dev/null +++ b/basis/sorting/slots/slots-docs.factor @@ -0,0 +1,42 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations math.order +sequences ; +IN: sorting.slots + +HELP: compare-slots +{ $values + { "sort-specs" "a sequence of accessor/comparator pairs" } + { "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } } +} +{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ; + +HELP: sort-by-slots +{ $values + { "seq" sequence } { "sort-specs" "a sequence of accessor/comparator pairs" } + { "seq'" sequence } +} +{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a slot accessor and a comparator." } +{ $examples + "Sort by slot c, then b descending:" + { $example + "USING: accessors math.order prettyprint sorting.slots ;" + "IN: scratchpad" + "TUPLE: sort-me a b ;" + "{" + " T{ sort-me f 2 3 } T{ sort-me f 3 2 }" + " T{ sort-me f 4 3 } T{ sort-me f 2 1 }" + "}" + "{ { a>> <=> } { b>> >=< } } sort-by-slots ." + "{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}" + } +} ; + +ARTICLE: "sorting.slots" "Sorting by slots" +"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl +"Comparing two objects by a sequence of slots:" +{ $subsection compare-slots } +"Sorting a sequence by a sequence of slots:" +{ $subsection sort-by-slots } ; + +ABOUT: "sorting.slots" diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor new file mode 100644 index 0000000000..ab130d1eed --- /dev/null +++ b/basis/sorting/slots/slots-tests.factor @@ -0,0 +1,50 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors math.order sorting.slots tools.test +sorting.human ; +IN: sorting.literals.tests + +TUPLE: sort-test a b c ; + +[ + { + T{ sort-test { a 1 } { b 3 } { c 9 } } + T{ sort-test { a 1 } { b 1 } { c 10 } } + T{ sort-test { a 1 } { b 1 } { c 11 } } + T{ sort-test { a 2 } { b 5 } { c 2 } } + T{ sort-test { a 2 } { b 5 } { c 3 } } + } +] [ + { + T{ sort-test f 1 3 9 } + T{ sort-test f 1 1 10 } + T{ sort-test f 1 1 11 } + T{ sort-test f 2 5 3 } + T{ sort-test f 2 5 2 } + } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots +] unit-test + +[ + { + T{ sort-test { a 1 } { b 3 } { c 9 } } + T{ sort-test { a 1 } { b 1 } { c 10 } } + T{ sort-test { a 1 } { b 1 } { c 11 } } + T{ sort-test { a 2 } { b 5 } { c 2 } } + T{ sort-test { a 2 } { b 5 } { c 3 } } + } +] [ + { + T{ sort-test f 1 3 9 } + T{ sort-test f 1 1 10 } + T{ sort-test f 1 1 11 } + T{ sort-test f 2 5 3 } + T{ sort-test f 2 5 2 } + } { { a>> human-<=> } { b>> human->=< } { c>> <=> } } sort-by-slots +] unit-test + +[ + { } +] [ + { } + { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots +] unit-test diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor new file mode 100644 index 0000000000..02a11428f9 --- /dev/null +++ b/basis/sorting/slots/slots.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.short-circuit fry kernel macros math.order +sequences words sorting ; +IN: sorting.slots + + + +MACRO: compare-slots ( sort-specs -- <=> ) + #! sort-spec: { accessor comparator } + [ first2 slot-comparator ] map '[ _ 2|| +eq+ or ] ; + +: sort-by-slots ( seq sort-specs -- seq' ) + '[ _ compare-slots ] sort ; From 0a9677c0af560b283334b7bdc77134a113a72131 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 16:41:38 -0600 Subject: [PATCH 14/56] Test the database with parallel combinators --- basis/db/tester/authors.txt | 2 + basis/db/tester/tester-tests.factor | 7 ++++ basis/db/tester/tester.factor | 57 +++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+) create mode 100644 basis/db/tester/authors.txt create mode 100644 basis/db/tester/tester-tests.factor create mode 100644 basis/db/tester/tester.factor diff --git a/basis/db/tester/authors.txt b/basis/db/tester/authors.txt new file mode 100644 index 0000000000..f372b574ae --- /dev/null +++ b/basis/db/tester/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Doug Coleman diff --git a/basis/db/tester/tester-tests.factor b/basis/db/tester/tester-tests.factor new file mode 100644 index 0000000000..6b39a7e218 --- /dev/null +++ b/basis/db/tester/tester-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test db.tester ; +IN: db.tester.tests + +[ ] [ sqlite-test-db db-tester ] unit-test +[ ] [ sqlite-test-db db-tester2 ] unit-test diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor new file mode 100644 index 0000000000..4e53ad3df7 --- /dev/null +++ b/basis/db/tester/tester.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Slava Pestov, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: concurrency.combinators db.pools db.sqlite db.tuples +db.types kernel math random threads tools.test db sequences +io prettyprint ; +IN: db.tester + +TUPLE: test-1 id a b c ; + +test-1 "TEST1" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "a" "A" { VARCHAR 256 } +not-null+ } + { "b" "B" { VARCHAR 256 } +not-null+ } + { "c" "C" { VARCHAR 256 } +not-null+ } +} define-persistent + +TUPLE: test-2 id x y z ; + +test-2 "TEST2" { + { "id" "ID" INTEGER +db-assigned-id+ } + { "x" "X" { VARCHAR 256 } +not-null+ } + { "y" "Y" { VARCHAR 256 } +not-null+ } + { "z" "Z" { VARCHAR 256 } +not-null+ } +} define-persistent + +: sqlite-test-db ( -- db ) "test.db" ; +: test-db ( -- db ) "test.db" ; + +: db-tester ( test-db -- ) + [ + [ + test-1 ensure-table + test-2 ensure-table + ] with-db + ] [ + 10 [ + drop + 10 [ + dup [ + f 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] with-db + ] times + ] with parallel-each + ] bi ; + +: db-tester2 ( test-db -- ) + [ + [ test-1 recreate-table ] with-db + ] [ + [ + 2 [ + 10 random 100 random 100 random 100 random test-1 boa + insert-tuple yield + ] parallel-each + ] with-db + ] bi ; From f4530a743dc3a3bfe4a622d90712c7bff4e4ce8c Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Thu, 8 Jan 2009 23:52:38 +0100 Subject: [PATCH 15/56] FUEL: Improvements to factor-mode-visit-other-file. --- misc/fuel/factor-mode.el | 72 +++++++++++++++++++++++++++++----------- 1 file changed, 53 insertions(+), 19 deletions(-) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index d354fd820a..394f6c41f9 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -1,6 +1,6 @@ ;;; factor-mode.el -- mode for editing Factor source -;; Copyright (C) 2008 Jose Antonio Ortega Ruiz +;; Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz ;; See http://factorcode.org/license.txt for BSD license. ;; Author: Jose Antonio Ortega Ruiz @@ -28,6 +28,14 @@ :group 'fuel :group 'languages) +(defcustom factor-mode-cycle-always-ask-p t + "Whether to always ask for file creation when cycling to a +source/docs/tests file. + +When set to false, you'll be asked only once." + :type 'boolean + :group 'factor-mode) + (defcustom factor-mode-use-fuel t "Whether to use the full FUEL facilities in factor mode. @@ -174,33 +182,58 @@ code in the buffer." (defconst factor-mode--cycle-endings '(".factor" "-tests.factor" "-docs.factor")) -(defconst factor-mode--regex-cycle-endings - (format "\\(.*?\\)\\(%s\\)$" - (regexp-opt factor-mode--cycle-endings))) +(make-local-variable + (defvar factor-mode--cycling-no-ask nil)) -(defconst factor-mode--cycle-endings-ring +(defvar factor-mode--cycle-ring (let ((ring (make-ring (length factor-mode--cycle-endings)))) (dolist (e factor-mode--cycle-endings ring) - (ring-insert ring e)))) + (ring-insert ring e)) + ring)) + +(defconst factor-mode--cycle-basename-regex + (format "\\(.+?\\)\\(%s\\)$" (regexp-opt factor-mode--cycle-endings))) + +(defun factor-mode--cycle-split (basename) + (when (string-match factor-mode--cycle-basename-regex basename) + (cons (match-string 1 basename) (match-string 2 basename)))) (defun factor-mode--cycle-next (file) - (let* ((match (string-match factor-mode--regex-cycle-endings file)) - (base (and match (match-string-no-properties 1 file))) - (ending (and match (match-string-no-properties 2 file))) - (idx (and ending (ring-member factor-mode--cycle-endings-ring ending))) - (gfl (lambda (i) (concat base (ring-ref factor-mode--cycle-endings-ring i))))) - (if (not idx) file - (let ((l (length factor-mode--cycle-endings)) (i 1) next) - (while (and (not next) (< i l)) - (when (file-exists-p (funcall gfl (+ idx i))) - (setq next (+ idx i))) - (setq i (1+ i))) - (funcall gfl (or next idx)))))) + (let* ((dir (file-name-directory file)) + (basename (file-name-nondirectory file)) + (p/s (factor-mode--cycle-split basename)) + (prefix (car p/s)) + (ring factor-mode--cycle-ring) + (idx (or (ring-member ring (cdr p/s)) 0)) + (len (ring-size ring)) + (i 1) + (result nil)) + (while (and (< i len) (not result)) + (let* ((suffix (ring-ref ring (+ i idx))) + (path (expand-file-name (concat prefix suffix) dir))) + (when (or (file-exists-p path) + (and (not (member suffix factor-mode--cycling-no-ask)) + (y-or-n-p (format "Create %s? " path)))) + (setq result path)) + (when (and (not factor-mode-cycle-always-ask-p) + (not (member suffix factor-mode--cycling-no-ask))) + (setq factor-mode--cycling-no-ask + (cons name factor-mode--cycling-no-ask)))) + (setq i (1+ i))) + result)) + +(defsubst factor-mode--cycling-setup () + (setq factor-mode--cycling-no-ask nil)) (defun factor-mode-visit-other-file (&optional file) "Cycle between code, tests and docs factor files." (interactive) - (find-file (factor-mode--cycle-next (or file (buffer-file-name))))) + (let ((file (factor-mode--cycle-next (or file (buffer-file-name))))) + (unless file (error "No other file found")) + (find-file file) + (unless (file-exists-p file) + (set-buffer-modified-p t) + (save-buffer)))) ;;; Keymap: @@ -237,6 +270,7 @@ code in the buffer." (factor-mode--keymap-setup) (factor-mode--indentation-setup) (factor-mode--syntax-setup) + (factor-mode--cycling-setup) (when factor-mode-use-fuel (require 'fuel-mode) (fuel-mode)) (run-hooks 'factor-mode-hook)) From b9f0d16026e005de682fe100898149ef33ccef3d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 17:01:27 -0600 Subject: [PATCH 16/56] add upward/stable/downward slices, monotonic-slice, trends and docs --- .../splitting/monotonic/monotonic-docs.factor | 109 ++++++++++++++++++ .../monotonic/monotonic-tests.factor | 45 ++++++++ basis/splitting/monotonic/monotonic.factor | 54 ++++++++- 3 files changed, 206 insertions(+), 2 deletions(-) create mode 100644 basis/splitting/monotonic/monotonic-docs.factor diff --git a/basis/splitting/monotonic/monotonic-docs.factor b/basis/splitting/monotonic/monotonic-docs.factor new file mode 100644 index 0000000000..983c5b0dea --- /dev/null +++ b/basis/splitting/monotonic/monotonic-docs.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations classes sequences +multiline ; +IN: splitting.monotonic + +HELP: monotonic-slice +{ $values + { "seq" sequence } { "quot" quotation } { "class" class } + { "slices" "a sequence of slices" } +} +{ $description "Monotonically splits a sequence into slices of the type " { $snippet "class" } "." } +{ $examples + { $example + "USING: splitting.monotonic math prettyprint ;" + "{ 1 2 3 2 3 4 } [ < ] upward-slice monotonic-slice ." + <" { + T{ upward-slice + { from 0 } + { to 3 } + { seq { 1 2 3 2 3 4 } } + } + T{ upward-slice + { from 3 } + { to 6 } + { seq { 1 2 3 2 3 4 } } + } +}"> + } +} ; + +HELP: monotonic-split +{ $values + { "seq" sequence } { "quot" quotation } + { "newseq" "a sequence of sequences" } +} +{ $description "Compares pairs of elements in a sequence and collects elements into sequences while they satisfy the predicate. Once the predicate fails, a new sequence is started, and all sequences are returned in a single sequence." } +{ $examples + { $example + "USING: splitting.monotonic math prettyprint ;" + "{ 1 2 3 2 3 4 } [ < ] monotonic-split ." + "{ V{ 1 2 3 } V{ 2 3 4 } }" + } +} ; + +HELP: downward-slices +{ $values + { "seq" sequence } + { "slices" "a sequence of downward-slices" } +} +{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ; + +HELP: stable-slices +{ $values + { "seq" sequence } + { "slices" "a sequence of stable-slices" } +} +{ $description "Returns an array of monotonically decreasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ; + +HELP: upward-slices +{ $values + { "seq" sequence } + { "slices" "a sequence of upward-slices" } +} +{ $description "Returns an array of monotonically increasing slices of type " { $link downward-slice } ". Slices of one element are discarded." } ; + +HELP: trends +{ $values + { "seq" sequence } + { "slices" "a sequence of downward, stable, and upward slices" } +} +{ $description "Returns a sorted sequence of downward, stable, or upward slices. The endpoints of some slices may overlap with each other." } +{ $examples + { $example + "USING: splitting.monotonic math prettyprint ;" + "{ 1 2 3 3 2 1 } trends ." + <" { + T{ upward-slice + { from 0 } + { to 3 } + { seq { 1 2 3 3 2 1 } } + } + T{ stable-slice + { from 2 } + { to 4 } + { seq { 1 2 3 3 2 1 } } + } + T{ downward-slice + { from 3 } + { to 6 } + { seq { 1 2 3 3 2 1 } } + } +}"> + } +} ; + +ARTICLE: "splitting.monotonic" "Splitting trending sequences" +"The " { $vocab-link "splitting.monotonic" } " vocabulary splits sequences that are trending downwards, upwards, or stably." $nl +"Splitting into sequences:" +{ $subsection monotonic-split } +"Splitting into slices:" +{ $subsection monotonic-slice } +"Trending:" +{ $subsection downward-slices } +{ $subsection stable-slices } +{ $subsection upward-slices } +{ $subsection trends } ; + +ABOUT: "splitting.monotonic" diff --git a/basis/splitting/monotonic/monotonic-tests.factor b/basis/splitting/monotonic/monotonic-tests.factor index ab4c48b292..7bf9a38e8a 100644 --- a/basis/splitting/monotonic/monotonic-tests.factor +++ b/basis/splitting/monotonic/monotonic-tests.factor @@ -6,3 +6,48 @@ USING: tools.test math arrays kernel sequences ; [ { { 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 +[ { } ] +[ { } [ = ] slice monotonic-slice ] unit-test + +[ t ] +[ { 1 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test + +[ { { 1 } } ] +[ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test + +[ t ] +[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test + +[ { { 1 1 1 } { 2 2 } { 3 3 } { 4 } } ] +[ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ >array ] map ] unit-test + +[ { { 3 3 } } ] +[ { 3 3 } [ = ] slice monotonic-slice [ >array ] map ] unit-test + +[ + { + T{ upward-slice { from 0 } { to 3 } { seq { 1 2 3 2 1 } } } + T{ downward-slice { from 2 } { to 5 } { seq { 1 2 3 2 1 } } } + } +] +[ { 1 2 3 2 1 } trends ] unit-test + +[ + { + T{ upward-slice + { from 0 } + { to 3 } + { seq { 1 2 3 3 2 1 } } + } + T{ stable-slice + { from 2 } + { to 4 } + { seq { 1 2 3 3 2 1 } } + } + T{ downward-slice + { from 3 } + { to 6 } + { seq { 1 2 3 3 2 1 } } + } + } +] [ { 1 2 3 3 2 1 } trends ] unit-test diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index 5bc7a51522..e39bba25ab 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -1,8 +1,11 @@ -! Copyright (C) 2008 Doug Coleman. +! Copyright (C) 2008, 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: make namespaces sequences kernel fry ; +USING: make namespaces sequences kernel fry arrays compiler.utilities +math accessors circular grouping combinators sorting math.order ; IN: splitting.monotonic + + : monotonic-split ( seq quot -- newseq ) over empty? [ 2drop { } ] [ (monotonic-split) ] if ; inline + + 1 over change-circular-start ] tri + [ @ not [ , ] [ drop ] if ] 3each + ] { } make + dup empty? [ over length 1- prefix ] when -1 prefix 2 clump + [ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline + +PRIVATE> + +: monotonic-slice ( seq quot class -- slices ) + pick length { + { 0 [ 2drop ] } + { 1 [ nip [ 0 1 rot ] dip boa 1array ] } + [ drop (monotonic-slice) ] + } case ; + +TUPLE: downward-slice < slice ; +TUPLE: stable-slice < slice ; +TUPLE: upward-slice < slice ; + +: downward-slices ( seq -- slices ) + [ > ] downward-slice monotonic-slice [ length 1 > ] filter ; + +: stable-slices ( seq -- slices ) + [ = ] stable-slice monotonic-slice [ length 1 > ] filter ; + +: upward-slices ( seq -- slices ) + [ < ] upward-slice monotonic-slice [ length 1 > ] filter ; + +: trends ( seq -- slices ) + dup length { + { 0 [ ] } + { 1 [ [ 0 1 ] dip stable-slice boa ] } + [ + drop + [ downward-slices ] + [ stable-slices ] + [ upward-slices ] tri 3append [ [ from>> ] compare ] sort + ] + } case ; From 977837143be7d42f471205316060dbf8829234fb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 Jan 2009 17:03:06 -0600 Subject: [PATCH 17/56] Load help.lint by default --- basis/bootstrap/help/help.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor index 5b49ce2802..145738ff45 100644 --- a/basis/bootstrap/help/help.factor +++ b/basis/bootstrap/help/help.factor @@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ; IN: bootstrap.help : load-help ( -- ) + "help.lint" require "alien.syntax" require "compiler" require From 070d7f05dfcb0f57e47a024e557024cb8f6d443e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 8 Jan 2009 17:03:15 -0600 Subject: [PATCH 18/56] Fix typo in VALUE: docs --- basis/values/values-docs.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index 866af469e9..59bf77da3a 100644 --- a/basis/values/values-docs.factor +++ b/basis/values/values-docs.factor @@ -15,7 +15,16 @@ ABOUT: "values" HELP: VALUE: { $syntax "VALUE: word" } { $values { "word" "a word to be created" } } -{ $description "Creates a value on the given word, initializing it to hold " { $code f } ". To get the value, just run the word. To set it, use " { $link set-value } "." } ; +{ $description "Creates a value on the given word, initializing it to hold " { $snippet "f" } ". To get the value, just run the word. To set it, use " { $link POSTPONE: to: } "." } +{ $examples + { $example + "USING: values math prettyprint ;" + "VALUE: x" + "2 2 + to: x" + "x ." + "4" + } +} ; HELP: get-value { $values { "word" "a value word" } { "value" "the contents" } } From 5135a2499a280951c4fc6bd2bcc425dda120116a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 17:07:33 -0600 Subject: [PATCH 19/56] username -> user-name --- basis/unix/groups/groups.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 41cd80f456..164afa46fb 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -71,7 +71,7 @@ M: string user-groups ( string -- seq ) (user-groups) ; M: integer user-groups ( id -- seq ) - username (user-groups) ; + user-name (user-groups) ; : all-groups ( -- seq ) [ getgrent dup ] [ group-struct>group ] [ drop ] produce ; From cf160c60ea38aaac4cf005e77eb2118a2345f664 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 17:48:17 -0600 Subject: [PATCH 20/56] use input> "Minneapolis" = ] unit-test diff --git a/extra/usa-cities/usa-cities.factor b/extra/usa-cities/usa-cities.factor index deb3e15845..25ec30ac78 100644 --- a/extra/usa-cities/usa-cities.factor +++ b/extra/usa-cities/usa-cities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.files io.encodings.ascii sequences generalizations math.parser combinators kernel memoize csv summary -words accessors math.order binary-search ; +words accessors math.order binary-search combinators.smart ; IN: usa-cities SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN @@ -30,15 +30,17 @@ first-zip name state latitude longitude gmt-offset dst-offset ; MEMO: cities ( -- seq ) "resource:extra/usa-cities/zipcode.csv" ascii csv rest-slice [ - 7 firstn { - [ string>number ] - [ ] - [ string>state ] - [ string>number ] - [ string>number ] - [ string>number ] - [ string>number ] - } spread city boa + [ + { + [ string>number ] + [ ] + [ string>state ] + [ string>number ] + [ string>number ] + [ string>number ] + [ string>number ] + } spread + ] input Date: Thu, 8 Jan 2009 17:53:48 -0600 Subject: [PATCH 21/56] use smart combinator in geo-ip --- extra/geo-ip/geo-ip.factor | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/extra/geo-ip/geo-ip.factor b/extra/geo-ip/geo-ip.factor index c878306d7d..ad6302ca55 100644 --- a/extra/geo-ip/geo-ip.factor +++ b/extra/geo-ip/geo-ip.factor @@ -4,7 +4,7 @@ USING: kernel sequences io.files io.files.temp io.launcher io.pathnames io.encodings.ascii io.streams.string http.client generalizations combinators math.parser math.vectors math.intervals interval-maps memoize csv accessors assocs -strings math splitting grouping arrays ; +strings math splitting grouping arrays combinators.smart ; IN: geo-ip : db-path ( -- path ) "IpToCountry.csv" temp-file ; @@ -20,15 +20,17 @@ IN: geo-ip TUPLE: ip-entry from to registry assigned city cntry country ; : parse-ip-entry ( row -- ip-entry ) - 7 firstn { - [ string>number ] - [ string>number ] - [ ] - [ ] - [ ] - [ ] - [ ] - } spread ip-entry boa ; + [ + { + [ string>number ] + [ string>number ] + [ ] + [ ] + [ ] + [ ] + [ ] + } spread + ] input Date: Thu, 8 Jan 2009 17:55:04 -0600 Subject: [PATCH 22/56] use smart combinators in tools.files.unix --- basis/tools/files/unix/unix.factor | 50 +++++++++++++++--------------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/basis/tools/files/unix/unix.factor b/basis/tools/files/unix/unix.factor index 507c689a55..9757db171a 100755 --- a/basis/tools/files/unix/unix.factor +++ b/basis/tools/files/unix/unix.factor @@ -3,12 +3,9 @@ USING: accessors combinators kernel system unicode.case io.files io.files.info io.files.info.unix tools.files generalizations strings arrays sequences math.parser unix.groups unix.users -tools.files.private unix.stat math fry macros ; +tools.files.private unix.stat math fry macros combinators.smart ; IN: tools.files.unix -MACRO: cleave>array ( array -- quot ) - dup length '[ _ cleave _ narray ] ; - string ( str bools -- str' ) @@ -20,18 +17,20 @@ MACRO: cleave>array ( array -- quot ) } case ; : permissions-string ( permissions -- str ) - { - [ type>> file-type>ch 1string ] - [ user-read? read>string ] - [ user-write? write>string ] - [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ] - [ group-read? read>string ] - [ group-write? write>string ] - [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ] - [ other-read? read>string ] - [ other-write? write>string ] - [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] - } cleave>array concat ; + [ + { + [ type>> file-type>ch 1string ] + [ user-read? read>string ] + [ user-write? write>string ] + [ [ uid? ] [ user-execute? ] bi 2array "s" unix-execute>string ] + [ group-read? read>string ] + [ group-write? write>string ] + [ [ gid? ] [ group-execute? ] bi 2array "s" unix-execute>string ] + [ other-read? read>string ] + [ other-write? write>string ] + [ [ sticky? ] [ other-execute? ] bi 2array "t" unix-execute>string ] + } cleave + ] output>array concat ; : mode>symbol ( mode -- ch ) S_IFMT bitand @@ -48,15 +47,16 @@ MACRO: cleave>array ( array -- quot ) M: unix (directory.) ( path -- lines ) [ [ [ - dup file-info - { - [ permissions-string ] - [ nlink>> number>string 3 CHAR: \s pad-left ] - [ uid>> user-name ] - [ gid>> group-name ] - [ size>> number>string 15 CHAR: \s pad-left ] - [ modified>> ls-timestamp ] - } cleave>array swap suffix " " join + dup file-info [ + { + [ permissions-string ] + [ nlink>> number>string 3 CHAR: \s pad-left ] + [ uid>> user-name ] + [ gid>> group-name ] + [ size>> number>string 15 CHAR: \s pad-left ] + [ modified>> ls-timestamp ] + } cleave + ] output>array swap suffix " " join ] map ] with-group-cache ] with-user-cache ; From a773e592164c4197aef519ab5424e6bc58bc466c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 17:56:03 -0600 Subject: [PATCH 23/56] username -> user-name --- basis/io/files/info/unix/unix-docs.factor | 8 ++++---- basis/io/files/info/unix/unix.factor | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/io/files/info/unix/unix-docs.factor b/basis/io/files/info/unix/unix-docs.factor index 0dff2e4419..a6ee2b9597 100644 --- a/basis/io/files/info/unix/unix-docs.factor +++ b/basis/io/files/info/unix/unix-docs.factor @@ -22,11 +22,11 @@ HELP: file-permissions { "n" integer } } { $description "Returns the Unix file permissions for a given file." } ; -HELP: file-username +HELP: file-user-name { $values { "path" "a pathname string" } { "string" string } } -{ $description "Returns the username for a given file." } ; +{ $description "Returns the user-name for a given file." } ; HELP: file-user-id { $values @@ -110,7 +110,7 @@ HELP: set-file-times HELP: set-file-user { $values { "path" "a pathname string" } { "string/id" "a string or a user id" } } -{ $description "Sets a file's user id from the given user id or username." } ; +{ $description "Sets a file's user id from the given user id or user-name." } ; HELP: set-file-modified-time { $values @@ -258,7 +258,7 @@ ARTICLE: "unix-file-timestamps" "Unix file timestamps" ARTICLE: "unix-file-ids" "Unix file user and group ids" "Reading file user data:" { $subsection file-user-id } -{ $subsection file-username } +{ $subsection file-user-name } "Setting file user data:" { $subsection set-file-user } "Reading file group data:" diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 66b95db144..9287e7f4ad 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -243,8 +243,8 @@ M: string set-file-group ( path string -- ) : file-user-id ( path -- uid ) normalize-path file-info uid>> ; -: file-username ( path -- string ) - file-user-id username ; +: file-user-name ( path -- string ) + file-user-id user-name ; : file-group-id ( path -- gid ) normalize-path file-info gid>> ; From cf3473cc911c5f0b404675217d2196e1a080f611 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 17:56:52 -0600 Subject: [PATCH 24/56] Making normalization and case conversion faster --- basis/unicode/case/case.factor | 2 +- basis/unicode/data/data.factor | 9 +++- basis/unicode/normalize/normalize.factor | 56 ++++++++++++++---------- 3 files changed, 42 insertions(+), 25 deletions(-) diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index b0472cd9cb..99278cd72e 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -18,7 +18,7 @@ SYMBOL: locale ! Just casing locale, or overall? char ( name -- char ) name-map at ; : char>name ( char -- name ) name-map value-at ; : property? ( char property -- ? ) properties at interval-key? ; @@ -183,6 +183,13 @@ load-data { [ process-category to: category-map ] } cleave +: postprocess-class ( -- ) + combine-map [ [ second ] map ] map concat + [ combining-class not ] filter + [ 0 swap class-map set-at ] each ; + +postprocess-class + load-special-casing to: special-casing load-properties to: properties diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 58ce412a2e..c8d0eb3f7d 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces make unicode.data kernel math arrays -locals sorting.insertion accessors assocs math.order ; +locals sorting.insertion accessors assocs math.order combinators ; IN: unicode.normalize jamo % ] - [ dup quot call [ % ] [ , ] ?if ] if - ] each - ] "" make - dup reorder - ] if ; inline + [ + string [ + dup hangul? [ hangul>jamo % ] + [ dup quot call [ % ] [ , ] ?if ] if + ] each + ] "" make + dup reorder ; + +: with-string ( str quot -- str ) + over aux>> [ call ] [ drop ] if ; inline + +: (nfd) ( string -- nfd ) + [ canonical-entry ] decompose ; + +: (nfkd) ( string -- nfkd ) + [ compatibility-entry ] decompose ; PRIVATE> : nfd ( string -- nfd ) - [ canonical-entry ] decompose ; + [ (nfd) ] with-string ; : nfkd ( string -- nfkd ) - [ compatibility-entry ] decompose ; + [ (nfkd) ] with-string ; : string-append ( s1 s2 -- string ) [ append ] keep @@ -138,20 +142,26 @@ DEFER: compose-iter : compose-iter ( last-class -- ) current [ - dup combining-class - [ try-compose to compose-iter ] - [ swap [ drop ] [ try-noncombining ] if ] if* + dup combining-class { + { f [ 2drop ] } + { 0 [ swap [ drop ] [ try-noncombining ] if ] } + [ try-compose to compose-iter ] + } case ] [ drop ] if* ; : ?new-after ( -- ) after [ dup empty? [ drop SBUF" " clone ] unless ] change ; +: compose-combining ( ch -- ) + char set to ?new-after + f compose-iter + char get , after get % ; + : (compose) ( -- ) current [ dup jamo? [ drop compose-jamo ] [ - char set to ?new-after - f compose-iter - char get , after get % + 1 get-str combining-class + [ compose-combining ] [ , to ] if ] if (compose) ] when* ; @@ -166,7 +176,7 @@ DEFER: compose-iter PRIVATE> : nfc ( string -- nfc ) - nfd combine ; + [ (nfd) combine ] with-string ; : nfkc ( string -- nfkc ) - nfkd combine ; + [ (nfkd) combine ] with-string ; From 0e34a6d3635111ba2e9d9b169138b6716ddfeafd Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 9 Jan 2009 01:50:51 +0100 Subject: [PATCH 25/56] FUEL: Improved connection behaviour in presence of fuel loading errors. --- misc/fuel/fuel-connection.el | 80 ++++++++++++++++++++++++------------ misc/fuel/fuel-listener.el | 6 +-- 2 files changed, 54 insertions(+), 32 deletions(-) diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 09d1ddfb51..11b135d0f7 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -29,10 +29,7 @@ (defun fuel-con--get-connection (buffer/proc) (if (processp buffer/proc) (fuel-con--get-connection (process-buffer buffer/proc)) - (with-current-buffer buffer/proc - (or fuel-con--connection - (setq fuel-con--connection - (fuel-con--setup-connection buffer/proc)))))) + (with-current-buffer buffer/proc fuel-con--connection))) ;;; Request and connection datatypes: @@ -126,19 +123,20 @@ (defun fuel-con--setup-connection (buffer) (set-buffer buffer) (fuel-con--cleanup-connection fuel-con--connection) + (setq fuel-con--connection nil) (let ((conn (fuel-con--make-connection buffer))) (fuel-con--setup-comint) - (prog1 - (setq fuel-con--connection conn) - (fuel-con--connection-start-timer conn)))) + (fuel-con--establish-connection conn buffer))) (defconst fuel-con--prompt-regex "( .+ ) ") (defconst fuel-con--eot-marker "<~FUEL~>") (defconst fuel-con--init-stanza "USE: fuel fuel-retort") -(defconst fuel-con--comint-finished-regex +(defconst fuel-con--comint-finished-regex-connected (format "^%s$" fuel-con--eot-marker)) +(defvar fuel-con--comint-finished-regex fuel-con--prompt-regex) + (defun fuel-con--setup-comint () (set (make-local-variable 'comint-redirect-insert-matching-regexp) t) (add-hook 'comint-redirect-filter-functions @@ -154,17 +152,43 @@ (setq comint-redirect-finished-regexp fuel-con--prompt-regex)) str) +(defun fuel-con--establish-connection (conn buffer) + (with-current-buffer (fuel-con--comint-buffer) (erase-buffer)) + (with-current-buffer buffer + (setq fuel-con--connection conn) + (setq fuel-con--comint-finished-regex fuel-con--prompt-regex) + (fuel-con--send-string/wait buffer + fuel-con--init-stanza + 'fuel-con--establish-connection-cont + 20000) + conn)) + +(defun fuel-con--establish-connection-cont (ignore) + (let ((str (with-current-buffer (fuel-con--comint-buffer) (buffer-string)))) + (if (string-match fuel-con--eot-marker str) + (progn + (setq fuel-con--comint-finished-regex + fuel-con--comint-finished-regex-connected) + (fuel-con--connection-start-timer conn) + (message "FUEL listener up and running!")) + (fuel-con--connection-clean-current-request fuel-con--connection) + (setq fuel-con--connection nil) + (message "An error occurred initialising FUEL's Factor library!") + (pop-to-buffer (fuel-con--comint-buffer))))) + ;;; Requests handling: (defsubst fuel-con--comint-buffer () (get-buffer-create " *fuel connection retort*")) -(defsubst fuel-con--comint-buffer-form () +(defun fuel-con--comint-buffer-form () (with-current-buffer (fuel-con--comint-buffer) (goto-char (point-min)) (condition-case nil - (read (current-buffer)) + (let ((form (read (current-buffer)))) + (if (listp form) form + (list 'fuel-con-error (buffer-string)))) (error (list 'fuel-con-error (buffer-string)))))) (defun fuel-con--process-next (con) @@ -212,7 +236,7 @@ (save-current-buffer (let ((con (fuel-con--get-connection buffer/proc))) (unless con - (error "FUEL: couldn't find connection")) + (error "FUEL: no connection")) (let ((req (fuel-con--make-request str cont sender-buffer))) (fuel-con--connection-queue-request con req) (fuel-con--process-next con) @@ -223,22 +247,24 @@ (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf) (save-current-buffer - (let* ((con (fuel-con--get-connection buffer/proc)) - (req (fuel-con--send-string buffer/proc str cont sbuf)) - (id (and req (fuel-con--request-id req))) - (time (or timeout fuel-connection-timeout)) - (step 100) - (waitsecs (/ step 1000.0))) - (when id - (condition-case nil - (while (and (> time 0) - (not (fuel-con--connection-completed-p con id))) - (accept-process-output nil waitsecs) - (setq time (- time step))) - (error (setq time 0))) - (or (> time 0) - (fuel-con--request-deactivate req) - nil))))) + (let ((con (fuel-con--get-connection buffer/proc))) + (unless con + (error "FUEL: no connection")) + (let* ((req (fuel-con--send-string buffer/proc str cont sbuf)) + (id (and req (fuel-con--request-id req))) + (time (or timeout fuel-connection-timeout)) + (step 100) + (waitsecs (/ step 1000.0))) + (when id + (condition-case nil + (while (and (> time 0) + (not (fuel-con--connection-completed-p con id))) + (accept-process-output nil waitsecs) + (setq time (- time step))) + (error (setq time 0))) + (or (> time 0) + (fuel-con--request-deactivate req) + nil)))))) (provide 'fuel-connection) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index ecb47f68a2..d4fa5aed1f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -78,11 +78,7 @@ buffer." (make-comint-in-buffer "fuel listener" (current-buffer) factor nil "-run=listener" (format "-i=%s" image)) (fuel-listener--wait-for-prompt 10000) - (fuel-con--setup-connection (current-buffer)) - (fuel-con--send-string/wait (current-buffer) - fuel-con--init-stanza - '(lambda (s) (message "FUEL listener up and running!")) - 20000))) + (fuel-con--setup-connection (current-buffer)))) (defun fuel-listener--process (&optional start) (or (and (buffer-live-p (fuel-listener--buffer)) From fe92608a1f753c83f53b9a91f7ba6df05f1ea919 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 18:56:49 -0600 Subject: [PATCH 26/56] Add combinators.smart --- basis/combinators/smart/authors.txt | 1 + basis/combinators/smart/smart-docs.factor | 91 ++++++++++++++++++++++ basis/combinators/smart/smart-tests.factor | 21 +++++ basis/combinators/smart/smart.factor | 22 ++++++ 4 files changed, 135 insertions(+) create mode 100644 basis/combinators/smart/authors.txt create mode 100644 basis/combinators/smart/smart-docs.factor create mode 100644 basis/combinators/smart/smart-tests.factor create mode 100644 basis/combinators/smart/smart.factor diff --git a/basis/combinators/smart/authors.txt b/basis/combinators/smart/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/combinators/smart/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor new file mode 100644 index 0000000000..69ec3e7013 --- /dev/null +++ b/basis/combinators/smart/smart-docs.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations math sequences +multiline ; +IN: combinators.smart + +HELP: inputarray +{ $values + { "quot" quotation } + { "newquot" quotation } +} +{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." } +{ $examples + { $example + <" USING: combinators combinators.smart math prettyprint ; +9 [ + { [ 1- ] [ 1+ ] [ sq ] } cleave +] output>array ."> + "{ 8 10 81 }" + } +} ; + +HELP: output>sequence +{ $values + { "quot" quotation } { "exemplar" "an exemplar" } + { "newquot" quotation } +} +{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." } +{ $examples + { $example + "USING: combinators.smart kernel math prettyprint ;" + "4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ." + "V{ 5 6 7 }" + } +} ; + +HELP: reduce-output +{ $values + { "quot" quotation } { "operation" quotation } + { "newquot" quotation } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." } +{ $examples + { $example + "USING: combinators.smart kernel math prettyprint ;" + "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-output ." + "-9" + } +} ; + +HELP: sum-outputs +{ $values + { "quot" quotation } + { "n" integer } +} +{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." } +{ $examples + { $example + "USING: combinators.smart kernel math prettyprint ;" + "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ." + "20" + } +} ; + +ARTICLE: "combinators.smart" "Smart combinators" +"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl +"Smart inputs from a sequence:" +{ $subsection inputsequence } +{ $subsection output>array } +"Reducing the output of a quotation:" +{ $subsection reduce-output } +"Summing the output of a quotation:" +{ $subsection sum-outputs } ; + +ABOUT: "combinators.smart" diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor new file mode 100644 index 0000000000..4be445e465 --- /dev/null +++ b/basis/combinators/smart/smart-tests.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test combinators.smart math kernel ; +IN: combinators.smart.tests + +: test-bi ( -- 9 11 ) + 10 [ 1- ] [ 1+ ] bi ; + +[ [ test-bi ] output>array ] must-infer +[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test + +[ { 9 11 } [ + ] inputsequence ( quot exemplar -- newquot ) + [ dup infer out>> ] dip + '[ @ _ _ nsequence ] ; + +: output>array ( quot -- newquot ) + { } output>sequence ; inline + +MACRO: input> ] keep + '[ _ firstn @ ] ; + +MACRO: reduce-output ( quot operation -- newquot ) + [ dup infer out>> 1 [-] ] dip n*quot compose ; + +: sum-outputs ( quot -- n ) + [ + ] reduce-output ; inline From 932631c901f167c6dd2ea55fbdc4307355fdca12 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 18:57:07 -0600 Subject: [PATCH 27/56] use combinators.smart for bit-count --- basis/math/bitwise/bitwise-tests.factor | 4 ++++ basis/math/bitwise/bitwise.factor | 16 +++++++++------- 2 files changed, 13 insertions(+), 7 deletions(-) diff --git a/basis/math/bitwise/bitwise-tests.factor b/basis/math/bitwise/bitwise-tests.factor index 979c62dcfb..40eb20642c 100644 --- a/basis/math/bitwise/bitwise-tests.factor +++ b/basis/math/bitwise/bitwise-tests.factor @@ -32,3 +32,7 @@ IN: math.bitwise.tests [ 8 ] [ 0 3 toggle-bit ] unit-test [ 0 ] [ 8 3 toggle-bit ] unit-test + +[ 4 ] [ BIN: 1010101 bit-count ] unit-test +[ 0 ] [ BIN: 0 bit-count ] unit-test +[ 1 ] [ BIN: 1 bit-count ] unit-test diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 2c03164ae7..e60815bf60 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math math.functions sequences sequences.private words namespaces macros hints -combinators fry io.binary ; +combinators fry io.binary combinators.smart ; IN: math.bitwise ! utilities @@ -76,12 +76,14 @@ DEFER: byte-bit-count GENERIC: (bit-count) ( x -- n ) M: fixnum (bit-count) - { - [ byte-bit-count ] - [ -8 shift byte-bit-count ] - [ -16 shift byte-bit-count ] - [ -24 shift byte-bit-count ] - } cleave + + + ; + [ + { + [ byte-bit-count ] + [ -8 shift byte-bit-count ] + [ -16 shift byte-bit-count ] + [ -24 shift byte-bit-count ] + } cleave + ] sum-outputs ; M: bignum (bit-count) dup 0 = [ drop 0 ] [ From e020df3d008a878d5205ab1ecc9763d193d492b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 18:57:23 -0600 Subject: [PATCH 28/56] use combinators.smart --- basis/tools/cocoa/cocoa.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/tools/cocoa/cocoa.factor b/basis/tools/cocoa/cocoa.factor index a8cdf6f41c..9dd1895a68 100644 --- a/basis/tools/cocoa/cocoa.factor +++ b/basis/tools/cocoa/cocoa.factor @@ -1,16 +1,18 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays cocoa.messages cocoa.runtime combinators -prettyprint ; +prettyprint combinators.smart ; IN: tools.cocoa : method. ( method -- ) - { - [ method_getName sel_getName ] - [ method-return-type ] - [ method-arg-types ] - [ method_getImplementation ] - } cleave 4array . ; + [ + { + [ method_getName sel_getName ] + [ method-return-type ] + [ method-arg-types ] + [ method_getImplementation ] + } cleave + ] output>array . ; : methods. ( class -- ) [ method. ] each-method-in-class ; From 8cb0be6a0af905c6ed103ac9731070aa1cd8e04b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 18:57:33 -0600 Subject: [PATCH 29/56] use combinators.smart --- basis/ui/gadgets/buttons/buttons.factor | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/basis/ui/gadgets/buttons/buttons.factor b/basis/ui/gadgets/buttons/buttons.factor index 75469671ef..dabc12d3ae 100644 --- a/basis/ui/gadgets/buttons/buttons.factor +++ b/basis/ui/gadgets/buttons/buttons.factor @@ -6,7 +6,7 @@ classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets ui.gadgets.borders ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.render math.geometry.rect locals alien.c-types -specialized-arrays.float fry ; +specialized-arrays.float fry combinators.smart ; IN: ui.gadgets.buttons TUPLE: button < border pressed? selected? quot ; @@ -111,12 +111,14 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ; array ; : checkmark-vertices ( dim -- vertices ) checkmark-points concat >float-array ; From ad53cb8635ba90bdf50419846e995875d3e20955 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 19:07:46 -0600 Subject: [PATCH 30/56] Privatizing unicode.case:ch>{lower,upper,title} --- basis/ascii/ascii-docs.factor | 28 ++++++++++++++++++- basis/ascii/ascii-tests.factor | 5 ++++ basis/ascii/ascii.factor | 14 ++++++++++ basis/regexp/nfa/nfa.factor | 7 ++++- basis/regexp/parser/parser.factor | 10 +++---- basis/soundex/soundex.factor | 2 +- basis/tr/tr-tests.factor | 2 +- basis/tr/tr.factor | 4 +-- basis/unicode/case/case-docs.factor | 19 ------------- basis/unicode/case/case.factor | 2 +- basis/unicode/data/data.factor | 5 +--- basis/unicode/normalize/normalize.factor | 3 +- basis/xmode/marker/marker.factor | 2 +- .../reverse-complement.factor | 2 +- extra/parser-combinators/regexp/regexp.factor | 2 +- 15 files changed, 67 insertions(+), 40 deletions(-) diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor index 6af697cf89..4c783e609c 100644 --- a/basis/ascii/ascii-docs.factor +++ b/basis/ascii/ascii-docs.factor @@ -37,6 +37,26 @@ HELP: quotable? { $values { "ch" "a character" } { "?" "a boolean" } } { $description "Tests for characters which may appear in a Factor string literal without escaping." } ; +HELP: ascii? +{ $values { "ch" "a character" } { "?" "a boolean" } } +{ $description "Tests for whether a number is an ASCII character." } ; + +HELP: ch>lower +{ $values { "ch" "a character" } { "lower" "a character" } } +{ $description "Converts an ASCII character to lower case." } ; + +HELP: ch>upper +{ $values { "ch" "a character" } { "upper" "a character" } } +{ $description "Converts an ASCII character to upper case." } ; + +HELP: >lower +{ $values { "str" "a string" } { "lower" "a string" } } +{ $description "Converts an ASCII string to lower case." } ; + +HELP: >upper +{ $values { "str" "a string" } { "upper" "a string" } } +{ $description "Converts an ASCII string to upper case." } ; + ARTICLE: "ascii" "ASCII character classes" "The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:" { $subsection blank? } @@ -46,6 +66,12 @@ ARTICLE: "ascii" "ASCII character classes" { $subsection printable? } { $subsection control? } { $subsection quotable? } -"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ; +{ $subsection ascii? } +"ASCII case conversion is also implemented:" +{ $subsection ch>lower } +{ $subsection ch>upper } +{ $subsection >lower } +{ $subsection >upper } +"Modern applications should use Unicode 5.1 instead (" { $vocab-link "unicode.categories" } ")." ; ABOUT: "ascii" diff --git a/basis/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor index 7dacce734b..6f39b32a01 100644 --- a/basis/ascii/ascii-tests.factor +++ b/basis/ascii/ascii-tests.factor @@ -12,3 +12,8 @@ IN: ascii.tests 0 "There are Four Upper Case characters" [ LETTER? [ 1+ ] when ] each ] unit-test + +[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test + +[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test +[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor index c009c66cde..a64a7b8eb5 100644 --- a/basis/ascii/ascii.factor +++ b/basis/ascii/ascii.factor @@ -4,6 +4,8 @@ USING: kernel math math.order sequences combinators.short-circuit ; IN: ascii +: ascii? ( ch -- ? ) 0 127 between? ; inline + : blank? ( ch -- ? ) " \t\n\r" member? ; inline : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline @@ -25,3 +27,15 @@ IN: ascii : alpha? ( ch -- ? ) [ [ Letter? ] [ digit? ] ] 1|| ; + +: ch>lower ( ch -- lower ) + dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ; + +: >lower ( str -- lower ) + [ ch>lower ] map ; + +: ch>upper ( ch -- upper ) + dup CHAR: a CHAR: z between? [ HEX: 20 - ] when ; + +: >upper ( str -- upper ) + [ ch>upper ] map ; diff --git a/basis/regexp/nfa/nfa.factor b/basis/regexp/nfa/nfa.factor index 7620652948..dd116f3d7a 100644 --- a/basis/regexp/nfa/nfa.factor +++ b/basis/regexp/nfa/nfa.factor @@ -3,7 +3,10 @@ USING: accessors arrays assocs grouping kernel regexp.backend locals math namespaces regexp.parser sequences fry quotations math.order math.ranges vectors unicode.categories regexp.utils -regexp.transition-tables words sets regexp.classes unicode.case ; +regexp.transition-tables words sets regexp.classes unicode.case.private ; +! This uses unicode.case.private for ch>upper and ch>lower +! but case-insensitive matching should be done by case-folding everything +! before processing starts IN: regexp.nfa SYMBOL: negation-mode @@ -160,6 +163,8 @@ M: LETTER-class nfa-node ( node -- ) M: character-class-range nfa-node ( node -- ) case-insensitive option? [ + ! This should be implemented for Unicode by case-folding + ! the input and all strings in the regexp. dup [ from>> ] [ to>> ] bi 2dup [ Letter? ] bi@ and [ rot drop diff --git a/basis/regexp/parser/parser.factor b/basis/regexp/parser/parser.factor index 25509ec798..2f397538a0 100644 --- a/basis/regexp/parser/parser.factor +++ b/basis/regexp/parser/parser.factor @@ -3,8 +3,8 @@ USING: accessors arrays assocs combinators io io.streams.string kernel math math.parser namespaces sets quotations sequences splitting vectors math.order -unicode.categories strings regexp.backend regexp.utils -unicode.case words locals regexp.classes ; +strings regexp.backend regexp.utils +unicode.case unicode.categories words locals regexp.classes ; IN: regexp.parser FROM: math.ranges => [a,b] ; @@ -261,7 +261,7 @@ ERROR: bad-escaped-literals seq ; parse-til-E drop1 [ epsilon ] [ - [ quot call ] V{ } map-as + quot call [ ] V{ } map-as first|concatenation ] if-empty ; inline @@ -269,10 +269,10 @@ ERROR: bad-escaped-literals seq ; [ ] (parse-escaped-literals) ; : lower-case-literals ( -- obj ) - [ ch>lower ] (parse-escaped-literals) ; + [ >lower ] (parse-escaped-literals) ; : upper-case-literals ( -- obj ) - [ ch>upper ] (parse-escaped-literals) ; + [ >upper ] (parse-escaped-literals) ; : parse-escaped ( -- obj ) read1 diff --git a/basis/soundex/soundex.factor b/basis/soundex/soundex.factor index 416ec4a6bc..164f634185 100644 --- a/basis/soundex/soundex.factor +++ b/basis/soundex/soundex.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences grouping assocs kernel ascii unicode.case tr ; +USING: sequences grouping assocs kernel ascii ascii tr ; IN: soundex TR: soundex-tr diff --git a/basis/tr/tr-tests.factor b/basis/tr/tr-tests.factor index c168f5384d..3434c28216 100644 --- a/basis/tr/tr-tests.factor +++ b/basis/tr/tr-tests.factor @@ -1,5 +1,5 @@ IN: tr.tests -USING: tr tools.test unicode.case ; +USING: tr tools.test ascii ; TR: tr-test ch>upper "ABC" "XYZ" ; diff --git a/basis/tr/tr.factor b/basis/tr/tr.factor index 66d8df7d44..ce535f335a 100644 --- a/basis/tr/tr.factor +++ b/basis/tr/tr.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays strings sequences sequences.private +USING: byte-arrays strings sequences sequences.private ascii fry kernel words parser lexer assocs math math.order summary ; IN: tr @@ -11,8 +11,6 @@ M: bad-tr summary lower } { $subsection >title } { $subsection >case-fold } -"There are analogous routines which operate on individual code points, but these should " { $emphasis "not be used" } " in general as they have slightly different behavior. In some cases, for example, they do not perform the case operation, as a single code point must expand to more than one." -{ $subsection ch>upper } -{ $subsection ch>lower } -{ $subsection ch>title } "To test if a string is in a given case:" { $subsection upper? } { $subsection lower? } @@ -53,18 +49,3 @@ HELP: title? HELP: case-fold? { $values { "string" string } { "?" "a boolean" } } { $description "Tests if a string is in case-folded form." } ; - -HELP: ch>lower -{ $values { "ch" "a code point" } { "lower" "a code point" } } -{ $description "Converts a code point to lower case." } -{ $warning "Don't use this unless you know what you're doing! " { $code ">lower" } " is not the same as " { $code "[ ch>lower ] map" } "." } ; - -HELP: ch>upper -{ $values { "ch" "a code point" } { "upper" "a code point" } } -{ $description "Converts a code point to upper case." } -{ $warning "Don't use this unless you know what you're doing! " { $code ">upper" } " is not the same as " { $code "[ ch>upper ] map" } "." } ; - -HELP: ch>title -{ $values { "ch" "a code point" } { "title" "a code point" } } -{ $description "Converts a code point to title case." } -{ $warning "Don't use this unless you know what you're doing! " { $code ">title" } " is not the same as " { $code "[ ch>title ] map" } "." } ; diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 99278cd72e..c800205704 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -7,11 +7,11 @@ IN: unicode.case : ch>lower ( ch -- lower ) simple-lower at-default ; : ch>upper ( ch -- upper ) simple-upper at-default ; : ch>title ( ch -- title ) simple-title at-default ; +PRIVATE> SYMBOL: locale ! Just casing locale, or overall? diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 61a93d9375..6cf913bffa 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -128,12 +128,9 @@ VALUE: properties cat categories index char table ?set-nth ] assoc-each table fill-ranges ] ; -: ascii-lower ( string -- lower ) - [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; - : process-names ( data -- names-hash ) 1 swap (process-data) [ - ascii-lower { { CHAR: \s CHAR: - } } substitute swap + >lower { { CHAR: \s CHAR: - } } substitute swap ] H{ } assoc-map-as ; : multihex ( hexstring -- string ) diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index c8d0eb3f7d..2fbe2e1843 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces make unicode.data kernel math arrays -locals sorting.insertion accessors assocs math.order combinators ; +locals sorting.insertion accessors assocs math.order combinators +unicode.syntax ; IN: unicode.normalize upper "ACGTUMRYKVHDB" "TGCAAKYRMBDHV" ; diff --git a/extra/parser-combinators/regexp/regexp.factor b/extra/parser-combinators/regexp/regexp.factor index 2becd937f2..1c94308e93 100755 --- a/extra/parser-combinators/regexp/regexp.factor +++ b/extra/parser-combinators/regexp/regexp.factor @@ -2,7 +2,7 @@ USING: arrays combinators kernel lists math math.parser namespaces parser lexer parser-combinators parser-combinators.simple promises quotations sequences strings math.order assocs prettyprint.backend prettyprint.custom memoize -unicode.case unicode.categories combinators.short-circuit +ascii unicode.categories combinators.short-circuit accessors make io ; IN: parser-combinators.regexp From a889b9d2d097a039099d3e68049a44ee449ff63c Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 9 Jan 2009 03:45:04 +0100 Subject: [PATCH 31/56] FUEL: Nicer autodoc error messages. --- misc/fuel/factor-mode.el | 2 +- misc/fuel/fuel-autodoc.el | 5 ++++- misc/fuel/fuel-connection.el | 8 ++++---- 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/misc/fuel/factor-mode.el b/misc/fuel/factor-mode.el index 394f6c41f9..d3a633910c 100644 --- a/misc/fuel/factor-mode.el +++ b/misc/fuel/factor-mode.el @@ -241,7 +241,7 @@ code in the buffer." (defun factor-mode-insert-and-indent (n) (interactive "p") (self-insert-command n) - (indent-for-tab-command)) + (indent-according-to-mode)) (defvar factor-mode-map (let ((map (make-sparse-keymap))) diff --git a/misc/fuel/fuel-autodoc.el b/misc/fuel/fuel-autodoc.el index 53b5228965..76919702bb 100644 --- a/misc/fuel/fuel-autodoc.el +++ b/misc/fuel/fuel-autodoc.el @@ -57,7 +57,10 @@ (defun fuel-autodoc--eldoc-function () (or (and fuel-autodoc--fallback-function (funcall fuel-autodoc--fallback-function)) - (fuel-autodoc--word-synopsis))) + (condition-case e + (fuel-autodoc--word-synopsis) + (error (format "Autodoc not available (%s)" + (error-message-string e)))))) ;;; Autodoc mode: diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 11b135d0f7..f9cc1fb0f3 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -232,11 +232,12 @@ ;;; Message sending interface: +(defconst fuel-con--error-message "FUEL connection not active") + (defun fuel-con--send-string (buffer/proc str cont &optional sender-buffer) (save-current-buffer (let ((con (fuel-con--get-connection buffer/proc))) - (unless con - (error "FUEL: no connection")) + (unless con (error fuel-con--error-message)) (let ((req (fuel-con--make-request str cont sender-buffer))) (fuel-con--connection-queue-request con req) (fuel-con--process-next con) @@ -248,8 +249,7 @@ (defun fuel-con--send-string/wait (buffer/proc str cont &optional timeout sbuf) (save-current-buffer (let ((con (fuel-con--get-connection buffer/proc))) - (unless con - (error "FUEL: no connection")) + (unless con (error fuel-con--error-message)) (let* ((req (fuel-con--send-string buffer/proc str cont sbuf)) (id (and req (fuel-con--request-id req))) (time (or timeout fuel-connection-timeout)) From 58df6dad6f44ce45d5182a594d91e60f475ca42e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 22:23:39 -0600 Subject: [PATCH 32/56] Unicode cleanup and optimization --- basis/unicode/breaks/breaks.factor | 22 ++++++++++++---------- basis/unicode/normalize/normalize.factor | 13 ++++++------- 2 files changed, 18 insertions(+), 17 deletions(-) diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 1d2f821750..df3b2f03e8 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -192,22 +192,22 @@ to: word-table : word-table-nth ( class1 class2 -- ? ) word-table nth nth ; -: property-not= ( i str property -- ? ) - pick [ - [ ?nth ] dip swap - [ word-break-prop = not ] [ drop f ] if* - ] [ 3drop t ] if ; +:: property-not= ( i str property -- ? ) + i [ + i str ?nth [ word-break-prop property = not ] + [ f ] if* + ] [ t ] if ; : format/extended? ( ch -- ? ) word-break-prop { 4 5 } member? ; :: walk-up ( str i -- j ) i 1 + str [ format/extended? not ] find-from drop - 1+ str [ format/extended? not ] find-from drop ; ! possible bounds error? + [ 1+ str [ format/extended? not ] find-from drop ] [ f ] if* ; :: walk-down ( str i -- j ) i str [ format/extended? not ] find-last-from drop - 1- str [ format/extended? not ] find-last-from drop ; ! possible bounds error? + [ 1- str [ format/extended? not ] find-last-from drop ] [ f ] if* ; :: word-break? ( table-entry i str -- ? ) table-entry { @@ -224,9 +224,11 @@ to: word-table } case ; :: word-break-next ( old-class new-char i str -- next-class ? ) - new-char word-break-prop dup { 4 5 } member? - [ drop old-class dup { 1 2 3 } member? ] - [ old-class over word-table-nth i str word-break? ] if ; + new-char dup format/extended? + [ drop old-class dup { 1 2 3 } member? ] [ + word-break-prop old-class over word-table-nth + i str word-break? + ] if ; PRIVATE> diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 2fbe2e1843..7a41a768cd 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: sequences namespaces make unicode.data kernel math arrays locals sorting.insertion accessors assocs math.order combinators -unicode.syntax ; +unicode.syntax strings sbufs ; IN: unicode.normalize ] | string [ - dup hangul? [ hangul>jamo % ] - [ dup quot call [ % ] [ , ] ?if ] if - ] each - ] "" make - dup reorder ; + dup hangul? [ hangul>jamo out push-all ] + [ dup quot call [ out push-all ] [ out push ] ?if ] if + ] each out >string + ] dup reorder ; : with-string ( str quot -- str ) over aux>> [ call ] [ drop ] if ; inline From 8d8efb6dcedb4be96b0f67eb2d89743d77a6a549 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 8 Jan 2009 22:49:24 -0600 Subject: [PATCH 33/56] Fixing Unicode bootstrap issue (hopefully) --- basis/bootstrap/unicode/unicode.factor | 5 ----- basis/unicode/case/case.factor | 2 +- basis/unicode/data/data.factor | 6 +++++- 3 files changed, 6 insertions(+), 7 deletions(-) diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor index 1e9f8b8642..e69de29bb2 100644 --- a/basis/bootstrap/unicode/unicode.factor +++ b/basis/bootstrap/unicode/unicode.factor @@ -1,5 +0,0 @@ -USING: strings.parser kernel namespaces unicode unicode.data ; -IN: bootstrap.unicode - -[ name>char [ "Invalid character" throw ] unless* ] -name>char-hook set-global diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index c800205704..773bbeed5f 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data sequences sequences.next namespaces make +USING: unicode.data sequences sequences.next namespaces make unicode.syntax unicode.normalize math unicode.categories combinators unicode.syntax assocs strings splitting kernel accessors unicode.breaks fry ; IN: unicode.case diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 6cf913bffa..e78b4c104a 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -4,7 +4,8 @@ USING: combinators.short-circuit assocs math kernel sequences io.files hashtables quotations splitting grouping arrays io math.parser hash2 math.order byte-arrays words namespaces words compiler.units parser io.encodings.ascii values interval-maps -ascii sets combinators locals math.ranges sorting make io.encodings.utf8 ; +ascii sets combinators locals math.ranges sorting make +strings.parser io.encodings.utf8 ; IN: unicode.data VALUE: simple-lower @@ -218,3 +219,6 @@ SYMBOL: interned : load-script ( filename -- table ) ascii parse-script process-script ; + +[ name>char [ "Invalid character" throw ] unless* ] +name>char-hook set-global From e661c67189bd27ae64977ef4f54386db9bec3d8d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 8 Jan 2009 23:09:38 -0600 Subject: [PATCH 34/56] refactor a word to use smart combinators --- .../tree/propagation/inlining/inlining.factor | 24 ++++++++++--------- 1 file changed, 13 insertions(+), 11 deletions(-) diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index bd6d657442..7b3135e85c 100644 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -3,7 +3,7 @@ USING: accessors kernel arrays sequences math math.order math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators -words namespaces continuations classes fry +words namespaces continuations classes fry combinators.smart compiler.tree compiler.tree.builder compiler.tree.recursive @@ -134,17 +134,19 @@ DEFER: (flat-length) over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ; : inlining-rank ( #call word -- n ) - [ classes-known? 2 0 ? ] [ - { - [ body-length-bias ] - [ "default" word-prop -4 0 ? ] - [ "specializer" word-prop 1 0 ? ] - [ method-body? 1 0 ? ] - } cleave - node-count-bias - loop-nesting get 0 or 2 * - ] bi* + + + + + + ; + [ classes-known? 2 0 ? ] + [ + { + [ body-length-bias ] + [ "default" word-prop -4 0 ? ] + [ "specializer" word-prop 1 0 ? ] + [ method-body? 1 0 ? ] + } cleave + node-count-bias + loop-nesting get 0 or 2 * + ] bi* + ] sum-outputs ; : should-inline? ( #call word -- ? ) dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ; From 1ed964e53989341a94875dcf5d547dbba9b158e9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 9 Jan 2009 14:03:33 -0600 Subject: [PATCH 35/56] Speeding up normalization --- basis/unicode/case/case.factor | 57 ++++--- .../unicode/normalize/normalize-tests.factor | 2 + basis/unicode/normalize/normalize.factor | 146 ++++++++++-------- 3 files changed, 114 insertions(+), 91 deletions(-) diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 773bbeed5f..555a39ac88 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,16 +1,18 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data sequences sequences.next namespaces make unicode.syntax -unicode.normalize math unicode.categories combinators unicode.syntax -assocs strings splitting kernel accessors unicode.breaks fry ; +USING: unicode.data sequences sequences.next namespaces +sbufs make unicode.syntax unicode.normalize math hints +unicode.categories combinators unicode.syntax assocs +strings splitting kernel accessors unicode.breaks fry locals ; +QUALIFIED: ascii IN: unicode.case lower ( ch -- lower ) simple-lower at-default ; -: ch>upper ( ch -- upper ) simple-upper at-default ; -: ch>title ( ch -- title ) simple-title at-default ; +: ch>lower ( ch -- lower ) simple-lower at-default ; inline +: ch>upper ( ch -- upper ) simple-upper at-default ; inline +: ch>title ( ch -- title ) simple-title at-default ; inline PRIVATE> SYMBOL: locale ! Just casing locale, or overall? @@ -21,7 +23,7 @@ SYMBOL: locale ! Just casing locale, or overall? [ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ; : replace ( old new str -- newstr ) - [ split-subseq ] dip join ; + [ split-subseq ] dip join ; inline : i-dot? ( -- ? ) locale get { "tr" "az" } member? ; @@ -44,24 +46,24 @@ SYMBOL: locale ! Just casing locale, or overall? [ [ "" ] [ dup first mark-above? [ CHAR: combining-dot-above prefix ] when - ] if-empty ] with-rest ; + ] if-empty ] with-rest ; inline : lithuanian>lower ( string -- lower ) "i" split add-dots "i" join - "j" split add-dots "i" join ; + "j" split add-dots "i" join ; inline : turk>upper ( string -- upper-i ) - "i" "I\u000307" replace ; + "i" "I\u000307" replace ; inline : turk>lower ( string -- lower-i ) "I\u000307" "i" replace - "I" "\u000131" replace ; + "I" "\u000131" replace ; inline : fix-sigma-end ( string -- string ) [ "" ] [ dup peek CHAR: greek-small-letter-sigma = [ 1 head* CHAR: greek-small-letter-final-sigma suffix ] when - ] if-empty ; + ] if-empty ; inline : sigma-map ( string -- string ) { CHAR: greek-capital-letter-sigma } split [ [ @@ -70,19 +72,20 @@ SYMBOL: locale ! Just casing locale, or overall? CHAR: greek-small-letter-final-sigma CHAR: greek-small-letter-sigma ? prefix ] if-empty - ] map ] with-rest concat fix-sigma-end ; + ] map ] with-rest concat fix-sigma-end ; inline : final-sigma ( string -- string ) CHAR: greek-capital-letter-sigma - over member? [ sigma-map ] when ; + over member? [ sigma-map ] when + "" like ; inline -: map-case ( string string-quot char-quot -- case ) - [ - [ - [ dup special-casing at ] 2dip - [ [ % ] compose ] [ [ , ] compose ] bi* ?if - ] 2curry each - ] "" make ; inline +:: map-case ( string string-quot char-quot -- case ) + string length :> out + string [ + dup special-casing at + [ string-quot call out push-all ] + [ char-quot call out push ] ?if + ] each out "" like ; inline PRIVATE> @@ -90,24 +93,30 @@ PRIVATE> i-dot? [ turk>lower ] when final-sigma [ lower>> ] [ ch>lower ] map-case ; +HINTS: >lower string ; + : >upper ( string -- upper ) i-dot? [ turk>upper ] when [ upper>> ] [ ch>upper ] map-case ; +HINTS: >upper string ; + title) ( string -- title ) i-dot? [ turk>upper ] when - [ title>> ] [ ch>title ] map-case ; + [ title>> ] [ ch>title ] map-case ; inline : title-word ( string -- title ) - unclip 1string [ >lower ] [ (>title) ] bi* prepend ; + unclip 1string [ >lower ] [ (>title) ] bi* prepend ; inline PRIVATE> : >title ( string -- title ) final-sigma >words [ title-word ] map concat ; +HINTS: >title string ; + : >case-fold ( string -- fold ) >upper >lower ; diff --git a/basis/unicode/normalize/normalize-tests.factor b/basis/unicode/normalize/normalize-tests.factor index 25d5ce365c..1242e1d358 100644 --- a/basis/unicode/normalize/normalize-tests.factor +++ b/basis/unicode/normalize/normalize-tests.factor @@ -3,6 +3,8 @@ unicode.data io.encodings.utf8 io.files splitting math.parser locals math quotations assocs combinators unicode.normalize.private ; IN: unicode.normalize.tests +{ nfc nfkc nfd nfkd } [ must-infer ] each + [ "ab\u000323\u000302cd" ] [ "ab\u000302" "\u000323cd" string-append ] unit-test [ "ab\u00064b\u000347\u00034e\u00034d\u000346" ] [ "ab\u000346\u000347\u00064b\u00034e\u00034d" dup reorder ] unit-test diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 7a41a768cd..f7aa248028 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences namespaces make unicode.data kernel math arrays +USING: ascii sequences namespaces make unicode.data kernel math arrays locals sorting.insertion accessors assocs math.order combinators -unicode.syntax strings sbufs ; +unicode.syntax strings sbufs hints combinators.short-circuit vectors ; IN: unicode.normalize jamo ( hangul -- jamo-string ) hangul-base - final-count /mod final-base + @@ -48,16 +48,16 @@ CONSTANT: final-count 28 : reorder-slice ( string start -- slice done? ) 2dup swap [ non-starter? not ] find-from drop - [ [ over length ] unless* rot ] keep not ; + [ [ over length ] unless* rot ] keep not ; inline : reorder-next ( string i -- new-i done? ) over [ non-starter? ] find-from drop [ reorder-slice [ dup [ combining-class ] insertion-sort to>> ] dip - ] [ length t ] if* ; + ] [ length t ] if* ; inline : reorder-loop ( string start -- ) - dupd reorder-next [ 2drop ] [ reorder-loop ] if ; + dupd reorder-next [ 2drop ] [ reorder-loop ] if ; inline recursive : reorder ( string -- ) 0 reorder-loop ; @@ -66,12 +66,14 @@ CONSTANT: final-count 28 over [ non-starter? not ] find-last-from drop ?1+ reorder-next 2drop ; :: decompose ( string quot -- decomposed ) - [let | out [ string length ] | - string [ + string length :> out + string [ + >fixnum dup ascii? [ out push ] [ dup hangul? [ hangul>jamo out push-all ] [ dup quot call [ out push-all ] [ out push ] ?if ] if - ] each out >string - ] dup reorder ; + ] if + ] each + out "" like dup reorder ; inline : with-string ( str quot -- str ) over aux>> [ call ] [ drop ] if ; inline @@ -79,9 +81,13 @@ CONSTANT: final-count 28 : (nfd) ( string -- nfd ) [ canonical-entry ] decompose ; +HINTS: (nfd) string ; + : (nfkd) ( string -- nfkd ) [ compatibility-entry ] decompose ; +HINTS: (nfkd) string ; + PRIVATE> : nfd ( string -- nfd ) @@ -95,83 +101,89 @@ PRIVATE> 0 over ?nth non-starter? [ length dupd reorder-back ] [ drop ] if ; +HINTS: string-append string string ; + hangul , ] + [ 3 + ] 2bi ; -: imf, ( -- ) - current to current to current jamo>hangul , ; +: im, ( str i -- str i ) + [ tail-slice first2 final-base jamo>hangul , ] + [ 2 + ] 2bi ; -: im, ( -- ) - current to current final-base jamo>hangul , ; +: compose-jamo ( str i -- str i ) + 2dup initial-medial? [ + 2dup --final? [ imf, ] [ im, ] if + ] [ 2dup swap nth , 1+ ] if ; -: compose-jamo ( -- ) - initial-medial? [ - --final? [ imf, ] [ im, ] if - ] [ current , ] if to ; +: pass-combining ( str -- str i ) + dup [ non-starter? not ] find drop + [ dup length ] unless* + 2dup head-slice % ; -: pass-combining ( -- ) - current non-starter? [ current , to pass-combining ] when ; +TUPLE: compose-state i str char after last-class ; -:: try-compose ( last-class new-char current-class -- new-class ) - last-class current-class = [ new-char after get push last-class ] [ - char get new-char combine-chars - [ char set last-class ] - [ new-char after get push current-class ] if* +: get-str ( state i -- ch ) + swap [ i>> + ] [ str>> ] bi ?nth ; +: current ( state -- ch ) 0 get-str ; +: to ( state -- state ) [ 1+ ] change-i ; +: push-after ( ch state -- state ) [ ?push ] change-after ; + +:: try-compose ( state new-char current-class -- state ) + state last-class>> current-class = + [ new-char state push-after ] [ + state char>> new-char combine-chars + [ state swap >>char ] [ + new-char state push-after + current-class >>last-class + ] if* ] if ; DEFER: compose-iter -: try-noncombining ( char -- ) - char get swap combine-chars - [ char set to f compose-iter ] when* ; +: try-noncombining ( char state -- state ) + tuck char>> swap combine-chars + [ >>char to f >>last-class compose-iter ] when* ; -: compose-iter ( last-class -- ) - current [ +: compose-iter ( state -- state ) + dup current [ dup combining-class { - { f [ 2drop ] } - { 0 [ swap [ drop ] [ try-noncombining ] if ] } + { f [ drop ] } + { 0 [ + over last-class>> + [ drop ] [ swap try-noncombining ] if ] } [ try-compose to compose-iter ] } case - ] [ drop ] if* ; + ] when* ; -: ?new-after ( -- ) - after [ dup empty? [ drop SBUF" " clone ] unless ] change ; +: compose-combining ( ch str i -- str i ) + compose-state new + swap >>i + swap >>str + swap >>char + compose-iter + { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; -: compose-combining ( ch -- ) - char set to ?new-after - f compose-iter - char get , after get % ; - -: (compose) ( -- ) - current [ - dup jamo? [ drop compose-jamo ] [ - 1 get-str combining-class - [ compose-combining ] [ , to ] if +:: (compose) ( str i -- ) + i str ?nth [ + dup jamo? [ drop str i compose-jamo ] [ + i 1+ str ?nth combining-class + [ str i 1+ compose-combining ] [ , str i 1+ ] if ] if (compose) ] when* ; : combine ( str -- comp ) - [ - main-str set - 0 ind set - SBUF" " clone after set - pass-combining (compose) - ] "" make ; + [ pass-combining (compose) ] "" make ; PRIVATE> From 69e4fe1f766ee410567c4b86741f3fe499adf9df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 14:31:02 -0600 Subject: [PATCH 36/56] fix bootstrap on a couple platforms --- basis/io/files/info/unix/freebsd/freebsd.factor | 2 +- basis/io/files/info/unix/linux/linux.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/info/unix/freebsd/freebsd.factor b/basis/io/files/info/unix/freebsd/freebsd.factor index 398e4ff968..11025e14e6 100644 --- a/basis/io/files/info/unix/freebsd/freebsd.factor +++ b/basis/io/files/info/unix/freebsd/freebsd.factor @@ -3,7 +3,7 @@ USING: accessors alien.c-types alien.syntax combinators io.backend io.files io.files.info io.files.unix kernel math system unix unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd -sequences grouping alien.strings io.encodings.utf8 +sequences grouping alien.strings io.encodings.utf8 unix.types specialized-arrays.direct.uint arrays io.files.info.unix ; IN: io.files.info.unix.freebsd diff --git a/basis/io/files/info/unix/linux/linux.factor b/basis/io/files/info/unix/linux/linux.factor index 60313b3306..b447b6e54f 100644 --- a/basis/io/files/info/unix/linux/linux.factor +++ b/basis/io/files/info/unix/linux/linux.factor @@ -5,7 +5,7 @@ io.backend io.encodings.utf8 io.files io.files.info io.streams.string io.files.unix kernel math.order namespaces sequences sorting system unix unix.statfs.linux unix.statvfs.linux io.files.links specialized-arrays.direct.uint arrays io.files.info.unix assocs -io.pathnames ; +io.pathnames unix.types ; IN: io.files.info.unix.linux TUPLE: linux-file-system-info < unix-file-system-info From fe2a43b481a93170bc38666d0b6cdf89d5862f21 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 14:41:00 -0600 Subject: [PATCH 37/56] fix bootstrap --- basis/unix/statfs/freebsd/freebsd.factor | 2 +- basis/unix/statfs/linux/linux.factor | 2 +- basis/unix/statfs/macosx/macosx.factor | 3 ++- basis/unix/statfs/openbsd/openbsd.factor | 2 +- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index e6a033e09d..efd12b7d6c 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax unix.types ; IN: unix.statfs.freebsd CONSTANT: MFSNAMELEN 16 ! length of type name including null */ diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 6550ee572e..20688680fb 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax unix.types ; IN: unix.statfs.linux C-STRUCT: statfs64 diff --git a/basis/unix/statfs/macosx/macosx.factor b/basis/unix/statfs/macosx/macosx.factor index f80eb29ccd..c262949730 100644 --- a/basis/unix/statfs/macosx/macosx.factor +++ b/basis/unix/statfs/macosx/macosx.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types io.encodings.utf8 io.encodings.string kernel sequences unix.stat accessors unix combinators math -grouping system alien.strings math.bitwise alien.syntax ; +grouping system alien.strings math.bitwise alien.syntax +unix.types ; IN: unix.statfs.macosx CONSTANT: MNT_RDONLY HEX: 00000001 diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index f495f2af4e..456883514a 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.syntax unix.types ; IN: unix.statfs.openbsd CONSTANT: MFSNAMELEN 16 From c8fe4b21e7d56088a9f8145078f603a9ebce94f5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 15:39:47 -0600 Subject: [PATCH 38/56] Rename reduce-output -> reduce-outputs --- basis/combinators/smart/smart-docs.factor | 6 +++--- basis/combinators/smart/smart-tests.factor | 4 ++-- basis/combinators/smart/smart.factor | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor index 69ec3e7013..3df709c9fa 100644 --- a/basis/combinators/smart/smart-docs.factor +++ b/basis/combinators/smart/smart-docs.factor @@ -48,7 +48,7 @@ HELP: output>sequence } } ; -HELP: reduce-output +HELP: reduce-outputs { $values { "quot" quotation } { "operation" quotation } { "newquot" quotation } @@ -57,7 +57,7 @@ HELP: reduce-output { $examples { $example "USING: combinators.smart kernel math prettyprint ;" - "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-output ." + "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ." "-9" } } ; @@ -84,7 +84,7 @@ ARTICLE: "combinators.smart" "Smart combinators" { $subsection output>sequence } { $subsection output>array } "Reducing the output of a quotation:" -{ $subsection reduce-output } +{ $subsection reduce-outputs } "Summing the output of a quotation:" { $subsection sum-outputs } ; diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 4be445e465..54c53477db 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -14,8 +14,8 @@ IN: combinators.smart.tests -[ 6 ] [ [ 1 2 3 ] [ + ] reduce-output ] unit-test +[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test -[ [ 1 2 3 ] [ + ] reduce-output ] must-infer +[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer [ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index fcd28aac74..7a68cb5c1c 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -15,8 +15,8 @@ MACRO: input> ] keep '[ _ firstn @ ] ; -MACRO: reduce-output ( quot operation -- newquot ) +MACRO: reduce-outputs ( quot operation -- newquot ) [ dup infer out>> 1 [-] ] dip n*quot compose ; : sum-outputs ( quot -- n ) - [ + ] reduce-output ; inline + [ + ] reduce-outputs ; inline From fb25d04061d595050533b9b98eceda8c7e74dfe1 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 9 Jan 2009 15:53:35 -0600 Subject: [PATCH 39/56] Optimizing and cleaning up unicode.breaks and unicode.normalize --- basis/unicode/breaks/breaks.factor | 127 +++++++++++------------ basis/unicode/normalize/normalize.factor | 20 ++-- 2 files changed, 72 insertions(+), 75 deletions(-) diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index df3b2f03e8..10bc235805 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -4,7 +4,8 @@ USING: combinators.short-circuit unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces make math.ranges unicode.normalize.private values io.encodings.ascii unicode.syntax unicode.data compiler.units fry -alien.syntax sets accessors interval-maps memoize locals words ; +alien.syntax sets accessors interval-maps memoize locals words +strings hints ; IN: unicode.breaks : first-grapheme ( str -- i ) unclip-slice grapheme-class over - [ grapheme-class tuck grapheme-break? ] find-index + [ grapheme-class tuck grapheme-break? ] find drop nip swap length or 1+ ; : last-grapheme ( str -- i ) unclip-last-slice grapheme-class swap - [ grapheme-class dup rot grapheme-break? ] find-last-index ?1+ nip ; + [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ; -:: first-word ( str -- i ) - str unclip-slice word-break-prop over - [ swap str word-break-next ] assoc-find 2drop - nip swap length or 1+ ; +: first-word ( str -- i ) + [ unclip-slice word-break-prop over ] keep + '[ swap _ word-break-next ] assoc-find 2drop + nip swap length or 1+ ; inline + +HINTS: first-word string ; : >words ( str -- words ) [ first-word ] >pieces ; + +HINTS: >words string ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index f7aa248028..892379dc89 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -134,10 +134,10 @@ HINTS: string-append string string ; TUPLE: compose-state i str char after last-class ; : get-str ( state i -- ch ) - swap [ i>> + ] [ str>> ] bi ?nth ; -: current ( state -- ch ) 0 get-str ; -: to ( state -- state ) [ 1+ ] change-i ; -: push-after ( ch state -- state ) [ ?push ] change-after ; + swap [ i>> + ] [ str>> ] bi ?nth ; inline +: current ( state -- ch ) 0 get-str ; inline +: to ( state -- state ) [ 1+ ] change-i ; inline +: push-after ( ch state -- state ) [ ?push ] change-after ; inline :: try-compose ( state new-char current-class -- state ) state last-class>> current-class = @@ -147,13 +147,13 @@ TUPLE: compose-state i str char after last-class ; new-char state push-after current-class >>last-class ] if* - ] if ; + ] if ; inline DEFER: compose-iter : try-noncombining ( char state -- state ) tuck char>> swap combine-chars - [ >>char to f >>last-class compose-iter ] when* ; + [ >>char to f >>last-class compose-iter ] when* ; inline : compose-iter ( state -- state ) dup current [ @@ -164,7 +164,7 @@ DEFER: compose-iter [ drop ] [ swap try-noncombining ] if ] } [ try-compose to compose-iter ] } case - ] when* ; + ] when* ; inline recursive : compose-combining ( ch str i -- str i ) compose-state new @@ -172,7 +172,7 @@ DEFER: compose-iter swap >>str swap >>char compose-iter - { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; + { [ char>> , ] [ after>> % ] [ str>> ] [ i>> ] } cleave ; inline :: (compose) ( str i -- ) i str ?nth [ @@ -180,11 +180,13 @@ DEFER: compose-iter i 1+ str ?nth combining-class [ str i 1+ compose-combining ] [ , str i 1+ ] if ] if (compose) - ] when* ; + ] when* ; inline recursive : combine ( str -- comp ) [ pass-combining (compose) ] "" make ; +HINTS: combine string ; + PRIVATE> : nfc ( string -- nfc ) From 7b36938e8c67db929b1a34b4ac6d7771fe442b18 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 16:07:16 -0600 Subject: [PATCH 40/56] use unix.stat to fix bootstrap --- basis/unix/statfs/freebsd/freebsd.factor | 2 +- basis/unix/statfs/linux/linux.factor | 2 +- basis/unix/statfs/openbsd/openbsd.factor | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/unix/statfs/freebsd/freebsd.factor b/basis/unix/statfs/freebsd/freebsd.factor index efd12b7d6c..70e2d5e561 100644 --- a/basis/unix/statfs/freebsd/freebsd.factor +++ b/basis/unix/statfs/freebsd/freebsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types ; +USING: alien.syntax unix.types unix.stat ; IN: unix.statfs.freebsd CONSTANT: MFSNAMELEN 16 ! length of type name including null */ diff --git a/basis/unix/statfs/linux/linux.factor b/basis/unix/statfs/linux/linux.factor index 20688680fb..c0db5ced1d 100644 --- a/basis/unix/statfs/linux/linux.factor +++ b/basis/unix/statfs/linux/linux.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types ; +USING: alien.syntax unix.types unix.stat ; IN: unix.statfs.linux C-STRUCT: statfs64 diff --git a/basis/unix/statfs/openbsd/openbsd.factor b/basis/unix/statfs/openbsd/openbsd.factor index 456883514a..60590be4ea 100644 --- a/basis/unix/statfs/openbsd/openbsd.factor +++ b/basis/unix/statfs/openbsd/openbsd.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax unix.types ; +USING: alien.syntax unix.types unix.stat ; IN: unix.statfs.openbsd CONSTANT: MFSNAMELEN 16 From e61acc5eee7f59d1b58746bc2b2624da773b3df7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 16:34:31 -0600 Subject: [PATCH 41/56] username -> user-name in a couple of places --- basis/io/files/unix/unix-tests.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/io/files/unix/unix-tests.factor b/basis/io/files/unix/unix-tests.factor index 48a128d862..003cb40621 100644 --- a/basis/io/files/unix/unix-tests.factor +++ b/basis/io/files/unix/unix-tests.factor @@ -117,12 +117,12 @@ prepare-test-file [ ] [ test-file f f 2array set-file-times ] unit-test -[ ] [ test-file real-username set-file-user ] unit-test +[ ] [ test-file real-user-name set-file-user ] unit-test [ ] [ test-file real-user-id set-file-user ] unit-test [ ] [ test-file real-group-name set-file-group ] unit-test [ ] [ test-file real-group-id set-file-group ] unit-test -[ t ] [ test-file file-username real-username = ] unit-test +[ t ] [ test-file file-user-name real-user-name = ] unit-test [ t ] [ test-file file-group-name real-group-name = ] unit-test [ ] From 2714de3b85c570e252226f7344081deb0c76a78c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 16:35:28 -0600 Subject: [PATCH 42/56] fix help-lint for values -- IN: scratchpad in an example --- basis/values/values-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/values/values-docs.factor b/basis/values/values-docs.factor index 59bf77da3a..df38869fbf 100644 --- a/basis/values/values-docs.factor +++ b/basis/values/values-docs.factor @@ -19,6 +19,7 @@ HELP: VALUE: { $examples { $example "USING: values math prettyprint ;" + "IN: scratchpad" "VALUE: x" "2 2 + to: x" "x ." From 56808874f1a32dc20f10b90201386cc44d6bd9b5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 15:28:10 -0600 Subject: [PATCH 43/56] fix group-name on netbsd --- basis/unix/groups/groups-docs.factor | 6 +++--- basis/unix/groups/groups-tests.factor | 2 ++ basis/unix/groups/groups.factor | 20 ++++++++++++-------- 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/basis/unix/groups/groups-docs.factor b/basis/unix/groups/groups-docs.factor index 18c2e2384a..07911bc96b 100644 --- a/basis/unix/groups/groups-docs.factor +++ b/basis/unix/groups/groups-docs.factor @@ -24,8 +24,8 @@ HELP: group-cache HELP: group-id { $values { "string" string } - { "id" integer } } -{ $description "Returns the group id given a group name." } ; + { "id/f" "an integer or f" } } +{ $description "Returns the group id given a group name. Returns " { $link f } " if the group does not exist." } ; HELP: group-name { $values @@ -36,7 +36,7 @@ HELP: group-name HELP: group-struct { $values { "obj" object } - { "group" "a group struct" } } + { "group/f" "a group struct or f" } } { $description "Returns an alien group struct to be turned into a group tuple by calling subsequent words." } ; HELP: real-group-id diff --git a/basis/unix/groups/groups-tests.factor b/basis/unix/groups/groups-tests.factor index 75f5d64b5f..2e989b32c0 100644 --- a/basis/unix/groups/groups-tests.factor +++ b/basis/unix/groups/groups-tests.factor @@ -27,3 +27,5 @@ IN: unix.groups.tests [ ] [ real-group-id group-name drop ] unit-test [ "888888888888888" ] [ 888888888888888 group-name ] unit-test +[ f ] +[ "please-oh-please-don't-have-a-group-named-this123lalala" group-struct ] unit-test diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 164afa46fb..371bec9a70 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -13,7 +13,7 @@ TUPLE: group id name passwd members ; SYMBOL: group-cache -GENERIC: group-struct ( obj -- group ) +GENERIC: group-struct ( obj -- group/f ) tuck 4096 [ ] keep f ; -M: integer group-struct ( id -- group ) - (group-struct) getgrgid_r io-error ; +: check-group-struct ( group-struct ptr -- group-struct/f ) + *void* [ drop f ] unless ; -M: string group-struct ( string -- group ) - (group-struct) getgrnam_r 0 = [ (io-error) ] unless ; +M: integer group-struct ( id -- group/f ) + (group-struct) [ getgrgid_r io-error ] keep check-group-struct ; + +M: string group-struct ( string -- group/f ) + (group-struct) [ getgrnam_r io-error ] keep check-group-struct ; : group-struct>group ( group-struct -- group ) [ \ group new ] dip @@ -43,14 +46,15 @@ PRIVATE> : group-name ( id -- string ) dup group-cache get [ + "yo" print dupd at* [ name>> nip ] [ drop number>string ] if ] [ - group-struct group-gr_name + group-struct [ group-gr_name ] [ f ] if* ] if* [ nip ] [ number>string ] if* ; -: group-id ( string -- id ) - group-struct group-gr_gid ; +: group-id ( string -- id/f ) + group-struct [ group-gr_gid ] [ f ] if* ; Date: Fri, 9 Jan 2009 15:34:46 -0600 Subject: [PATCH 44/56] display available-space for file-systems. --- basis/tools/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index e6ca02d5f9..9066f3a219 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -65,7 +65,7 @@ percent-used percent-free ; [ [ unparse ] map ] bi prefix simple-table. ; : file-systems. ( -- ) - { device-name free-space used-space total-space percent-used mount-point } + { device-name available-space free-space used-space total-space percent-used mount-point } print-file-systems ; { From b08e1a02053aa82562db62b059362a27750c280b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 17:44:21 -0600 Subject: [PATCH 45/56] remove debug line --- basis/unix/groups/groups.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index 371bec9a70..f4d91df245 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -46,7 +46,6 @@ PRIVATE> : group-name ( id -- string ) dup group-cache get [ - "yo" print dupd at* [ name>> nip ] [ drop number>string ] if ] [ group-struct [ group-gr_name ] [ f ] if* From b149a012482623dc3f7b11c886ef2ec25c924abf Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 10 Jan 2009 00:55:39 +0100 Subject: [PATCH 46/56] FUEL: Better syntax highlighting. --- misc/fuel/fuel-font-lock.el | 11 +++-- misc/fuel/fuel-syntax.el | 80 +++++++++++++++++++++++++++---------- 2 files changed, 68 insertions(+), 23 deletions(-) diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el index d4ce88cf20..45fd0758d5 100644 --- a/misc/fuel/fuel-font-lock.el +++ b/misc/fuel/fuel-font-lock.el @@ -54,6 +54,7 @@ factor-font-lock font-lock factor-mode ((comment comment "comments") (constructor type "constructors ()") + (constant constant "constants and literal values") (declaration keyword "declaration words") (parsing-word keyword "parsing words") (setter-word function-name "setter words (>>foo)") @@ -73,17 +74,21 @@ (,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word) ("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word) (,fuel-syntax--stack-effect-regex . 'factor-font-lock-stack-effect) + (,fuel-syntax--vocab-ref-regexp 2 'factor-font-lock-vocabulary-name) (,fuel-syntax--declaration-words-regex . 'factor-font-lock-declaration) (,fuel-syntax--word-definition-regex 2 'factor-font-lock-word) + (,fuel-syntax--alias-definition-regex (1 'factor-font-lock-word) + (2 'factor-font-lock-word)) + (,fuel-syntax--int-constant-def-regex 2 'factor-font-lock-constant) + (,fuel-syntax--number-regex . 'factor-font-lock-constant) (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name) (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name) (2 'factor-font-lock-word)) - (,fuel-syntax--parent-type-regex 1 'factor-font-lock-type-name) + (,fuel-syntax--parent-type-regex 2 'factor-font-lock-type-name) (,fuel-syntax--constructor-regex . 'factor-font-lock-constructor) (,fuel-syntax--setter-regex . 'factor-font-lock-setter-word) (,fuel-syntax--getter-regex . 'factor-font-lock-getter-word) - (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol) - (,fuel-syntax--use-line-regex 1 'factor-font-lock-vocabulary-name)) + (,fuel-syntax--symbol-definition-regex 2 'factor-font-lock-symbol)) "Font lock keywords definition for Factor mode.") (defun fuel-font-lock--font-lock-setup (&optional keywords no-syntax) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index e1981eff47..49e7788b2f 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -44,16 +44,24 @@ (defconst fuel-syntax--parsing-words '(":" "::" ";" "<<" ">" - "B" "BIN:" "C:" "C-STRUCT:" "C-UNION:" "CHAR:" - "DEFER:" "ERROR:" "EXCLUDE:" "FORGET:" - "GENERIC#" "GENERIC:" "HEX:" "HOOK:" - "IN:" "INSTANCE:" "INTERSECTION:" + "ALIAS:" + "B" "BIN:" + "C:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method" + "DEFER:" + "ERROR:" "EXCLUDE:" + "f" "FORGET:" "FROM:" + "GENERIC#" "GENERIC:" + "HEX:" "HOOK:" + "IN:" "initial:" "INSTANCE:" "INTERSECTION:" "M:" "MACRO:" "MACRO::" "MAIN:" "MATH:" "MEMO:" "MEMO:" "METHOD:" "MIXIN:" - "OCT:" "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" - "REQUIRE:" "REQUIRES:" "SINGLETON:" "SLOT:" "SYMBOL:" "SYMBOLS:" + "OCT:" + "POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:" + "QUALIFIED-WITH:" "QUALIFIED:" + "read-only" "RENAME:" "REQUIRE:" "REQUIRES:" + "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "TUPLE:" "t" "t?" "TYPEDEF:" - "UNION:" "USE:" "USING:" "VARS:" - "call-next-method" "delimiter" "f" "initial:" "read-only")) + "UNION:" "USE:" "USING:" + "VARS:")) (defconst fuel-syntax--bracers '("B" "BV" "C" "CS" "H" "T" "V" "W")) @@ -65,7 +73,7 @@ (format "%s{" (regexp-opt fuel-syntax--bracers t))) (defconst fuel-syntax--declaration-words - '("flushable" "foldable" "inline" "parsing" "recursive")) + '("flushable" "foldable" "inline" "parsing" "recursive" "delimiter")) (defconst fuel-syntax--declaration-words-regex (regexp-opt fuel-syntax--declaration-words 'words)) @@ -76,13 +84,29 @@ (defconst fuel-syntax--method-definition-regex "^M: +\\([^ ]+\\) +\\([^ ]+\\)") +(defconst fuel-syntax--number-regex + "\\(\\+\\|-\\)?\\([0-9]+\\.?[0-9]*\\|\\.[0-9]+\\)\\([eE]\\(\\+\\|-\\)?[0-9]+\\)?") + (defconst fuel-syntax--word-definition-regex - (fuel-syntax--second-word-regex '(":" "::" "GENERIC:"))) + (fuel-syntax--second-word-regex + '(":" "::" "GENERIC:" "DEFER:" "HOOK:" "MAIN:" "MATH:" "POSTPONE:" + "SYMBOL:" "RENAME:"))) + +(defconst fuel-syntax--alias-definition-regex + "^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)") + +(defconst fuel-syntax--vocab-ref-regexp + (fuel-syntax--second-word-regex + '("IN:" "USE:" "FROM:" "EXCLUDE:" "QUALIFIED:" "QUALIFIED-WITH:"))) + +(defconst fuel-syntax--int-constant-def-regex + (fuel-syntax--second-word-regex '("CHAR:" "BIN:" "HEX:" "OCT:"))) (defconst fuel-syntax--type-definition-regex - (fuel-syntax--second-word-regex '("TUPLE:" "SINGLETON:"))) + (fuel-syntax--second-word-regex '("MIXIN:" "TUPLE:" "SINGLETON:" "UNION:"))) -(defconst fuel-syntax--parent-type-regex "^TUPLE: +[^ ]+ +< +\\([^ ]+\\)") +(defconst fuel-syntax--parent-type-regex + "^\\(TUPLE\\|PREDICTE\\): +[^ ]+ +< +\\([^ ]+\\)") (defconst fuel-syntax--constructor-regex "<[^ >]+>") @@ -102,21 +126,37 @@ (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$") -(defconst fuel-syntax--definition-starters-regex - (regexp-opt - '("VARS" "TUPLE" "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" ":" ""))) - (defconst fuel-syntax--definition-start-regex - (format "^\\(%s:\\) " fuel-syntax--definition-starters-regex)) + (format "^\\(%s:\\) " (regexp-opt '("" ":" + "FROM" + "INTERSECTION:" + "MACRO" "MACRO:" "M" "MEMO" "MEMO:" "METHOD" + "PREDICATE" "PRIMITIVE" + "SINGLETONS" "SYMBOLS" + "TUPLE" + "UNION" + "VARS")))) (defconst fuel-syntax--definition-end-regex (format "\\(\\(^\\| +\\);\\( *%s\\)*\\($\\| +\\)\\)" fuel-syntax--declaration-words-regex)) (defconst fuel-syntax--single-liner-regex - (format "^%s" (regexp-opt '("C:" "DEFER:" "GENERIC:" "IN:" - "PRIVATE>" "" " Date: Sat, 10 Jan 2009 01:05:51 +0100 Subject: [PATCH 47/56] FUEL: Fix for word extraction in top level forms. --- misc/fuel/fuel-refactor.el | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el index a414f17795..4bb83c06c8 100644 --- a/misc/fuel/fuel-refactor.el +++ b/misc/fuel/fuel-refactor.el @@ -32,7 +32,13 @@ (insert word) (indent-region begin (point)) (set-mark (point)) - (fuel-syntax--beginning-of-defun) + (let ((beg (save-excursion (fuel-syntax--beginning-of-defun) (point))) + (end (save-excursion + (re-search-backward fuel-syntax--end-of-def-regex nil t) + (forward-line 1) + (skip-syntax-forward "-") + (point)))) + (goto-char (max beg end))) (open-line 1) (let ((start (point))) (insert ": " word " " stack-effect "\n" code " ;\n") From ea4f8867c762e40680a50dae92f3215658714f9b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 19:04:10 -0600 Subject: [PATCH 48/56] make monotonic-slice compile --- .../splitting/monotonic/monotonic-tests.factor | 2 ++ basis/splitting/monotonic/monotonic.factor | 18 ++++++++++-------- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/basis/splitting/monotonic/monotonic-tests.factor b/basis/splitting/monotonic/monotonic-tests.factor index 7bf9a38e8a..2b44f42394 100644 --- a/basis/splitting/monotonic/monotonic-tests.factor +++ b/basis/splitting/monotonic/monotonic-tests.factor @@ -15,6 +15,8 @@ USING: tools.test math arrays kernel sequences ; [ { { 1 } } ] [ { 1 } [ = ] slice monotonic-slice [ >array ] map ] unit-test +[ { 1 } [ = ] slice monotonic-slice ] must-infer + [ t ] [ { 1 1 1 2 2 3 3 4 } [ = ] slice monotonic-slice [ slice? ] all? ] unit-test diff --git a/basis/splitting/monotonic/monotonic.factor b/basis/splitting/monotonic/monotonic.factor index e39bba25ab..2e2ac74e30 100644 --- a/basis/splitting/monotonic/monotonic.factor +++ b/basis/splitting/monotonic/monotonic.factor @@ -24,13 +24,15 @@ PRIVATE> 1 over change-circular-start ] tri - [ @ not [ , ] [ drop ] if ] 3each - ] { } make - dup empty? [ over length 1- prefix ] when -1 prefix 2 clump - [ first2 [ 1+ ] bi@ rot roll boa ] with with map ; inline + [ + dupd '[ + [ length ] [ ] [ 1 over change-circular-start ] tri + [ @ not [ , ] [ drop ] if ] 3each + ] { } make + dup empty? [ over length 1- prefix ] when -1 prefix 2 clump + swap + ] dip + '[ first2 [ 1+ ] bi@ _ _ boa ] map ; inline PRIVATE> @@ -39,7 +41,7 @@ PRIVATE> { 0 [ 2drop ] } { 1 [ nip [ 0 1 rot ] dip boa 1array ] } [ drop (monotonic-slice) ] - } case ; + } case ; inline TUPLE: downward-slice < slice ; TUPLE: stable-slice < slice ; From f3c7a870650af971c755f53797430559ade4fbaf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 19:12:49 -0600 Subject: [PATCH 49/56] clarify how sort works --- core/sorting/sorting-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/sorting/sorting-docs.factor b/core/sorting/sorting-docs.factor index 6ea1485425..290ca1470c 100644 --- a/core/sorting/sorting-docs.factor +++ b/core/sorting/sorting-docs.factor @@ -20,7 +20,8 @@ ABOUT: "sequences-sorting" HELP: sort { $values { "seq" "a sequence" } { "quot" { $quotation "( obj1 obj2 -- <=> )" } } { "sortedseq" "a new sorted sequence" } } -{ $description "Sorts the elements into a new array." } ; +{ $description "Sorts the elements into a new array using a stable sort." } +{ $notes "The algorithm used is the merge sort." } ; HELP: sort-keys { $values { "seq" "an alist" } { "sortedseq" "a new sorted sequence" } } From 5ae9c7fe2fbac48b8167db13bb853dc99afb1de0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 9 Jan 2009 20:35:01 -0600 Subject: [PATCH 50/56] document 3each, 3map, 3map-as --- core/sequences/sequences-docs.factor | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 9f18fd4e66..eb621b3225 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -338,6 +338,10 @@ HELP: 2each { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- )" } } } { $description "Applies the quotation to pairs of elements from " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; +HELP: 3each +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- )" } } } +{ $description "Applies the quotation to triples of elements from " { $snippet "seq1" } ", " { $snippet "seq2" } " and " { $snippet "seq3" } "." } ; + HELP: 2reduce { $values { "seq1" sequence } { "seq2" sequence } @@ -350,10 +354,18 @@ HELP: 2map { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "newseq" "a new sequence" } } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; +HELP: 3map +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "newseq" "a new sequence" } } +{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "seq1" } "." } ; + HELP: 2map-as { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } { $description "Applies the quotation to each pair of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; +HELP: 3map-as +{ $values { "seq1" sequence } { "seq2" sequence } { "seq3" sequence } { "quot" { $quotation "( elt1 elt2 elt3 -- new )" } } { "exemplar" sequence } { "newseq" "a new sequence" } } +{ $description "Applies the quotation to each triple of elements in turn, yielding new elements which are collected into a new sequence having the same class as " { $snippet "exemplar" } "." } ; + HELP: 2all? { $values { "seq1" sequence } { "seq2" sequence } { "quot" { $quotation "( elt1 elt2 -- ? )" } } { "?" "a boolean" } } { $description "Tests the predicate pairwise against elements of " { $snippet "seq1" } " and " { $snippet "seq2" } "." } ; @@ -1422,16 +1434,23 @@ ARTICLE: "sequences-combinators" "Sequence combinators" { $subsection all? } "Testing how elements are related:" { $subsection monotonic? } -{ $subsection "sequence-2combinators" } ; +{ $subsection "sequence-2combinators" } +{ $subsection "sequence-3combinators" } ; ARTICLE: "sequence-2combinators" "Pair-wise sequence combinators" -"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, than only the prefix having the length of the minimum of the two is examined." +"There is a set of combinators which traverse two sequences pairwise. If one sequence is shorter than the other, then only the prefix having the length of the minimum of the two is examined." { $subsection 2each } { $subsection 2reduce } { $subsection 2map } { $subsection 2map-as } { $subsection 2all? } ; +ARTICLE: "sequence-3combinators" "Triple-wise sequence combinators" +"There is a set of combinators which traverse three sequences triple-wise. If one sequence is shorter than the others, then only the prefix having the length of the minimum of the three is examined." +{ $subsection 3each } +{ $subsection 3map } +{ $subsection 3map-as } ; + ARTICLE: "sequences-tests" "Testing sequences" "Testing for an empty sequence:" { $subsection empty? } From a977691d82e06033d04d5c7e4afe3f95572dde20 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 9 Jan 2009 21:35:49 -0600 Subject: [PATCH 51/56] Add iota virtual sequence which will eventually replace integers-as-sequences --- core/sequences/sequences-docs.factor | 11 +++++++++++ core/sequences/sequences.factor | 10 ++++++++++ 2 files changed, 21 insertions(+) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 9f18fd4e66..f3a12d9209 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1262,6 +1262,17 @@ HELP: shorten "V{ 1 2 3 }" } } ; +HELP: iota +{ $values { "n" integer } { "iota" iota } } +{ $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." } +{ $examples + { $example + "USING: math.parser sequences ;" + "3 iota [ sq ] map ." + "{ \"0\" \"1\" \"2\" }" + } +} ; + ARTICLE: "sequences-unsafe" "Unsafe sequence operations" "The " { $link nth-unsafe } " and " { $link set-nth-unsafe } " sequence protocol bypasses bounds checks for increased performance." $nl diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 91c9d52404..2a499845bd 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -101,6 +101,16 @@ M: integer nth-unsafe drop ; INSTANCE: integer immutable-sequence +! In the future, this will replace integer sequences +TUPLE: iota { n read-only } ; + +: iota ( n -- iota ) \ iota boa ; inline + +M: iota length n>> ; +M: iota nth-unsafe drop ; + +INSTANCE: iota immutable-sequence + : first-unsafe ( seq -- first ) 0 swap nth-unsafe ; inline From f4cffe8a1b2e6a002c5895d498c6183b40437b1d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 10 Jan 2009 13:05:25 -0600 Subject: [PATCH 52/56] move iota to sequences, fix example, add unit tests, make iota's slot integers only --- core/sequences/sequences-docs.factor | 4 ++-- core/sequences/sequences-tests.factor | 6 +++++- core/sequences/sequences.factor | 6 +++++- 3 files changed, 12 insertions(+), 4 deletions(-) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 957b33198e..651c8e8a14 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1279,9 +1279,9 @@ HELP: iota { $description "Creates an immutable virtual sequence containing the integers from 0 to " { $snippet "n-1" } "." } { $examples { $example - "USING: math.parser sequences ;" + "USING: math sequences prettyprint ;" "3 iota [ sq ] map ." - "{ \"0\" \"1\" \"2\" }" + "{ 0 1 4 }" } } ; diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 80352faf72..9adc6bc602 100644 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -276,4 +276,8 @@ M: bogus-hashcode hashcode* 2drop 0 >bignum ; { 3 0 } [ [ 3drop ] 3each ] must-infer-as -[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test \ No newline at end of file +[ V{ 0 3 } ] [ "A" { "A" "B" "C" "A" "D" } indices ] unit-test + +[ "asdf" iota ] must-fail +[ T{ iota { n 10 } } ] [ 10 iota ] unit-test +[ 0 ] [ 10 iota first ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2a499845bd..5a92dcaf2d 100644 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -101,11 +101,15 @@ M: integer nth-unsafe drop ; INSTANCE: integer immutable-sequence +PRIVATE> + ! In the future, this will replace integer sequences -TUPLE: iota { n read-only } ; +TUPLE: iota { n integer read-only } ; : iota ( n -- iota ) \ iota boa ; inline +> ; M: iota nth-unsafe drop ; From da20ea83af71df9cdb0a70db90a753f1361c325f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 10 Jan 2009 18:13:16 -0600 Subject: [PATCH 53/56] Minor parser docs fix --- core/parser/parser-docs.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 625c1e9c43..4da76468e8 100644 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -34,6 +34,7 @@ ARTICLE: "defining-words" "Defining words" { $see POSTPONE: SYMBOL: } "The key factor in the definition of " { $link POSTPONE: SYMBOL: } " is " { $link CREATE } ", which reads a token from the input and creates a word with that name. This word is then passed to " { $link define-symbol } "." { $subsection CREATE } +{ $subsection CREATE-WORD } "Colon definitions are defined in a more elaborate way:" { $subsection POSTPONE: : } "The " { $link POSTPONE: : } " word first calls " { $link CREATE } ", and then reads input until reaching " { $link POSTPONE: ; } " using a utility word:" From eaa920bc19d04e664d1483a1357b48686c4f8323 Mon Sep 17 00:00:00 2001 From: Tim Allen Date: Sun, 11 Jan 2009 13:12:52 +1100 Subject: [PATCH 54/56] Make line-numbering more reliable in gvim. --- basis/editors/gvim/gvim.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor index ad6fb65cfb..8fb4d6b23d 100644 --- a/basis/editors/gvim/gvim.factor +++ b/basis/editors/gvim/gvim.factor @@ -8,7 +8,7 @@ SINGLETON: gvim HOOK: gvim-path io-backend ( -- path ) M: gvim vim-command ( file line -- string ) - [ gvim-path , swap , "+" swap number>string append , ] { } make ; + [ gvim-path , "+" swap number>string append , , ] { } make ; gvim vim-editor set-global From 8e273b671317fc80e6cb621c435dd497e23cda4e Mon Sep 17 00:00:00 2001 From: Tim Allen Date: Sun, 11 Jan 2009 13:13:31 +1100 Subject: [PATCH 55/56] Fix USING: in editors.vim.generate-syntax --- basis/editors/vim/generate-syntax/generate-syntax.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/basis/editors/vim/generate-syntax/generate-syntax.factor b/basis/editors/vim/generate-syntax/generate-syntax.factor index 325a451a0b..74b04c346f 100644 --- a/basis/editors/vim/generate-syntax/generate-syntax.factor +++ b/basis/editors/vim/generate-syntax/generate-syntax.factor @@ -1,6 +1,5 @@ ! Generate a new factor.vim file for syntax highlighting -USING: http.server.templating http.server.templating.fhtml -io.files ; +USING: html.templates html.templates.fhtml io.files io.pathnames ; IN: editors.vim.generate-syntax : generate-vim-syntax ( -- ) From 342e459ebedbd1b79351ca9986dcd47447e2b491 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 10 Jan 2009 23:41:50 -0600 Subject: [PATCH 56/56] Add ui-tools link to tools article --- basis/help/handbook/handbook.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor index 69c2046834..f63bb35f65 100644 --- a/basis/help/handbook/handbook.factor +++ b/basis/help/handbook/handbook.factor @@ -209,7 +209,8 @@ ARTICLE: "tools" "Developer tools" { $subsection "timing" } { $subsection "tools.disassembler" } "Deployment tools:" -{ $subsection "tools.deploy" } ; +{ $subsection "tools.deploy" } +{ $see-also "ui-tools" } ; ARTICLE: "article-index" "Article index" { $index [ articles get keys ] } ;