From b369ed600d1a9e4dd1e21ab765e8aef2d9f2682c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 16:02:41 -0500 Subject: [PATCH 001/146] Graph docs fix --- core/graphs/graphs-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/core/graphs/graphs-docs.factor b/core/graphs/graphs-docs.factor index 1e4350d58c..f16f8cca3b 100644 --- a/core/graphs/graphs-docs.factor +++ b/core/graphs/graphs-docs.factor @@ -21,12 +21,12 @@ HELP: graph HELP: add-vertex { $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } } -{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." } +{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." } { $side-effects "graph" } ; HELP: remove-vertex { $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } } -{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." } +{ $description "Removes a vertex from a graph, using the given edges sequence." } { $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." } { $side-effects "graph" } ; From 70573c01f07b1aecd9abe14fd44b0cd87f00a141 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 14:33:01 -0500 Subject: [PATCH 002/146] comment out compiler error --- extra/db/mysql/lib/lib.factor | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 59d1b6ff3d..ca912f200d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -18,16 +18,16 @@ TUPLE: mysql-result-set ; : mysql-error ( mysql -- ) [ mysql_error throw ] when* ; -: mysql-connect ( mysql-connection -- ) - new-mysql over set-mysql-db-handle - dup { - mysql-db-handle - mysql-db-host - mysql-db-user - mysql-db-password - mysql-db-db - mysql-db-port - } get-slots f 0 mysql_real_connect mysql-error ; +! : mysql-connect ( mysql-connection -- ) + ! new-mysql over set-mysql-db-handle + ! dup { + ! mysql-db-handle + ! mysql-db-host + ! mysql-db-user + ! mysql-db-password + ! mysql-db-db + ! mysql-db-port + ! } get-slots f 0 mysql_real_connect mysql-error ; ! ========================================================= ! Low level mysql utility definitions From d81a4aa914ac947bf6f6e14029ac87ff9e330c5f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sun, 6 Apr 2008 19:03:00 -0500 Subject: [PATCH 003/146] Minor io.encodings.8-bit cleanup --- extra/io/encodings/8-bit/8-bit.factor | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/extra/io/encodings/8-bit/8-bit.factor b/extra/io/encodings/8-bit/8-bit.factor index 259173fec4..04e8ee8569 100755 --- a/extra/io/encodings/8-bit/8-bit.factor +++ b/extra/io/encodings/8-bit/8-bit.factor @@ -29,9 +29,10 @@ IN: io.encodings.8-bit { "mac-roman" "ROMAN" } } ; -: full-path ( file-name -- path ) +: encoding-file ( file-name -- stream ) "extra/io/encodings/8-bit/" ".TXT" - swapd 3append resource-path ; + swapd 3append resource-path + ascii ; : tail-if ( seq n -- newseq ) 2dup swap length <= [ tail ] [ drop ] if ; @@ -48,8 +49,8 @@ IN: io.encodings.8-bit : ch>byte ( assoc -- newassoc ) [ swap ] assoc-map >hashtable ; -: parse-file ( file-name -- byte>ch ch>byte ) - ascii file-lines process-contents +: parse-file ( path -- byte>ch ch>byte ) + lines process-contents [ byte>ch ] [ ch>byte ] bi ; TUPLE: 8-bit name decode encode ; @@ -71,13 +72,13 @@ M: 8-bit decode-char : make-8-bit ( word byte>ch ch>byte -- ) [ 8-bit construct-boa ] 2curry dupd curry define ; -: define-8-bit-encoding ( name path -- ) +: define-8-bit-encoding ( name stream -- ) >r in get create r> parse-file make-8-bit ; PRIVATE> [ "io.encodings.8-bit" in [ - mappings [ full-path define-8-bit-encoding ] assoc-each + mappings [ encoding-file define-8-bit-encoding ] assoc-each ] with-variable ] with-compilation-unit From 719376e412804f1286482ff32cf3aaf1889f524d Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 13:17:09 +1200 Subject: [PATCH 004/146] Remove w-c-u from ebnf transform --- extra/peg/ebnf/ebnf.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index e5787e6cf8..56f88fc866 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -318,11 +318,11 @@ M: object build-locals ( code ast -- ) M: ebnf-action (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit action ; + string-lines parse-lines action ; M: ebnf-semantic (transform) ( ast -- parser ) [ parser>> (transform) ] [ code>> ] [ parser>> ] tri build-locals - string-lines [ parse-lines ] with-compilation-unit semantic ; + string-lines parse-lines semantic ; M: ebnf-var (transform) ( ast -- parser ) parser>> (transform) ; From ddb1749c57743c25d7667c9484fa854ee98abf50 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 6 Apr 2008 21:07:21 -0500 Subject: [PATCH 005/146] ERROR: should be inside the IN: --- extra/opengl/gl/extensions/extensions.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/opengl/gl/extensions/extensions.factor b/extra/opengl/gl/extensions/extensions.factor index b8ac396c2f..20929fb410 100644 --- a/extra/opengl/gl/extensions/extensions.factor +++ b/extra/opengl/gl/extensions/extensions.factor @@ -1,6 +1,7 @@ USING: alien alien.syntax combinators kernel parser sequences system words namespaces hashtables init math arrays assocs continuations ; +IN: opengl.gl.extensions ERROR: unknown-gl-platform ; << { @@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ; { [ os unix? ] [ "opengl.gl.unix" ] } { [ t ] [ unknown-gl-platform ] } } cond use+ >> -IN: opengl.gl.extensions SYMBOL: +gl-function-number-counter+ SYMBOL: +gl-function-pointers+ From a641c6d332e36910239a6a269e299a231f422d18 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Mon, 7 Apr 2008 14:39:18 +1200 Subject: [PATCH 006/146] Add \r to ebnf escape rules --- extra/peg/ebnf/ebnf.factor | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index 56f88fc866..8bf0475da5 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -361,7 +361,11 @@ M: ebnf-non-terminal (transform) ( ast -- parser ) [ compiled-parse ] curry [ with-scope ] curry ; : replace-escapes ( string -- string ) - "\\t" token [ drop "\t" ] action "\\n" token [ drop "\n" ] action 2choice replace ; + [ + "\\t" token [ drop "\t" ] action , + "\\n" token [ drop "\n" ] action , + "\\r" token [ drop "\r" ] action , + ] choice* replace ; : [EBNF "EBNF]" parse-multiline-string replace-escapes ebnf>quot nip parsed ; parsing From 368599baf81fcd864b9fd2234df882ff326a5f1a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Mon, 7 Apr 2008 00:45:46 -0500 Subject: [PATCH 007/146] Fix to inverse, and syntax change --- extra/inverse/inverse-tests.factor | 6 ++++-- extra/inverse/inverse.factor | 17 ++++++++++------- 2 files changed, 14 insertions(+), 9 deletions(-) diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index 31e7c5f78a..101637e4e8 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -1,5 +1,5 @@ USING: inverse tools.test arrays math kernel sequences -math.functions math.constants ; +math.functions math.constants continuations ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test @@ -51,7 +51,7 @@ C: nil { { [ ] [ list-sum + ] } { [ ] [ 0 ] } - { [ ] [ "Malformed list" throw ] } + [ "Malformed list" throw ] } switch ; [ 10 ] [ 1 2 3 4 list-sum ] unit-test @@ -59,6 +59,7 @@ C: nil [ 1 2 ] [ 1 2 [ ] undo ] unit-test [ t ] [ 1 2 [ ] matches? ] unit-test [ f ] [ 1 2 [ ] matches? ] unit-test +[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test : empty-cons ( -- cons ) cons construct-empty ; : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; @@ -68,3 +69,4 @@ C: nil [ t ] [ pi [ pi ] matches? ] unit-test [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test +[ ] [ 3 [ _ ] undo ] unit-test diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1b7badd94a..9c94c86ce9 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ; PREDICATE: pop-inverse < word "pop-length" word-prop ; UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; -: enough? ( stack quot -- ? ) - [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] - recover ; +: enough? ( stack word -- ? ) + dup deferred? [ 2drop f ] [ + [ >r length r> 1quotation infer effect-in >= ] + [ 3drop f ] recover + ] if ; -: fold-word ( stack quot -- stack ) +: fold-word ( stack word -- stack ) 2dup enough? [ 1quotation with-datastack ] [ >r % r> , { } ] if ; @@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; [ { } swap [ fold-word ] each % ] [ ] make ; : flattenable? ( object -- ? ) - [ [ word? ] [ primitive? not ] and? ] [ + { [ word? ] [ primitive? not ] [ { "inverse" "math-inverse" "pop-inverse" } [ word-prop ] with contains? not - ] and? ; + ] } <-&& ; : (flatten) ( quot -- ) [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; @@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ; 2curry ] define-pop-inverse -: _ f ; +DEFER: _ \ _ [ drop ] define-inverse : both ( object object -- object ) @@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ; [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ; : [switch] ( quot-alist -- quot ) + [ dup quotation? [ [ ] swap 2array ] when ] map reverse [ >r [undo] r> compose ] { } assoc>map recover-chain ; From b1b889d8994e96968a47c5f93642fc76b6eb9864 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 15:30:06 -0500 Subject: [PATCH 008/146] add some acl constants --- extra/windows/advapi32/advapi32.factor | 195 ++++++++++++++++--------- 1 file changed, 129 insertions(+), 66 deletions(-) diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor index 28091d3d9d..0d2f164c8d 100644 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -61,6 +61,133 @@ LIBRARY: advapi32 : CRYPT_MACHINE_KEYSET HEX: 20 ; inline : CRYPT_SILENT HEX: 40 ; inline +C-STRUCT: ACL + { "BYTE" "AclRevision" } + { "BYTE" "Sbz1" } + { "WORD" "AclSize" } + { "WORD" "AceCount" } + { "WORD" "Sbz2" } ; + +TYPEDEF: ACL* PACL + +: ACCESS_ALLOWED_ACE_TYPE 0 ; inline +: ACCESS_DENIED_ACE_TYPE 1 ; inline +: SYSTEM_AUDIT_ACE_TYPE 2 ; inline +: SYSTEM_ALARM_ACE_TYPE 3 ; inline + +: OBJECT_INHERIT_ACE HEX: 1 ; inline +: CONTAINER_INHERIT_ACE HEX: 2 ; inline +: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline +: INHERIT_ONLY_ACE HEX: 8 ; inline +: VALID_INHERIT_FLAGS HEX: f ; inline + +C-STRUCT: ACE_HEADER + { "BYTE" "AceType" } + { "BYTE" "AceFlags" } + { "WORD" "AceSize" } ; + +TYPEDEF: ACE_HEADER* PACE_HEADER + +C-STRUCT: ACCESS_ALLOWED_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE + +C-STRUCT: ACCESS_DENIED_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; +TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE + + +C-STRUCT: SYSTEM_AUDIT_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE + +C-STRUCT: SYSTEM_ALARM_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE + +C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE + { "ACE_HEADER" "Header" } + { "DWORD" "Mask" } + { "DWORD" "SidStart" } ; + +TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE + + +! typedef enum _TOKEN_INFORMATION_CLASS { +: TokenUser 1 ; inline +: TokenGroups 2 ; inline +: TokenPrivileges 3 ; inline +: TokenOwner 4 ; inline +: TokenPrimaryGroup 5 ; inline +: TokenDefaultDacl 6 ; inline +: TokenSource 7 ; inline +: TokenType 8 ; inline +: TokenImpersonationLevel 9 ; inline +: TokenStatistics 10 ; inline +: TokenRestrictedSids 11 ; inline +: TokenSessionId 12 ; inline +: TokenGroupsAndPrivileges 13 ; inline +: TokenSessionReference 14 ; inline +: TokenSandBoxInert 15 ; inline +! } TOKEN_INFORMATION_CLASS; + +: DELETE HEX: 00010000 ; inline +: READ_CONTROL HEX: 00020000 ; inline +: WRITE_DAC HEX: 00040000 ; inline +: WRITE_OWNER HEX: 00080000 ; inline +: SYNCHRONIZE HEX: 00100000 ; inline +: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline + +: STANDARD_RIGHTS_READ READ_CONTROL ; inline +: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline +: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline + +: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline +: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline +: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline +: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline +: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline +: TOKEN_DUPLICATE HEX: 0002 ; inline +: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline +: TOKEN_IMPERSONATE HEX: 0004 ; inline +: TOKEN_QUERY HEX: 0008 ; inline +: TOKEN_QUERY_SOURCE HEX: 0010 ; inline +: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline +: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; + +: TOKEN_WRITE + { + STANDARD_RIGHTS_WRITE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_DEFAULT + } flags ; foldable + +: TOKEN_ALL_ACCESS + { + STANDARD_RIGHTS_REQUIRED + TOKEN_ASSIGN_PRIMARY + TOKEN_DUPLICATE + TOKEN_IMPERSONATE + TOKEN_QUERY + TOKEN_QUERY_SOURCE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_SESSIONID + TOKEN_ADJUST_DEFAULT + } flags ; foldable + ! : I_ScGetCurrentGroupStateW ; ! : A_SHAFinal ; @@ -85,7 +212,7 @@ LIBRARY: advapi32 ! : AddAccessDeniedAce ; ! : AddAccessDeniedAceEx ; ! : AddAccessDeniedObjectAce ; -! : AddAce ; +FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ; ! : AddAuditAccessAce ; ! : AddAuditAccessAceEx ; ! : AddAuditAccessObjectAce ; @@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ; ! : ImpersonateLoggedOnUser ; ! : ImpersonateNamedPipeClient ; ! : ImpersonateSelf ; -! : InitializeAcl ; +FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ; ! : InitializeSecurityDescriptor ; ! : InitializeSid ; ! : InitiateSystemShutdownA ; @@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, ! : OpenEventLogA ; ! : OpenEventLogW ; -! typedef enum _TOKEN_INFORMATION_CLASS { -: TokenUser 1 ; -: TokenGroups 2 ; -: TokenPrivileges 3 ; -: TokenOwner 4 ; -: TokenPrimaryGroup 5 ; -: TokenDefaultDacl 6 ; -: TokenSource 7 ; -: TokenType 8 ; -: TokenImpersonationLevel 9 ; -: TokenStatistics 10 ; -: TokenRestrictedSids 11 ; -: TokenSessionId 12 ; -: TokenGroupsAndPrivileges 13 ; -: TokenSessionReference 14 ; -: TokenSandBoxInert 15 ; -! } TOKEN_INFORMATION_CLASS; - -: DELETE HEX: 00010000 ; inline -: READ_CONTROL HEX: 00020000 ; inline -: WRITE_DAC HEX: 00040000 ; inline -: WRITE_OWNER HEX: 00080000 ; inline -: SYNCHRONIZE HEX: 00100000 ; inline -: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline - -: STANDARD_RIGHTS_READ READ_CONTROL ; inline -: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline -: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline - -: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline -: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline -: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline -: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline -: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline -: TOKEN_DUPLICATE HEX: 0002 ; inline -: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline -: TOKEN_IMPERSONATE HEX: 0004 ; inline -: TOKEN_QUERY HEX: 0008 ; inline -: TOKEN_QUERY_SOURCE HEX: 0010 ; inline -: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline -: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; - -: TOKEN_WRITE - { - STANDARD_RIGHTS_WRITE - TOKEN_ADJUST_PRIVILEGES - TOKEN_ADJUST_GROUPS - TOKEN_ADJUST_DEFAULT - } flags ; foldable - -: TOKEN_ALL_ACCESS - { - STANDARD_RIGHTS_REQUIRED - TOKEN_ASSIGN_PRIMARY - TOKEN_DUPLICATE - TOKEN_IMPERSONATE - TOKEN_QUERY - TOKEN_QUERY_SOURCE - TOKEN_ADJUST_PRIVILEGES - TOKEN_ADJUST_GROUPS - TOKEN_ADJUST_SESSIONID - TOKEN_ADJUST_DEFAULT - } flags ; foldable - FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, PHANDLE TokenHandle ) ; From 56ff4530ff9b34fcc15050fd8af66b71e751b572 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:28:54 -0500 Subject: [PATCH 009/146] fix blum-blum-shub --- .../blum-blum-shub-tests.factor | 28 +++++++++++++++++++ .../blum-blum-shub/blum-blum-shub.factor | 24 ++++++---------- 2 files changed, 36 insertions(+), 16 deletions(-) create mode 100644 extra/random/blum-blum-shub/blum-blum-shub-tests.factor diff --git a/extra/random/blum-blum-shub/blum-blum-shub-tests.factor b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor new file mode 100644 index 0000000000..a92f256eeb --- /dev/null +++ b/extra/random/blum-blum-shub/blum-blum-shub-tests.factor @@ -0,0 +1,28 @@ +USING: kernel math tools.test namespaces random +random.blum-blum-shub ; +IN: blum-blum-shub.tests + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } random-32* +] unit-test + + +[ 887708070 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 32 random-bits + ] with-random +] unit-test + +[ 5726770047455156646 ] [ + T{ blum-blum-shub f 590695557939 811977232793 } [ + 64 random-bits + ] with-random +] unit-test + +[ 3716213681 ] +[ + 100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [ + random-32* drop + ] curry times + random-32* +] unit-test diff --git a/extra/random/blum-blum-shub/blum-blum-shub.factor b/extra/random/blum-blum-shub/blum-blum-shub.factor index 017ef402c0..5644cf6d08 100755 --- a/extra/random/blum-blum-shub/blum-blum-shub.factor +++ b/extra/random/blum-blum-shub/blum-blum-shub.factor @@ -3,34 +3,26 @@ math.miller-rabin combinators.lib math.functions accessors random ; IN: random.blum-blum-shub -! TODO: take (log log M) bits instead of 1 bit -! Blum Blum Shub, M = pq +! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n +! return low bit of x+1 TUPLE: blum-blum-shub x n ; -C: blum-blum-shub + ( numbits -- blum-blum-shub ) - #! returns a Blum-Blum-Shub tuple generate-bbs-primes * [ find-relative-prime ] keep blum-blum-shub construct-boa ; -! 256 make-bbs blum-blum-shub set-global - : next-bbs-bit ( bbs -- bit ) - #! x = x^2 mod n, return low bit of calculated x - [ [ x>> 2 ] [ n>> ] bi ^mod ] - [ [ >>x ] keep x>> 1 bitand ] bi ; + [ [ x>> 2 ] [ n>> ] bi ^mod ] keep + over >>x drop 1 bitand ; -IN: crypto -! : random ( n -- n ) - ! ! #! Cryptographically secure random number using Blum-Blum-Shub 256 - ! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ; +PRIVATE> M: blum-blum-shub random-32* ( bbs -- r ) - ; + 0 32 rot + [ next-bbs-bit swap 1 shift bitor ] curry times ; From f0ae86b884efe75ab55d3f6e8524a019bafd80ac Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 7 Apr 2008 19:30:02 -0500 Subject: [PATCH 010/146] remove outdated file --- extra/crypto/test/blum-blum-shub.factor | 5 ----- 1 file changed, 5 deletions(-) delete mode 100644 extra/crypto/test/blum-blum-shub.factor diff --git a/extra/crypto/test/blum-blum-shub.factor b/extra/crypto/test/blum-blum-shub.factor deleted file mode 100644 index b1b6034373..0000000000 --- a/extra/crypto/test/blum-blum-shub.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: kernel math test namespaces crypto crypto-internals ; - -[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test -[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test - From 4cd86a06174816adefef7f3899a82cedf66be585 Mon Sep 17 00:00:00 2001 From: Bruno Deferrari Date: Tue, 8 Apr 2008 17:32:37 -0300 Subject: [PATCH 011/146] IRC client update --- extra/irc/irc.factor | 337 ++++++++++++++++++++++++++----------------- 1 file changed, 206 insertions(+), 131 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 8a39846fc4..0105fc53bb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -1,87 +1,130 @@ ! Copyright (C) 2007 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays calendar io io.sockets kernel match namespaces -sequences splitting strings continuations threads ascii -io.encodings.utf8 ; +USING: arrays calendar combinators channels concurrency.messaging fry io + io.encodings.8-bit io.sockets kernel math namespaces sequences + sequences.lib singleton splitting strings threads + continuations classes.tuple ascii accessors ; IN: irc -! "setup" objects -TUPLE: profile server port nickname password default-channels ; -C: profile +! utils +: split-at-first ( seq separators -- before after ) + dupd '[ , member? ] find + [ cut 1 tail ] + [ swap ] + if ; -TUPLE: channel-profile name password auto-rejoin ; -C: channel-profile +: spawn-server-linked ( quot name -- thread ) + >r '[ , [ ] [ ] while ] r> + spawn-linked ; +! --- + +! Default irc port +: irc-port 6667 ; + +! Message used when the client isn't running anymore +SINGLETON: irc-end + +! "setup" objects +TUPLE: irc-profile server port nickname password default-channels ; +C: irc-profile + +TUPLE: irc-channel-profile name password auto-rejoin ; +C: irc-channel-profile ! "live" objects -TUPLE: irc-client profile nick stream stream-process controller-process ; -C: irc-client - TUPLE: nick name channels log ; C: nick -TUPLE: channel name topic members log attributes ; -C: channel +TUPLE: irc-client profile nick stream stream-channel controller-channel + listeners is-running ; +: ( profile -- irc-client ) + f V{ } clone V{ } clone + f V{ } clone f irc-client construct-boa ; + +USE: prettyprint +TUPLE: irc-listener channel ; +! FIXME: spawn-server-linked con manejo de excepciones, mandar un mensaje final (ya se maneja esto al recibir mensajes del channel? ) +! tener la opción de dejar de correr un client?? +: ( quot -- irc-listener ) + irc-listener construct-boa swap + [ + [ channel>> '[ , from ] ] + [ '[ , curry f spawn drop ] ] + bi* compose "irc-listener" spawn-server-linked drop + ] [ drop ] 2bi ; + +! TUPLE: irc-channel name topic members log attributes ; +! C: irc-channel ! the delegate of all irc messages -TUPLE: irc-message timestamp ; +TUPLE: irc-message line prefix command parameters trailing timestamp ; C: irc-message ! "irc message" objects -TUPLE: logged-in name text ; +TUPLE: logged-in < irc-message name ; C: logged-in -TUPLE: ping name ; +TUPLE: ping < irc-message ; C: ping -TUPLE: join name channel ; -C: join +TUPLE: join_ < irc-message ; +C: join_ -TUPLE: part name channel text ; +TUPLE: part < irc-message name channel ; C: part -TUPLE: quit text ; +TUPLE: quit ; C: quit -TUPLE: privmsg name text ; +TUPLE: privmsg < irc-message name ; C: privmsg -TUPLE: kick channel er ee text ; +TUPLE: kick < irc-message channel who ; C: kick -TUPLE: roomlist channel names ; +TUPLE: roomlist < irc-message channel names ; C: roomlist -TUPLE: nick-in-use name ; +TUPLE: nick-in-use < irc-message name ; C: nick-in-use -TUPLE: notice type text ; +TUPLE: notice < irc-message type ; C: notice -TUPLE: mode name channel mode text ; +TUPLE: mode < irc-message name channel mode ; C: mode -! TUPLE: members -TUPLE: unhandled text ; +TUPLE: unhandled < irc-message ; C: unhandled -! "control message" objects -TUPLE: command sender ; -TUPLE: service predicate quot enabled? ; -TUPLE: chat-command from to text ; -TUPLE: join-command channel password ; -TUPLE: part-command channel text ; - SYMBOL: irc-client -: irc-stream> ( -- stream ) irc-client get irc-client-stream ; -: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ; +: irc-client> ( -- irc-client ) irc-client get ; +: irc-stream> ( -- stream ) irc-client> stream>> ; + +: remove-heading-: ( seq -- seq ) dup ":" head? [ 1 tail ] when ; + : parse-name ( string -- string ) - trim-: "!" split first ; -: irc-split ( string -- seq ) - 1 swap [ [ CHAR: : = ] find* ] keep - swap [ swap cut trim-: ] [ nip f ] if >r [ blank? ] trim trim-: - " " split r> [ 1array append ] when* ; + remove-heading-: "!" split-at-first drop ; + +: sender>> ( obj -- string ) + prefix>> parse-name ; + +: split-prefix ( string -- string/f string ) + dup ":" head? + [ remove-heading-: " " split1 ] + [ f swap ] + if ; + +: split-trailing ( string -- string string/f ) + ":" split1 ; + +: string>irc-message ( string -- object ) + dup split-prefix split-trailing + [ [ blank? ] trim " " split unclip swap ] dip + now ; + : me? ( name -- ? ) - irc-client get irc-client-nick nick-name = ; + irc-client> nick>> name>> = ; : irc-write ( s -- ) irc-stream> stream-write ; @@ -89,123 +132,155 @@ SYMBOL: irc-client : irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ; -: nick ( nick -- ) +! Irc commands + +: NICK ( nick -- ) "NICK " irc-write irc-print ; -: login ( nick -- ) - dup nick +: LOGIN ( nick -- ) + dup NICK "USER " irc-write irc-write " hostname servername :irc.factor" irc-print ; -: connect* ( server port -- ) - utf8 irc-client get set-irc-client-stream ; +: CONNECT ( server port -- stream ) + latin1 ; -: connect ( server -- ) 6667 connect* ; - -: join ( channel password -- ) +: JOIN ( channel password -- ) "JOIN " irc-write - [ >r " :" r> 3append ] when* irc-print ; + [ " :" swap 3append ] when* irc-print ; -: part ( channel text -- ) - >r "PART " irc-write irc-write r> +: PART ( channel text -- ) + [ "PART " irc-write irc-write ] dip " :" irc-write irc-print ; -: say ( line nick -- ) - "PRIVMSG " irc-write irc-write " :" irc-write irc-print ; +: KICK ( channel who -- ) + [ "KICK " irc-write irc-write ] dip + " " irc-write irc-print ; + +: PRIVMSG ( nick line -- ) + [ "PRIVMSG " irc-write irc-write ] dip + " :" irc-write irc-print ; -: quit ( text -- ) +: SAY ( nick line -- ) + PRIVMSG ; + +: ACTION ( nick line -- ) + [ 1 , "ACTION " % % 1 , ] "" make PRIVMSG ; + +: QUIT ( text -- ) "QUIT :" irc-write irc-print ; +: join-channel ( channel-profile -- ) + [ name>> ] keep password>> JOIN ; +: irc-connect ( irc-client -- ) + [ profile>> [ server>> ] keep port>> CONNECT ] keep + swap >>stream t >>is-running drop ; + GENERIC: handle-irc ( obj -- ) M: object handle-irc ( obj -- ) - "Unhandled irc object" print drop ; + drop ; M: logged-in handle-irc ( obj -- ) - logged-in-name irc-client get [ irc-client-nick set-nick-name ] keep - - irc-client-profile profile-default-channels - [ - [ channel-profile-name ] keep - channel-profile-password join - ] each ; + name>> + irc-client> [ nick>> swap >>name drop ] keep + profile>> default-channels>> [ join-channel ] each ; M: ping handle-irc ( obj -- ) "PONG " irc-write - ping-name irc-print ; + trailing>> irc-print ; M: nick-in-use handle-irc ( obj -- ) - nick-in-use-name "_" append nick ; + name>> "_" append NICK ; -: delegate-timestamp ( obj -- obj ) - now over set-delegate ; +: parse-irc-line ( string -- message ) + string>irc-message + dup command>> { + { "PING" [ \ ping ] } + { "NOTICE" [ \ notice ] } + { "001" [ \ logged-in ] } + { "433" [ \ nick-in-use ] } + { "JOIN" [ \ join_ ] } + { "PART" [ \ part ] } + { "PRIVMSG" [ \ privmsg ] } + { "QUIT" [ \ quit ] } + { "MODE" [ \ mode ] } + { "KICK" [ \ kick ] } + [ drop \ unhandled ] + } case + [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ; -MATCH-VARS: ?name ?name2 ?channel ?text ?mode ; -SYMBOL: line -: match-irc ( string -- ) - dup line set - dup print flush - irc-split - { - { { "PING" ?name } - [ ?name ] } - { { ?name "001" ?name2 ?text } - [ ?name2 ?text ] } - { { ?name "433" _ ?name2 "Nickname is already in use." } - [ ?name2 ] } +! Reader +: handle-reader-message ( irc-client irc-message -- ) + dup handle-irc swap stream-channel>> to ; - { { ?name "JOIN" ?channel } - [ ?name ?channel ] } - { { ?name "PART" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "PRIVMSG" ?channel ?text } - [ ?name ?channel ?text ] } - { { ?name "QUIT" ?text } - [ ?name ?text ] } +: reader-loop ( irc-client -- ) + dup stream>> stream-readln [ + dup print parse-irc-line handle-reader-message + ] [ + f >>is-running + dup stream>> dispose + irc-end over controller-channel>> to + stream-channel>> irc-end swap to + ] if* ; - { { "NOTICE" ?name ?text } - [ ?name ?text ] } - { { ?name "MODE" ?channel ?mode ?text } - [ ?name ?channel ?mode ?text ] } - { { ?name "KICK" ?channel ?name2 ?text } - [ ?channel ?name ?name2 ?text ] } +! Controller commands +GENERIC: handle-command ( obj -- ) - ! { { ?name "353" ?name2 _ ?channel ?text } - ! [ ?text ?channel ?name2 make-member-list ] } - { _ [ line get ] } - } match-cond - delegate-timestamp handle-irc flush ; +M: object handle-command ( obj -- ) + . ; -: irc-loop ( -- ) - irc-stream> stream-readln - [ match-irc irc-loop ] when* ; +TUPLE: send-message to text ; +C: send-message +M: send-message handle-command ( obj -- ) + dup to>> swap text>> SAY ; +TUPLE: send-action to text ; +C: send-action +M: send-action handle-command ( obj -- ) + dup to>> swap text>> ACTION ; + +TUPLE: send-quit text ; +C: send-quit +M: send-quit handle-command ( obj -- ) + text>> QUIT ; + +: irc-listen ( irc-client quot -- ) + [ listeners>> ] [ ] bi* swap push ; + +! Controller loop +: controller-loop ( irc-client -- ) + controller-channel>> from handle-command ; + +! Multiplexer +: multiplex-message ( irc-client message -- ) + swap listeners>> [ channel>> ] map + [ '[ , , to ] "message" spawn drop ] each-with ; + +: multiplexer-loop ( irc-client -- ) + dup stream-channel>> from multiplex-message ; + +! process looping and starting +: (spawn-irc-loop) ( irc-client quot name -- ) + [ over >r curry r> '[ @ , is-running>> ] ] dip + spawn-server-linked drop ; + +: spawn-irc-loop ( irc-client quot name -- ) + '[ , , , [ (spawn-irc-loop) receive ] [ print ] recover ] + f spawn drop ; + +: spawn-irc ( irc-client -- ) + [ [ reader-loop ] "reader-loop" spawn-irc-loop ] + [ [ controller-loop ] "controller-loop" spawn-irc-loop ] + [ [ multiplexer-loop ] "multiplexer-loop" spawn-irc-loop ] + tri ; + : do-irc ( irc-client -- ) - dup irc-client set - dup irc-client-profile profile-server - over irc-client-profile profile-port connect* - dup irc-client-profile profile-nickname login - [ irc-loop ] [ irc-stream> dispose ] [ ] cleanup ; - -: with-infinite-loop ( quot timeout -- quot timeout ) - "looping" print flush - over [ drop ] recover dup sleep with-infinite-loop ; - -: start-irc ( irc-client -- ) - ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; - [ do-irc ] curry 3000 with-infinite-loop ; - - -! For testing -: make-factorbot - "irc.freenode.org" 6667 "factorbot" f - [ - "#concatenative-flood" f f , - ] { } make - f V{ } clone V{ } clone - f f f ; - -: test-factorbot - make-factorbot start-irc ; - + irc-client [ + irc-client> + [ irc-connect ] + [ profile>> nickname>> LOGIN ] + [ spawn-irc ] + tri + ] with-variable ; \ No newline at end of file From 2cebf7e9e59790ba5a9531e33b4c6509f35f9c4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 18:51:56 -0500 Subject: [PATCH 012/146] Improve multi-methods: multi-var hooks --- .../multi-methods/multi-methods-tests.factor | 98 ------ extra/multi-methods/multi-methods.factor | 309 ++++++++++-------- extra/multi-methods/tests/canonicalize.factor | 66 ++++ extra/multi-methods/tests/definitions.factor | 37 +++ extra/multi-methods/tests/legacy.factor | 10 + extra/multi-methods/tests/syntax.factor | 58 ++++ .../tests/topological-sort.factor | 18 + 7 files changed, 357 insertions(+), 239 deletions(-) delete mode 100755 extra/multi-methods/multi-methods-tests.factor create mode 100644 extra/multi-methods/tests/canonicalize.factor create mode 100644 extra/multi-methods/tests/definitions.factor create mode 100644 extra/multi-methods/tests/legacy.factor create mode 100644 extra/multi-methods/tests/syntax.factor create mode 100644 extra/multi-methods/tests/topological-sort.factor diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor deleted file mode 100755 index 8910e64092..0000000000 --- a/extra/multi-methods/multi-methods-tests.factor +++ /dev/null @@ -1,98 +0,0 @@ -IN: multi-methods.tests -USING: multi-methods tools.test kernel math arrays sequences -prettyprint strings classes hashtables assocs namespaces -debugger continuations ; - -[ { 1 2 3 4 5 6 } ] [ - { 6 4 5 1 3 2 } [ <=> ] topological-sort -] unit-test - -[ -1 ] [ - { fixnum array } { number sequence } classes< -] unit-test - -[ 0 ] [ - { number sequence } { number sequence } classes< -] unit-test - -[ 1 ] [ - { object object } { number sequence } classes< -] unit-test - -[ - { - { { object integer } [ 1 ] } - { { object object } [ 2 ] } - { { POSTPONE: f POSTPONE: f } [ 3 ] } - } -] [ - { - { { integer } [ 1 ] } - { { } [ 2 ] } - { { f f } [ 3 ] } - } congruify-methods -] unit-test - -GENERIC: first-test - -[ t ] [ \ first-test generic? ] unit-test - -MIXIN: thing - -TUPLE: paper ; INSTANCE: paper thing -TUPLE: scissors ; INSTANCE: scissors thing -TUPLE: rock ; INSTANCE: rock thing - -GENERIC: beats? - -METHOD: beats? { paper scissors } t ; -METHOD: beats? { scissors rock } t ; -METHOD: beats? { rock paper } t ; -METHOD: beats? { thing thing } f ; - -: play ( obj1 obj2 -- ? ) beats? 2nip ; - -[ { } 3 play ] must-fail -[ t ] [ error get no-method? ] unit-test -[ ] [ error get error. ] unit-test -[ t ] [ T{ paper } T{ scissors } play ] unit-test -[ f ] [ T{ scissors } T{ paper } play ] unit-test - -[ t ] [ { beats? paper scissors } method-spec? ] unit-test -[ ] [ { beats? paper scissors } see ] unit-test - -GENERIC: legacy-test - -M: integer legacy-test sq ; -M: string legacy-test " hey" append ; - -[ 25 ] [ 5 legacy-test ] unit-test -[ "hello hey" ] [ "hello" legacy-test ] unit-test - -SYMBOL: some-var - -HOOK: hook-test some-var - -[ t ] [ \ hook-test hook-generic? ] unit-test - -METHOD: hook-test { array array } reverse ; -METHOD: hook-test { array } class ; -METHOD: hook-test { hashtable number } assoc-size ; - -{ 1 2 3 } some-var set -[ { f t t } ] [ { t t f } hook-test ] unit-test -[ fixnum ] [ 3 hook-test ] unit-test -5.0 some-var set -[ 0 ] [ H{ } hook-test ] unit-test - -MIXIN: busted - -TUPLE: busted-1 ; -TUPLE: busted-2 ; INSTANCE: busted-2 busted -TUPLE: busted-3 ; - -GENERIC: busted-sort - -METHOD: busted-sort { busted-1 busted-2 } ; -METHOD: busted-sort { busted-2 busted-3 } ; -METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 115432b14d..0276e1422c 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,13 +3,74 @@ USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units kernel.private effects ; +debugger io compiler.units kernel.private effects accessors +hashtables sorting shuffle ; IN: multi-methods -GENERIC: generic-prologue ( combination -- quot ) +! PART I: Converting hook specializers +: canonicalize-specializer-0 ( specializer -- specializer' ) + [ \ f or ] map ; -GENERIC: method-prologue ( combination -- quot ) +SYMBOL: args +SYMBOL: hooks + +SYMBOL: total + +: canonicalize-specializer-1 ( specializer -- specializer' ) + [ + [ class? ] subset + [ length [ 1+ neg ] map ] keep zip + [ length args [ max ] change ] keep + ] + [ + [ pair? ] subset + [ keys [ hooks get push-new ] each ] keep + ] bi append ; + +: canonicalize-specializer-2 ( specializer -- specializer' ) + [ + >r + { + { [ dup integer? ] [ ] } + { [ dup word? ] [ hooks get index ] } + } cond args get + r> + ] assoc-map ; + +: canonicalize-specializer-3 ( specializer -- specializer' ) + >r total get object dup r> update ; + +: canonicalize-specializers ( methods -- methods' hooks ) + [ + [ >r canonicalize-specializer-0 r> ] assoc-map + + 0 args set + V{ } clone hooks set + + [ >r canonicalize-specializer-1 r> ] assoc-map + + hooks [ natural-sort ] change + + [ >r canonicalize-specializer-2 r> ] assoc-map + + args get hooks get length + total set + + [ >r canonicalize-specializer-3 r> ] assoc-map + + hooks get + ] with-scope ; + +: drop-n-quot ( n -- quot ) \ drop >quotation ; + +: prepare-method ( method n -- quot ) + [ 1quotation ] [ drop-n-quot ] bi* prepend ; + +: prepare-methods ( methods -- methods' prologue ) + canonicalize-specializers + [ length [ prepare-method ] curry assoc-map ] keep + [ [ get ] curry ] map concat [ ] like ; + +! Part II: Topologically sorting specializers : maximal-element ( seq quot -- n elt ) dupd [ swapd [ call 0 < ] 2curry subset empty? @@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot ) } cond 2nip ] 2map [ zero? not ] find nip 0 or ; +: sort-methods ( alist -- alist' ) + [ [ first ] bi@ classes< ] topological-sort ; + +! PART III: Creating dispatch quotation : picker ( n -- quot ) { { 0 [ [ dup ] ] } @@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot ) unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: multi-dispatch-quot ( methods generic -- quot ) + "default-multi-method" word-prop 1quotation swap + [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + +! Generic words +PREDICATE: generic < word + "multi-methods" word-prop >boolean ; + : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: make-method-def ( quot classes generic -- quot ) +: make-generic ( generic -- quot ) [ - swap [ declare ] curry % - "multi-combination" word-prop method-prologue % - % + [ methods prepare-methods % sort-methods ] keep + multi-dispatch-quot % ] [ ] make ; -TUPLE: method word def classes generic loc ; +: update-generic ( word -- ) + dup make-generic define ; +! Methods PREDICATE: method-body < word - "multi-method" word-prop >boolean ; + "multi-method-generic" word-prop >boolean ; M: method-body stack-effect - "multi-method" word-prop method-generic stack-effect ; + "multi-method-generic" word-prop stack-effect ; M: method-body crossref? drop t ; -: method-word-name ( classes generic -- string ) +: method-word-name ( specializer generic -- string ) + [ word-name % "-" % unparse % ] "" make ; + +: method-word-props ( specializer generic -- assoc ) [ - word-name % - "-(" % [ "," % ] [ word-name % ] interleave ")" % - ] "" make ; + "multi-method-generic" set + "multi-method-specializer" set + ] H{ } make-assoc ; -: ( quot classes generic -- word ) - #! We xref here because the "multi-method" word-prop isn't - #! set yet so crossref? yields f. - [ make-method-def ] 2keep +: ( specializer generic -- word ) + [ method-word-props ] 2keep method-word-name f - dup rot define - dup xref ; + [ set-word-props ] keep ; -: ( quot classes generic -- method ) - [ ] 3keep f \ method construct-boa - dup method-word over "multi-method" set-word-prop ; +: with-methods ( word quot -- ) + over >r >r "multi-methods" word-prop + r> call r> update-generic ; inline + +: reveal-method ( method classes generic -- ) + [ set-at ] with-methods ; + +: method ( classes word -- method ) + "multi-methods" word-prop at ; + +: create-method ( classes generic -- method ) + 2dup method dup [ + 2nip + ] [ + drop [ dup ] 2keep reveal-method + ] if ; TUPLE: no-method arguments generic ; : no-method ( argument-count generic -- * ) >r narray r> \ no-method construct-boa throw ; inline -: argument-count ( methods -- n ) - dup assoc-empty? [ drop 0 ] [ - keys [ length ] map supremum - ] if ; - -: multi-dispatch-quot ( methods generic -- quot ) - >r [ - [ - >r multi-predicate r> method-word 1quotation - ] assoc-map - ] keep argument-count - r> [ no-method ] 2curry - swap reverse alist>quot ; - -: congruify-methods ( alist -- alist' ) - dup argument-count [ - swap >r object pad-left [ \ f or ] map r> - ] curry assoc-map ; - -: sorted-methods ( alist -- alist' ) - [ [ first ] bi@ classes< ] topological-sort ; - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. "Type check error" print nl - "Generic word " write dup no-method-generic pprint + "Generic word " write dup generic>> pprint " does not have a method applicable to inputs:" print - dup no-method-arguments short. + dup arguments>> short. nl "Inputs have signature:" print - dup no-method-arguments [ class ] map niceify-method . + dup arguments>> [ class ] map niceify-method . nl - "Defined methods in topological order: " print - no-method-generic - methods congruify-methods sorted-methods keys + "Available methods: " print + generic>> methods keys [ niceify-method ] map stack. ; -TUPLE: standard-combination ; +: make-default-method ( generic -- quot ) + [ 0 swap no-method ] curry ; -M: standard-combination method-prologue drop [ ] ; +: ( generic -- method ) + [ { } swap ] keep + [ drop ] [ make-default-method define ] 2bi ; -M: standard-combination generic-prologue drop [ ] ; +: define-default-method ( generic -- ) + dup "default-multi-method" set-word-prop ; -: make-generic ( generic -- quot ) - dup "multi-combination" word-prop generic-prologue swap - [ methods congruify-methods sorted-methods ] keep - multi-dispatch-quot append ; - -TUPLE: hook-combination var ; - -M: hook-combination method-prologue - drop [ drop ] ; - -M: hook-combination generic-prologue - hook-combination-var [ get ] curry ; - -: update-generic ( word -- ) - dup make-generic define ; - -: define-generic ( word combination -- ) - over "multi-combination" word-prop over = [ - 2drop - ] [ - dupd "multi-combination" set-word-prop - dup H{ } clone "multi-methods" set-word-prop - update-generic - ] if ; - -: define-standard-generic ( word -- ) - T{ standard-combination } define-generic ; - -: GENERIC: - CREATE define-standard-generic ; parsing - -: define-hook-generic ( word var -- ) - hook-combination construct-boa define-generic ; - -: HOOK: - CREATE scan-word define-hook-generic ; parsing - -: method ( classes word -- method ) - "multi-methods" word-prop at ; - -: with-methods ( word quot -- ) - over >r >r "multi-methods" word-prop - r> call r> update-generic ; inline - -: define-method ( quot classes generic -- ) - >r [ bootstrap-word ] map r> - [ ] 2keep - [ set-at ] with-methods ; - -: forget-method ( classes generic -- ) +: forget-method ( specializer generic -- ) [ delete-at ] with-methods ; : method>spec ( method -- spec ) - dup method-classes swap method-generic prefix ; + [ "multi-method-specializer" word-prop ] + [ "multi-method-generic" word-prop ] bi prefix ; + +: define-generic ( word -- ) + dup "multi-methods" word-prop [ + drop + ] [ + [ H{ } clone "multi-methods" set-word-prop ] + [ define-default-method ] + [ update-generic ] + tri + ] if ; + +! Syntax +: GENERIC: + CREATE define-generic ; parsing : parse-method ( -- quot classes generic ) - parse-definition dup 2 tail over second rot first ; + parse-definition [ 2 tail ] [ second ] [ first ] tri ; -: METHOD: - location - >r parse-method [ define-method ] 2keep prefix r> - remember-definition ; parsing +: create-method-in ( specializer generic -- method ) + create-method dup save-location f set-word ; + +: CREATE-METHOD + scan-word scan-object swap create-method-in ; + +: (METHOD:) CREATE-METHOD parse-definition ; + +: METHOD: (METHOD:) define ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot define-method ; parsing + scan-word 1array scan-word create-method-in + parse-definition + define ; parsing ! Definition protocol. We qualify core generics here USE: qualified QUALIFIED: syntax -PREDICATE: generic < word - "multi-combination" word-prop >boolean ; +syntax:M: generic definer drop \ GENERIC: f ; -PREDICATE: standard-generic < word - "multi-combination" word-prop standard-combination? ; - -PREDICATE: hook-generic < word - "multi-combination" word-prop hook-combination? ; - -syntax:M: standard-generic definer drop \ GENERIC: f ; - -syntax:M: standard-generic definition drop f ; - -syntax:M: hook-generic definer drop \ HOOK: f ; - -syntax:M: hook-generic definition drop f ; - -syntax:M: hook-generic synopsis* - dup definer. - dup seeing-word - dup pprint-word - dup "multi-combination" word-prop - hook-combination-var pprint-word stack-effect. ; +syntax:M: generic definition drop f ; PREDICATE: method-spec < array unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method [ method-loc ] [ second where ] ?if ; + dup unclip method [ ] [ first ] ?if where ; syntax:M: method-spec set-where - unclip method set-method-loc ; + unclip method set-where ; syntax:M: method-spec definer - drop \ METHOD: \ ; ; + unclip method definer ; syntax:M: method-spec definition - unclip method dup [ method-def ] when ; + unclip method definition ; syntax:M: method-spec synopsis* - dup definer. - unclip pprint* pprint* ; + unclip method synopsis* ; syntax:M: method-spec forget* - unclip forget-method ; + unclip method forget* ; + +syntax:M: method-body definer + drop \ METHOD: \ ; ; + +syntax:M: method-body synopsis* + dup definer. + [ "multi-method-generic" word-prop pprint-word ] + [ "multi-method-specializer" word-prop pprint* ] bi ; diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor new file mode 100644 index 0000000000..d5baf4914c --- /dev/null +++ b/extra/multi-methods/tests/canonicalize.factor @@ -0,0 +1,66 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings ; + +[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test + +: setup-canon-test + 0 args set + V{ } clone hooks set ; + +: canon-test-1 + { integer { cpu x86 } sequence } canonicalize-specializer-1 ; + +[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [ + [ + setup-canon-test + canon-test-1 + ] with-scope +] unit-test + +[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [ + [ + setup-canon-test + canon-test-1 + canonicalize-specializer-2 + ] with-scope +] unit-test + +[ { integer sequence x86 } ] [ + [ + setup-canon-test + canon-test-1 + canonicalize-specializer-2 + args get hooks get length + total set + canonicalize-specializer-3 + ] with-scope +] unit-test + +: example-1 + { + { { { cpu x86 } { os linux } } "a" } + { { { cpu ppc } } "b" } + { { string { os windows } } "c" } + } ; + +[ + { + { { object x86 linux } "a" } + { { object ppc object } "b" } + { { string object windows } "c" } + } + V{ cpu os } +] [ + example-1 canonicalize-specializers +] unit-test + +[ + { + { { object x86 linux } [ drop drop "a" ] } + { { object ppc object } [ drop drop "b" ] } + { { string object windows } [ drop drop "c" ] } + } + [ \ cpu get \ os get ] +] [ + example-1 prepare-methods +] unit-test diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor new file mode 100644 index 0000000000..60ddd32875 --- /dev/null +++ b/extra/multi-methods/tests/definitions.factor @@ -0,0 +1,37 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings words compiler.units quotations ; + +\ GENERIC: must-infer +\ create-method-in must-infer +\ define-default-method must-infer + +DEFER: fake +\ fake H{ } clone "multi-methods" set-word-prop + +[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test + +[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ] +[ { } \ fake method-word-props ] unit-test + +[ t ] [ { } \ fake method-body? ] unit-test + +[ + [ ] [ \ fake define-default-method ] unit-test + + [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test + + [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test + + [ t ] [ \ fake make-generic quotation? ] unit-test + + [ ] [ \ fake update-generic ] unit-test + + DEFER: testing + + [ ] [ \ testing define-generic ] unit-test + + [ t ] [ \ testing generic? ] unit-test + + [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test +] with-compilation-unit diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor new file mode 100644 index 0000000000..f4bd0a00b2 --- /dev/null +++ b/extra/multi-methods/tests/legacy.factor @@ -0,0 +1,10 @@ +IN: multi-methods.tests +USING: math strings sequences tools.test ; + +GENERIC: legacy-test + +M: integer legacy-test sq ; +M: string legacy-test " hey" append ; + +[ 25 ] [ 5 legacy-test ] unit-test +[ "hello hey" ] [ "hello" legacy-test ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor new file mode 100644 index 0000000000..5e2e86d04b --- /dev/null +++ b/extra/multi-methods/tests/syntax.factor @@ -0,0 +1,58 @@ +IN: multi-methods.tests +USING: multi-methods tools.test math sequences namespaces system +kernel strings definitions prettyprint debugger arrays +hashtables continuations classes assocs ; + +GENERIC: first-test + +[ t ] [ \ first-test generic? ] unit-test + +MIXIN: thing + +SINGLETON: paper INSTANCE: paper thing +SINGLETON: scissors INSTANCE: scissors thing +SINGLETON: rock INSTANCE: rock thing + +GENERIC: beats? + +METHOD: beats? { paper scissors } t ; +METHOD: beats? { scissors rock } t ; +METHOD: beats? { rock paper } t ; +METHOD: beats? { thing thing } f ; + +: play ( obj1 obj2 -- ? ) beats? 2nip ; + +[ { } 3 play ] must-fail +[ t ] [ error get no-method? ] unit-test +[ ] [ error get error. ] unit-test +[ t ] [ paper scissors play ] unit-test +[ f ] [ scissors paper play ] unit-test + +[ t ] [ { beats? paper scissors } method-spec? ] unit-test +[ ] [ { beats? paper scissors } see ] unit-test + +SYMBOL: some-var + +GENERIC: hook-test + +METHOD: hook-test { array { some-var array } } reverse ; +METHOD: hook-test { { some-var array } } class ; +METHOD: hook-test { hashtable { some-var number } } assoc-size ; + +{ 1 2 3 } some-var set +[ { f t t } ] [ { t t f } hook-test ] unit-test +[ fixnum ] [ 3 hook-test ] unit-test +5.0 some-var set +[ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor new file mode 100644 index 0000000000..ed8bece4ba --- /dev/null +++ b/extra/multi-methods/tests/topological-sort.factor @@ -0,0 +1,18 @@ +IN: multi-methods.tests +USING: kernel multi-methods tools.test math arrays sequences ; + +[ { 1 2 3 4 5 6 } ] [ + { 6 4 5 1 3 2 } [ <=> ] topological-sort +] unit-test + +[ -1 ] [ + { fixnum array } { number sequence } classes< +] unit-test + +[ 0 ] [ + { number sequence } { number sequence } classes< +] unit-test + +[ 1 ] [ + { object object } { number sequence } classes< +] unit-test From a82794a71910cfaea3471a95db65e8d101a95557 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:12:48 -0500 Subject: [PATCH 013/146] Fixing error reporting --- extra/multi-methods/multi-methods.factor | 35 ++++++++------------ extra/multi-methods/tests/definitions.factor | 5 +-- extra/multi-methods/tests/syntax.factor | 8 ++++- 3 files changed, 22 insertions(+), 26 deletions(-) diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 0276e1422c..8f9e34b1fb 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -117,9 +117,18 @@ SYMBOL: total unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: argument-count ( methods -- n ) + keys 0 [ length max ] reduce ; + +ERROR: no-method arguments generic ; + +: make-default-method ( methods generic -- quot ) + >r argument-count r> [ >r narray r> no-method ] 2curry ; + : multi-dispatch-quot ( methods generic -- quot ) - "default-multi-method" word-prop 1quotation swap - [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + [ make-default-method ] + [ drop [ >r multi-predicate r> ] assoc-map reverse ] + 2bi alist>quot ; ! Generic words PREDICATE: generic < word @@ -178,11 +187,6 @@ M: method-body crossref? drop [ dup ] 2keep reveal-method ] if ; -TUPLE: no-method arguments generic ; - -: no-method ( argument-count generic -- * ) - >r narray r> \ no-method construct-boa throw ; inline - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. @@ -196,18 +200,8 @@ M: no-method error. dup arguments>> [ class ] map niceify-method . nl "Available methods: " print - generic>> methods keys - [ niceify-method ] map stack. ; - -: make-default-method ( generic -- quot ) - [ 0 swap no-method ] curry ; - -: ( generic -- method ) - [ { } swap ] keep - [ drop ] [ make-default-method define ] 2bi ; - -: define-default-method ( generic -- ) - dup "default-multi-method" set-word-prop ; + generic>> methods canonicalize-specializers drop sort-methods + keys [ niceify-method ] map stack. ; : forget-method ( specializer generic -- ) [ delete-at ] with-methods ; @@ -221,9 +215,8 @@ M: no-method error. drop ] [ [ H{ } clone "multi-methods" set-word-prop ] - [ define-default-method ] [ update-generic ] - tri + bi ] if ; ! Syntax diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 60ddd32875..fea8f0c402 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -4,7 +4,6 @@ kernel strings words compiler.units quotations ; \ GENERIC: must-infer \ create-method-in must-infer -\ define-default-method must-infer DEFER: fake \ fake H{ } clone "multi-methods" set-word-prop @@ -17,11 +16,9 @@ DEFER: fake [ t ] [ { } \ fake method-body? ] unit-test [ - [ ] [ \ fake define-default-method ] unit-test - [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test - [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test + [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test [ t ] [ \ fake make-generic quotation? ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 5e2e86d04b..597a1cebeb 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays -hashtables continuations classes assocs ; +hashtables continuations classes assocs accessors ; GENERIC: first-test @@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ; [ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test +[ { { } 3 } ] [ error get arguments>> ] unit-test [ t ] [ paper scissors play ] unit-test [ f ] [ scissors paper play ] unit-test @@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ; 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test +"error" some-var set +[ H{ } hook-test ] must-fail +[ t ] [ error get no-method? ] unit-test +[ { H{ } "error" } ] [ error get arguments>> ] unit-test + MIXIN: busted TUPLE: busted-1 ; From 9c19ade9810857c98cf41228f59982736ef53d5b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 19:43:54 -0500 Subject: [PATCH 014/146] Fix library path --- extra/db/postgresql/ffi/ffi.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7f428bb6b6..ee5ba622e5 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,8 +6,7 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } - ! { [ os macosx? ] [ "libpq.dylib" ] } + { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> From 0dd8e462c6dc31065dcdee6d33913edd3a3688e5 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Wed, 9 Apr 2008 12:52:49 +1200 Subject: [PATCH 015/146] Minor peg refactorings --- extra/peg/peg.factor | 75 +++++++++++++++++++++++--------------------- 1 file changed, 40 insertions(+), 35 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 3b1d408ae2..7390c15684 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -30,6 +30,9 @@ SYMBOL: fail SYMBOL: lrstack SYMBOL: heads +: failed? ( obj -- ? ) + fail = ; + : delegates ( -- cache ) \ delegates get-global [ H{ } clone dup \ delegates set-global ] unless* ; @@ -66,21 +69,18 @@ C: peg-head #! that maps the position to the parser result. id>> packrat get [ drop H{ } clone ] cache ; +: process-rule-result ( p result -- result ) + [ + nip [ ast>> ] [ remaining>> ] bi input-from pos set + ] [ + pos set fail + ] if* ; + : eval-rule ( rule -- ast ) #! Evaluate a rule, return an ast resulting from it. #! Return fail if the rule failed. The rule has #! stack effect ( input -- parse-result ) - pos get swap - execute -! drop f f - [ - nip - [ ast>> ] [ remaining>> ] bi - input-from pos set - ] [ - pos set - fail - ] if* ; inline + pos get swap execute process-rule-result ; inline : memo ( pos rule -- memo-entry ) #! Return the result from the memo cache. @@ -90,21 +90,29 @@ C: peg-head #! Store an entry in the cache rule-parser input-cache set-at ; -:: (grow-lr) ( r p m h -- ) - p pos set - h involved-set>> clone h (>>eval-set) +: update-m ( ast m -- ) + swap >>ans pos get >>pos drop ; + +: stop-growth? ( ast m -- ? ) + [ failed? pos get ] dip + pos>> <= or ; + +: setup-growth ( h p -- ) + pos set dup involved-set>> clone >>eval-set drop ; + +:: (grow-lr) ( h p r m -- ) + h p setup-growth r eval-rule - dup fail = pos get m pos>> <= or [ + dup m stop-growth? [ drop ] [ - m (>>ans) - pos get m (>>pos) - r p m h (grow-lr) + m update-m + h p r m (grow-lr) ] if ; inline -:: grow-lr ( r p m h -- ast ) +:: grow-lr ( h p r m -- ast ) h p heads get set-at - r p m h (grow-lr) + h p r m (grow-lr) p heads get delete-at m pos>> pos set m ans>> ; inline @@ -128,10 +136,10 @@ C: peg-head | h rule>> r eq? [ m ans>> seed>> m (>>ans) - m ans>> fail = [ + m ans>> failed? [ fail ] [ - r p m h grow-lr + h p r m grow-lr ] if ] [ m ans>> seed>> @@ -150,8 +158,7 @@ C: peg-head r h eval-set>> member? [ h [ r swap remove ] change-eval-set drop r eval-rule - m (>>ans) - pos get m (>>pos) + m update-m m ] [ m @@ -207,20 +214,18 @@ C: peg-head GENERIC: (compile) ( parser -- quot ) +: execute-parser ( word -- result ) + pos get apply-rule dup failed? [ + drop f + ] [ + input-slice swap + ] if ; inline -:: parser-body ( parser -- quot ) +: parser-body ( parser -- quot ) #! Return the body of the word that is the compiled version #! of the parser. - [let* | rule [ gensym dup parser (compile) 0 1 define-declared dup parser "peg" set-word-prop ] - | - [ - rule pos get apply-rule dup fail = [ - drop f - ] [ - input-slice swap - ] if - ] - ] ; + gensym 2dup swap (compile) 0 1 define-declared swap dupd "peg" set-word-prop + [ execute-parser ] curry ; : compiled-parser ( parser -- word ) #! Look to see if the given parser has been compiled. From 411a13756395cbf142d7212868cc8512eff50aff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 21:29:37 -0500 Subject: [PATCH 016/146] Fix unit test --- extra/multi-methods/tests/definitions.factor | 2 -- 1 file changed, 2 deletions(-) diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index fea8f0c402..c112a67776 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -29,6 +29,4 @@ DEFER: fake [ ] [ \ testing define-generic ] unit-test [ t ] [ \ testing generic? ] unit-test - - [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test ] with-compilation-unit From 6c5935a3b0e604afa7606384f66183bbfc87e577 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:08:11 -0500 Subject: [PATCH 017/146] add set-os-env, unset-os-env --- core/bootstrap/primitives.factor | 2 ++ core/inference/known-words/known-words.factor | 4 ++++ vm/os-unix.c | 15 +++++++++++++++ vm/primitives.c | 2 ++ vm/run.h | 2 ++ 5 files changed, 25 insertions(+) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 233de6f4ee..9d3c28b068 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -732,6 +732,8 @@ define-builtin { "set-innermost-frame-quot" "kernel.private" } { "call-clear" "kernel" } { "(os-envs)" "system.private" } + { "set-os-env" "system" } + { "unset-os-env" "system" } { "(set-os-envs)" "system.private" } { "resize-byte-array" "byte-arrays" } { "resize-bit-array" "bit-arrays" } diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 33a5da87f4..453e2460b0 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -587,6 +587,10 @@ set-primitive-effect \ (os-envs) { } { array } set-primitive-effect +\ set-os-env { string string } { } set-primitive-effect + +\ unset-os-env { string } { } set-primitive-effect + \ (set-os-envs) { array } { } set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop diff --git a/vm/os-unix.c b/vm/os-unix.c index 74320288aa..2991cde78c 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -103,6 +103,21 @@ DEFINE_PRIMITIVE(os_envs) dpush(result); } +DEFINE_PRIMITIVE(set_os_env) +{ + char *key = unbox_char_string(); + REGISTER_C_STRING(key); + char *value = unbox_char_string(); + UNREGISTER_C_STRING(key); + setenv(key, value, 1); +} + +DEFINE_PRIMITIVE(unset_os_env) +{ + char *key = unbox_char_string(); + unsetenv(key); +} + DEFINE_PRIMITIVE(set_os_envs) { F_ARRAY *array = untag_array(dpop()); diff --git a/vm/primitives.c b/vm/primitives.c index 533fcebc9a..2906a154a2 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -182,6 +182,8 @@ void *primitives[] = { primitive_set_innermost_stack_frame_quot, primitive_call_clear, primitive_os_envs, + primitive_set_os_env, + primitive_unset_os_env, primitive_set_os_envs, primitive_resize_byte_array, primitive_resize_bit_array, diff --git a/vm/run.h b/vm/run.h index c112c5f587..e2afb08525 100755 --- a/vm/run.h +++ b/vm/run.h @@ -249,6 +249,8 @@ DECLARE_PRIMITIVE(setenv); DECLARE_PRIMITIVE(exit); DECLARE_PRIMITIVE(os_env); DECLARE_PRIMITIVE(os_envs); +DECLARE_PRIMITIVE(set_os_env); +DECLARE_PRIMITIVE(unset_os_env); DECLARE_PRIMITIVE(set_os_envs); DECLARE_PRIMITIVE(eq); DECLARE_PRIMITIVE(millis); From c19505cd844e9fb14fffadf937bdfee7d52089b4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 8 Apr 2008 23:35:28 -0500 Subject: [PATCH 018/146] set-os-env on windows --- vm/os-windows.c | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/vm/os-windows.c b/vm/os-windows.c index 664df9e774..b3fc1c917f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,6 +215,21 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(set_os_env) +{ + char *key = unbox_char_string(); + REGISTER_C_STRING(key); + char *value = unbox_char_string(); + UNREGISTER_C_STRING(key); + SetEnvironmentVariable(key, value); +} + +DEFINE_PRIMITIVE(unset_os_env) +{ + char *key = unbox_char_string(); + SetEnvironmentVariable(key, f); +} + DEFINE_PRIMITIVE(set_os_envs) { not_implemented_error(); From 52bb93cf40a878577ce33ebd8f9766ffeab102cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:19:56 -0500 Subject: [PATCH 019/146] Working on faster refresh-all --- extra/tools/vocabs/monitor/monitor.factor | 39 +++++++++++----- extra/tools/vocabs/vocabs.factor | 57 ++++++++++++----------- 2 files changed, 56 insertions(+), 40 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 071f179676..ada539c60a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -1,24 +1,39 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel -vocabs.loader tools.vocabs namespaces continuations ; +vocabs vocabs.loader tools.vocabs namespaces continuations +sequences splitting assocs ; IN: tools.vocabs.monitor -! Use file system change monitoring to flush the tags/authors -! cache -SYMBOL: vocab-monitor +: vocab-dir>vocab-name ( path -- vocab ) + left-trim-separators right-trim-separators + { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; -: monitor-thread ( -- ) - vocab-monitor get-global - next-change 2drop - t sources-changed? set-global reset-cache ; +: path>vocab-name ( path -- vocab ) + dup ".factor" tail? [ parent-directory ] when + dup [ vocab-dir>vocab-name ] when ; -: start-monitor-thread +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: monitor-thread ( path monitor -- ) + #! On OS X, monitors give us the full path, so we chop it + #! off if its there. + next-change drop swap ?head drop + path>vocab-name changed-vocab reset-cache ; + +: start-monitor-thread ( root -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. + (normalize-path) dup t [ monitor-thread t ] 2curry + "Vocabulary monitor" spawn-server drop ; + +: start-monitor-threads ( -- ) [ - "" resource-path t vocab-monitor set-global - [ monitor-thread t ] "Vocabulary monitor" spawn-server drop + vocab-roots get [ start-monitor-thread ] each + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-thread ] "tools.vocabs.monitor" add-init-hook +[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 2f941ad2ce..825d2a6329 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -21,15 +21,15 @@ IN: tools.vocabs : vocab-tests ( vocab -- tests ) [ - dup vocab-tests-file [ , ] when* - vocab-tests-dir [ % ] when* + [ vocab-tests-file [ , ] when* ] + [ vocab-tests-dir [ % ] when* ] bi ] { } make ; : vocab-files ( vocab -- seq ) [ - dup vocab-source-path [ , ] when* - dup vocab-docs-path [ , ] when* - vocab-tests % + [ vocab-source-path [ , ] when* ] + [ vocab-docs-path [ , ] when* ] + [ vocab-tests % ] tri ] { } make ; : source-modified? ( path -- ? ) @@ -56,20 +56,27 @@ IN: tools.vocabs : modified-docs ( vocabs -- seq ) [ vocab-docs-path ] modified ; +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ delete-at* nip ] curry subset + ] when* ; + : to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs - dup modified-sources swap modified-docs ; + child-vocabs filter-changed + [ modified-sources ] [ modified-docs ] bi ; : vocab-heading. ( vocab -- ) nl "==== " write - dup vocab-name swap vocab write-object ":" print + [ vocab-name ] [ vocab write-object ] bi ":" print nl ; : load-error. ( triple -- ) - dup first vocab-heading. - dup second print-error - drop ; + [ first vocab-heading. ] [ second print-error ] bi ; : load-failures. ( failures -- ) [ load-error. nl ] each ; @@ -89,30 +96,24 @@ SYMBOL: failures ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) - 2dup - [ f swap set-vocab-docs-loaded? ] each - [ f swap set-vocab-source-loaded? ] each - append prune require-all load-failures. ; + [ + [ [ f swap set-vocab-source-loaded? ] each ] + [ [ f swap set-vocab-docs-loaded? ] each ] bi* + ] + [ append prune require-all load-failures. ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; -SYMBOL: sources-changed? +: refresh-all ( -- ) "" refresh ; -[ t sources-changed? set-global ] "tools.vocabs" add-init-hook - -: refresh-all ( -- ) - "" refresh f sources-changed? set-global ; - -MEMO: (vocab-file-contents) ( path -- lines ) - dup exists? [ utf8 file-lines ] [ drop f ] if ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-append-path dup [ (vocab-file-contents) ] when ; +MEMO: vocab-file-contents ( vocab name -- seq ) + vocab-append-path dup + [ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ; : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-append-path [ utf8 set-file-lines - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" @@ -261,7 +262,7 @@ MEMO: all-authors ( -- seq ) : reset-cache ( -- ) root-cache get-global clear-assoc - \ (vocab-file-contents) reset-memoized + \ vocab-file-contents reset-memoized \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; From 16fa44fc8222b15d81c6bb3295eb3a38b3835f2b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 00:22:25 -0500 Subject: [PATCH 020/146] Fix irc loading --- extra/irc/irc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 0105fc53bb..27f82b25eb 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays calendar combinators channels concurrency.messaging fry io io.encodings.8-bit io.sockets kernel math namespaces sequences - sequences.lib singleton splitting strings threads + sequences.lib splitting strings threads continuations classes.tuple ascii accessors ; IN: irc @@ -209,7 +209,7 @@ M: nick-in-use handle-irc ( obj -- ) { "KICK" [ \ kick ] } [ drop \ unhandled ] } case - [ [ tuple-slots ] [ parameters>> ] bi append ] dip add* >tuple ; + [ [ tuple-slots ] [ parameters>> ] bi append ] dip prefix >tuple ; ! Reader : handle-reader-message ( irc-client irc-message -- ) From c5229fcbd1a1148545c47ec6caa57c83ecfd5b40 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:32:18 -0500 Subject: [PATCH 021/146] add some docs for environment variables --- core/system/system-docs.factor | 35 ++++++++++++++++++++++++++++------ 1 file changed, 29 insertions(+), 6 deletions(-) diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor index df112bd786..d0b2cfb194 100755 --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -7,9 +7,7 @@ ABOUT: "system" ARTICLE: "system" "System interface" { $subsection "cpu" } { $subsection "os" } -"Reading environment variables:" -{ $subsection os-env } -{ $subsection os-envs } +{ $subsection "environment-variables" } "Getting the path to the Factor VM and image:" { $subsection vm } { $subsection image } @@ -19,7 +17,16 @@ ARTICLE: "system" "System interface" { $subsection exit } { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ; -ARTICLE: "cpu" "Processor Detection" +ARTICLE: "environment-variables" "Environment variables" +"Reading environment variables:" +{ $subsection os-env } +{ $subsection os-envs } +"Writing environment variables:" +{ $subsection set-os-env } +{ $subsection unset-os-env } +{ $subsection set-os-envs } ; + +ARTICLE: "cpu" "Processor detection" "Processor detection:" { $subsection cpu } "Supported processors:" @@ -30,7 +37,7 @@ ARTICLE: "cpu" "Processor Detection" "Processor families:" { $subsection x86 } ; -ARTICLE: "os" "Operating System Detection" +ARTICLE: "os" "Operating system detection" "Operating system detection:" { $subsection os } "Supported operating systems:" @@ -98,7 +105,23 @@ HELP: set-os-envs } { $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; -{ os-env os-envs set-os-envs } related-words +HELP: set-os-env ( value key -- ) +{ $values { "value" string } { "key" string } } +{ $description "Set an environment variable." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +HELP: unset-os-env ( key -- ) +{ $values { "key" string } } +{ $description "Unset an environment variable." } +{ $notes + "Names and values of environment variables are operating system-specific." +} +{ $errors "Windows CE has no concept of environment variables, so this word throws an error there." } ; + +{ os-env os-envs set-os-env unset-os-env set-os-envs } related-words HELP: image { $values { "path" "a pathname string" } } From d1cc5cc650461cff50e15ba4640f2e746e72dece Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 00:33:29 -0500 Subject: [PATCH 022/146] windows environment variables --- vm/os-windows.c | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/os-windows.c b/vm/os-windows.c index b3fc1c917f..77a32f6f9f 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -217,17 +217,17 @@ void sleep_millis(DWORD msec) DEFINE_PRIMITIVE(set_os_env) { - char *key = unbox_char_string(); + F_CHAR *key = unbox_u16_string(); REGISTER_C_STRING(key); - char *value = unbox_char_string(); + F_CHAR *value = unbox_u16_string(); UNREGISTER_C_STRING(key); SetEnvironmentVariable(key, value); } DEFINE_PRIMITIVE(unset_os_env) { - char *key = unbox_char_string(); - SetEnvironmentVariable(key, f); + F_CHAR *key = unbox_u16_string(); + SetEnvironmentVariable(key, NULL); } DEFINE_PRIMITIVE(set_os_envs) From c6e1347c6718c793dbb7d3949c48147e2e2259d5 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 22:36:49 -0700 Subject: [PATCH 023/146] Two small spelling fixes --- core/inference/backend/backend-docs.factor | 2 +- extra/io/monitors/monitors-docs.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 1d742e144a..32978d5814 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -4,7 +4,7 @@ kernel.private combinators sequences.private ; HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } -{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile of the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; +{ $notes "This error will be thrown when compiling any combinator, such as " { $link each } ". However, words calling combinators can compile if the combinator is declared " { $link POSTPONE: inline } " and the quotation being passed in is a literal." } ; HELP: too-many->r { $error-description "Thrown if inference notices a quotation pushing elements on the retain stack without popping them at the end." } diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 76a354b0bd..4f24879e19 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } From 639871900a65a25617fed0ee19342e6cd4971dac Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Tue, 8 Apr 2008 23:22:28 -0700 Subject: [PATCH 024/146] Import extra/unionfind, a disjoint set datastructure --- extra/unionfind/authors.txt | 1 + extra/unionfind/summary.txt | 1 + extra/unionfind/unionfind.factor | 71 ++++++++++++++++++++++++++++++++ 3 files changed, 73 insertions(+) create mode 100644 extra/unionfind/authors.txt create mode 100644 extra/unionfind/summary.txt create mode 100644 extra/unionfind/unionfind.factor diff --git a/extra/unionfind/authors.txt b/extra/unionfind/authors.txt new file mode 100644 index 0000000000..16e1588016 --- /dev/null +++ b/extra/unionfind/authors.txt @@ -0,0 +1 @@ +Eric Mertens diff --git a/extra/unionfind/summary.txt b/extra/unionfind/summary.txt new file mode 100644 index 0000000000..c282cc29bb --- /dev/null +++ b/extra/unionfind/summary.txt @@ -0,0 +1 @@ +A efficient implementation of a disjoint-set datastructure diff --git a/extra/unionfind/unionfind.factor b/extra/unionfind/unionfind.factor new file mode 100644 index 0000000000..1f0d8be927 --- /dev/null +++ b/extra/unionfind/unionfind.factor @@ -0,0 +1,71 @@ +USING: accessors arrays combinators kernel math sequences namespaces ; + +IN: unionfind + +> nth ; + +: add-count ( p a -- ) + count [ + ] curry uf get counts>> swap change-nth ; + +: parent ( a -- p ) + uf get parents>> nth ; + +: set-parent ( p a -- ) + uf get parents>> set-nth ; + +: link-sets ( p a -- ) + [ set-parent ] + [ add-count ] 2bi ; + +: rank ( a -- r ) + uf get ranks>> nth ; + +: inc-rank ( a -- ) + uf get ranks>> [ 1+ ] change-nth ; + +: topparent ( a -- p ) + [ parent ] keep + 2dup = [ + [ topparent ] dip + 2dup set-parent + ] unless drop ; + +PRIVATE> + +: ( n -- unionfind ) + [ >array ] + [ 0 ] + [ 1 ] tri + unionfind construct-boa ; + +: equiv-set-size ( a uf -- n ) + uf [ topparent count ] with-variable ; + +: equiv? ( a b uf -- ? ) + uf [ [ topparent ] bi@ = ] with-variable ; + +: equate ( a b uf -- ) + uf [ + [ topparent ] bi@ + 2dup [ rank ] compare sgn + { + { -1 [ swap link-sets ] } + { 1 [ link-sets ] } + { 0 [ + 2dup = + [ 2drop ] + [ + [ link-sets ] + [ drop inc-rank ] 2bi + ] if + ] + } + } case + ] with-variable ; From 8d8c39ecca0496b8e684a810211c6f662ed0ac36 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:21 -0500 Subject: [PATCH 025/146] Fix circularity --- core/inference/backend/backend-docs.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/core/inference/backend/backend-docs.factor b/core/inference/backend/backend-docs.factor index 32978d5814..0125f04efa 100755 --- a/core/inference/backend/backend-docs.factor +++ b/core/inference/backend/backend-docs.factor @@ -1,6 +1,7 @@ USING: help.syntax help.markup words effects inference.dataflow -inference.state inference.backend kernel sequences +inference.state kernel sequences kernel.private combinators sequences.private ; +IN: inference.backend HELP: literal-expected { $error-description "Thrown when inference encounters a " { $link call } " or " { $link if } " being applied to a value which is not known to be a literal. Such a form can have an arbitrary stack effect, and does not compile." } From 6b16f7082257ab897c9d6e9f0a1cb54c618dbc6e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:53:29 -0500 Subject: [PATCH 026/146] Try a different strategy --- .../tools/vocabs/monitor/monitor-tests.factor | 6 +++++ extra/tools/vocabs/monitor/monitor.factor | 26 +++++++++++++------ 2 files changed, 24 insertions(+), 8 deletions(-) create mode 100644 extra/tools/vocabs/monitor/monitor-tests.factor diff --git a/extra/tools/vocabs/monitor/monitor-tests.factor b/extra/tools/vocabs/monitor/monitor-tests.factor new file mode 100644 index 0000000000..f1eece91c2 --- /dev/null +++ b/extra/tools/vocabs/monitor/monitor-tests.factor @@ -0,0 +1,6 @@ +USING: tools.test tools.vocabs.monitor io.files ; +IN: tools.vocabs.monitor.tests + +[ "kernel" ] [ "core/kernel/kernel.factor" path>vocab ] unit-test +[ "kernel" ] [ "core/kernel/" path>vocab ] unit-test +[ "kernel" ] [ "core/kernel/" resource-path path>vocab ] unit-test diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index ada539c60a..b96f76d3ba 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -11,27 +11,37 @@ IN: tools.vocabs.monitor : path>vocab-name ( path -- vocab ) dup ".factor" tail? [ parent-directory ] when - dup [ vocab-dir>vocab-name ] when ; + ; + +: chop-vocab-root ( path -- path' ) + "resource:" prepend-path (normalize-path) + dup vocab-roots get + [ (normalize-path) ] map + [ head? ] with find nip + ?head drop ; + +: path>vocab ( path -- vocab ) + chop-vocab-root path>vocab-name vocab-dir>vocab-name ; : changed-vocab ( vocab -- ) dup vocab [ dup changed-vocabs get-global set-at ] [ drop ] if ; -: monitor-thread ( path monitor -- ) +: monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop swap ?head drop - path>vocab-name changed-vocab reset-cache ; + next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( root -- ) +: start-monitor-thread ( monitor -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - (normalize-path) dup t [ monitor-thread t ] 2curry - "Vocabulary monitor" spawn-server drop ; + [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server + drop ; : start-monitor-threads ( -- ) [ - vocab-roots get [ start-monitor-thread ] each + "" resource-path t start-monitor-thread H{ } clone changed-vocabs set-global vocabs [ changed-vocab ] each ] ignore-errors ; From 17931bb5353c3ea994a1bc15890fa7510e93da7a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 02:56:17 -0500 Subject: [PATCH 027/146] Add command-line switch for disabling the refresh-all monitor --- extra/tools/vocabs/monitor/monitor.factor | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index b96f76d3ba..867c3b2903 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: threads io.files io.monitors init kernel vocabs vocabs.loader tools.vocabs namespaces continuations -sequences splitting assocs ; +sequences splitting assocs command-line ; IN: tools.vocabs.monitor : vocab-dir>vocab-name ( path -- vocab ) @@ -32,18 +32,20 @@ IN: tools.vocabs.monitor #! off if its there. next-change drop path>vocab changed-vocab reset-cache ; -: start-monitor-thread ( monitor -- ) +: start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server - drop ; - -: start-monitor-threads ( -- ) [ - "" resource-path t start-monitor-thread + "" resource-path t [ monitor-thread t ] curry + "Vocabulary monitor" spawn-server drop + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each ] ignore-errors ; -[ start-monitor-threads ] "tools.vocabs.monitor" add-init-hook +[ + "-no-monitors" cli-args get member? [ + start-monitor-thread + ] unless +] "tools.vocabs.monitor" add-init-hook From 5204d7065c25c8d73b00d9fa96756f9daac1dc0f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 03:00:15 -0500 Subject: [PATCH 028/146] Improve docs --- core/inference/inference-docs.factor | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index a837cfce5e..e32c94ed37 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -79,6 +79,18 @@ ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" "The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." $nl ; +ARTICLE: "inference-errors" "Inference errors" +"Main wrapper for all inference errors:" +{ $subsection inference-error } +"Specific inference errors:" +{ $subsection no-effect } +{ $subsection literal-expected } +{ $subsection too-many->r } +{ $subsection too-many-r> } +{ $subsection unbalanced-branches-error } +{ $subsection effect-error } +{ $subsection recursive-declare-error } ; + ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." $nl @@ -93,7 +105,8 @@ $nl { $subsection "inference-combinators" } { $subsection "inference-branches" } { $subsection "inference-recursive" } -{ $subsection "inference-limitations" } +{ $subsection "inference-limitations" } +{ $subsection "inference-errors" } { $subsection "dataflow-graphs" } { $subsection "compiler-transforms" } ; @@ -105,16 +118,7 @@ HELP: inference-error { $error-description "Thrown by " { $link infer } " and " { $link dataflow } " when the stack effect of a quotation cannot be inferred." $nl - "The " { $snippet "error" } " slot contains one of the following classes of errors, which indicate the specific issue preventing a stack effect from being inferred:" - { $list - { $link no-effect } - { $link literal-expected } - { $link too-many->r } - { $link too-many-r> } - { $link unbalanced-branches-error } - { $link effect-error } - { $link recursive-declare-error } - } + "The " { $snippet "error" } " slot contains one of several possible " { $link "inference-errors" } "." } ; From 20148a1106dafacee41b5fc1f54d7ef76f3dfcc4 Mon Sep 17 00:00:00 2001 From: Eric Mertens Date: Wed, 9 Apr 2008 01:20:45 -0700 Subject: [PATCH 029/146] Minor typo corrections in cookbook.factor --- extra/help/cookbook/cookbook.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/help/cookbook/cookbook.factor b/extra/help/cookbook/cookbook.factor index 075ce2d0e8..f1d4ac4ca7 100755 --- a/extra/help/cookbook/cookbook.factor +++ b/extra/help/cookbook/cookbook.factor @@ -224,7 +224,7 @@ $nl ":errors - print 2 compiler errors." ":warnings - print 50 compiler warnings." } -"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations." +"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations." { $references "To learn more about the compiler and static stack effect inference, read these articles:" "compiler" @@ -259,7 +259,7 @@ $nl { $code "#! /usr/bin/env factor -script" } "Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "." $nl -"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes." +"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes." { $references { } "cli" @@ -273,7 +273,7 @@ $nl $nl "Keep the following guidelines in mind to avoid losing your sense of balance:" { $list - "SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." + "Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines." "In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code." "If your code looks repetitive, factor it some more." "If after factoring, your code still looks repetitive, introduce combinators." @@ -285,7 +285,7 @@ $nl "Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition." { "Learn to use the " { $link "inference" } " tool." } { "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." } - "Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution." + "Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution." { "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." } { "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." } { "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." } @@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid" $nl "Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:" { $code "\"inference\" test" } - "In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } + "In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." } { "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." } { "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." } } ; From 02886132f3b667d5eb03edb4a97a337d2f1f3ff4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 12:50:58 -0500 Subject: [PATCH 030/146] add [un]set-os-env tests --- core/system/system-tests.factor | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/core/system/system-tests.factor b/core/system/system-tests.factor index 14e34ccb17..d5a48080c2 100755 --- a/core/system/system-tests.factor +++ b/core/system/system-tests.factor @@ -12,3 +12,10 @@ os unix? [ [ ] [ "envs" get set-os-envs ] unit-test [ t ] [ os-envs "envs" get = ] unit-test ] when + +[ ] [ "factor-test-key-1" unset-os-env ] unit-test +[ ] [ "ps3" "factor-test-key-1" set-os-env ] unit-test +[ "ps3" ] [ "factor-test-key-1" os-env ] unit-test +[ ] [ "factor-test-key-1" unset-os-env ] unit-test +[ f ] [ "factor-test-key-1" os-env ] unit-test + From d748c367c0d373c4f6575931cfecb1f923c98a24 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 14:01:04 -0500 Subject: [PATCH 031/146] ppc64 architecture is now recognized --- build-support/factor.sh | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/build-support/factor.sh b/build-support/factor.sh index ea0c35aa83..4bcd9e3086 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,6 +89,11 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; + netbsd) if [[ $WORD -eq 64 ]] ; then + CC=/usr/pkg/gcc34/bin/gcc + else + CC=gcc + fi ;; *) CC=gcc;; esac } @@ -185,6 +190,7 @@ find_architecture() { i386) ARCH=x86;; i686) ARCH=x86;; amd64) ARCH=x86;; + ppc64) ARCH=ppc;; *86) ARCH=x86;; *86_64) ARCH=x86;; "Power Macintosh") ARCH=ppc;; From 409d984c3c35a233e25b7e3e90e563bf83e9c3b3 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:57:21 -0500 Subject: [PATCH 032/146] move os_env from run to os-unix.c/os-windows.c --- vm/os-unix.c | 10 ++++++++++ vm/os-windows.c | 21 ++++++++++++++++++--- vm/run.c | 10 ---------- 3 files changed, 28 insertions(+), 13 deletions(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index 2991cde78c..6363ce68a9 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } +DEFINE_PRIMITIVE(os_env) +{ + char *name = unbox_char_string(); + char *value = getenv(name); + if(value == NULL) + dpush(F); + else + box_char_string(value); +} + DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.c b/vm/os-windows.c index 77a32f6f9f..136168807a 100755 --- a/vm/os-windows.c +++ b/vm/os-windows.c @@ -215,19 +215,34 @@ void sleep_millis(DWORD msec) Sleep(msec); } +DEFINE_PRIMITIVE(os_env) +{ + F_CHAR *key = unbox_u16_string(); + F_CHAR *value = safe_malloc(MAX_UNICODE_PATH); + int ret; + ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH); + if(ret == 0) + dpush(F); + else + dpush(tag_object(from_u16_string(value))); + free(value); +} + DEFINE_PRIMITIVE(set_os_env) { F_CHAR *key = unbox_u16_string(); REGISTER_C_STRING(key); F_CHAR *value = unbox_u16_string(); UNREGISTER_C_STRING(key); - SetEnvironmentVariable(key, value); + if(!SetEnvironmentVariable(key, value)) + general_error(ERROR_IO, tag_object(get_error_message()), F, NULL); } DEFINE_PRIMITIVE(unset_os_env) { - F_CHAR *key = unbox_u16_string(); - SetEnvironmentVariable(key, NULL); + if(!SetEnvironmentVariable(unbox_u16_string(), NULL) + && GetLastError() != ERROR_ENVVAR_NOT_FOUND) + general_error(ERROR_IO, tag_object(get_error_message()), F, NULL); } DEFINE_PRIMITIVE(set_os_envs) diff --git a/vm/run.c b/vm/run.c index 282be0a447..ae0c91d9e6 100755 --- a/vm/run.c +++ b/vm/run.c @@ -280,16 +280,6 @@ DEFINE_PRIMITIVE(exit) exit(to_fixnum(dpop())); } -DEFINE_PRIMITIVE(os_env) -{ - char *name = unbox_char_string(); - char *value = getenv(name); - if(value == NULL) - dpush(F); - else - box_char_string(value); -} - DEFINE_PRIMITIVE(eq) { CELL lhs = dpop(); From 2da9aa9d18f529344a057f140aac10e2da96b3af Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 9 Apr 2008 16:58:55 -0500 Subject: [PATCH 033/146] Fix Linux/PPC port --- vm/os-linux-ppc.h | 8 ++++++++ vm/os-macosx.h | 8 +++++++- vm/os-unix-ucontext.h | 7 ------- vm/platform.h | 2 -- 4 files changed, 15 insertions(+), 10 deletions(-) delete mode 100644 vm/os-unix-ucontext.h diff --git a/vm/os-linux-ppc.h b/vm/os-linux-ppc.h index 86f0509e38..eb28af53e4 100644 --- a/vm/os-linux-ppc.h +++ b/vm/os-linux-ppc.h @@ -1,4 +1,12 @@ +#include + #define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1) +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1]; +} + #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP]) diff --git a/vm/os-macosx.h b/vm/os-macosx.h index 4c35087752..701bb8da01 100644 --- a/vm/os-macosx.h +++ b/vm/os-macosx.h @@ -15,4 +15,10 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot); #ifndef environ extern char ***_NSGetEnviron(void); #define environ (*_NSGetEnviron()) -#endif \ No newline at end of file +#endif + +INLINE void *ucontext_stack_pointer(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_stack.ss_sp; +} diff --git a/vm/os-unix-ucontext.h b/vm/os-unix-ucontext.h deleted file mode 100644 index 9ed0620a83..0000000000 --- a/vm/os-unix-ucontext.h +++ /dev/null @@ -1,7 +0,0 @@ -#include - -INLINE void *ucontext_stack_pointer(void *uap) -{ - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_stack.ss_sp; -} diff --git a/vm/platform.h b/vm/platform.h index a8c8ba756f..2f97cb9d1d 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -27,7 +27,6 @@ #include "os-unix.h" #ifdef __APPLE__ - #include "os-unix-ucontext.h" #include "os-macosx.h" #include "mach_signal.h" @@ -84,7 +83,6 @@ #if defined(FACTOR_X86) #include "os-linux-x86.32.h" #elif defined(FACTOR_PPC) - #include "os-unix-ucontext.h" #include "os-linux-ppc.h" #elif defined(FACTOR_ARM) #include "os-linux-arm.h" From 9373df5c4c5614a4a45afa215b26d249d1390611 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 17:04:09 -0500 Subject: [PATCH 034/146] Fix -generations=1 --- vm/data_gc.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/data_gc.h b/vm/data_gc.h index d3b8b6e39e..2490ed8805 100755 --- a/vm/data_gc.h +++ b/vm/data_gc.h @@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a) { CELL *object; - if(nursery->size - ALLOT_BUFFER_ZONE > a) + if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a) { /* If there is insufficient room, collect the nursery */ if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end) From f6e73abc0249e31bbd97918e285ccc851a043528 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:30:54 -0500 Subject: [PATCH 035/146] Redo refresh-all --- core/vocabs/loader/loader-tests.factor | 2 + extra/tools/vocabs/monitor/monitor.factor | 7 +- extra/tools/vocabs/vocabs.factor | 116 ++++++++++++++-------- 3 files changed, 80 insertions(+), 45 deletions(-) diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 1191594fe5..45b0d6b019 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -110,6 +110,8 @@ IN: vocabs.loader.tests ] with-compilation-unit ] unit-test +[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test + [ ] [ "vocabs.loader.test.b" refresh ] unit-test [ 3 ] [ "count-me" get-global ] unit-test diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..826d410480 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -10,8 +10,7 @@ IN: tools.vocabs.monitor { { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ; : path>vocab-name ( path -- vocab ) - dup ".factor" tail? [ parent-directory ] when - ; + dup ".factor" tail? [ parent-directory ] when ; : chop-vocab-root ( path -- path' ) "resource:" prepend-path (normalize-path) @@ -23,10 +22,6 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; - : monitor-thread ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 825d2a6329..211b396c50 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -32,43 +32,6 @@ IN: tools.vocabs [ vocab-tests % ] tri ] { } make ; -: source-modified? ( path -- ? ) - dup source-files get at [ - dup source-file-path - dup exists? [ - utf8 file-lines lines-crc32 - swap source-file-checksum = not - ] [ - 2drop f - ] if - ] [ - exists? - ] ?if ; - -: modified ( seq quot -- seq ) - [ dup ] swap compose { } map>assoc - [ nip ] assoc-subset - [ nip source-modified? ] assoc-subset keys ; inline - -: modified-sources ( vocabs -- seq ) - [ vocab-source-path ] modified ; - -: modified-docs ( vocabs -- seq ) - [ vocab-docs-path ] modified ; - -SYMBOL: changed-vocabs - -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - -: filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ delete-at* nip ] curry subset - ] when* ; - -: to-refresh ( prefix -- modified-sources modified-docs ) - child-vocabs filter-changed - [ modified-sources ] [ modified-docs ] bi ; - : vocab-heading. ( vocab -- ) nl "==== " write @@ -95,12 +58,87 @@ SYMBOL: failures failures get ] with-compiler-errors ; -: do-refresh ( modified-sources modified-docs -- ) +: source-modified? ( path -- ? ) + dup source-files get at [ + dup source-file-path + dup exists? [ + utf8 file-lines lines-crc32 + swap source-file-checksum = not + ] [ + 2drop f + ] if + ] [ + exists? + ] ?if ; + +SYMBOL: changed-vocabs + +[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook + +: changed-vocab ( vocab -- ) + dup vocab + [ dup changed-vocabs get-global set-at ] [ drop ] if ; + +: unchanged-vocab ( vocab -- ) + changed-vocabs get-global delete-at ; + +: unchanged-vocabs ( vocabs -- ) + [ unchanged-vocab ] each ; + +: filter-changed ( vocabs -- vocabs' ) + changed-vocabs get [ + [ key? ] curry subset + ] when* ; + +SYMBOL: modified-sources +SYMBOL: modified-docs + +: (to-refresh) ( vocab variable loaded? path -- ) + dup [ + swap [ + pick changed-vocabs get key? [ + source-modified? [ get push ] [ 2drop ] if + ] [ 3drop ] if + ] [ drop get push ] if + ] [ 2drop 2drop ] if ; + +: to-refresh ( prefix -- modified-sources modified-docs unchanged ) + [ + V{ } clone modified-sources set + V{ } clone modified-docs set + + child-vocabs [ + [ + [ + [ modified-sources ] + [ vocab-source-loaded? ] + [ vocab-source-path ] + tri (to-refresh) + ] [ + [ modified-docs ] + [ vocab-docs-loaded? ] + [ vocab-docs-path ] + tri (to-refresh) + ] bi + ] each + + modified-sources get + modified-docs get + ] + [ modified-sources get modified-docs get append swap seq-diff ] bi + ] with-scope ; + +: do-refresh ( modified-sources modified-docs unchanged -- ) + unchanged-vocabs [ [ [ f swap set-vocab-source-loaded? ] each ] [ [ f swap set-vocab-docs-loaded? ] each ] bi* ] - [ append prune require-all load-failures. ] 2bi ; + [ + append prune + [ unchanged-vocabs ] + [ require-all load-failures. ] bi + ] 2bi ; : refresh ( prefix -- ) to-refresh do-refresh ; From 0e723f64cc2cd97e767cccab9f4b3a8ecb197385 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 19:47:10 -0500 Subject: [PATCH 036/146] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 29 +++++++++++++++++++++++++ 1 file changed, 29 insertions(+) create mode 100644 extra/io/monitors/monitors-tests.factor diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor new file mode 100644 index 0000000000..fb687f6876 --- /dev/null +++ b/extra/io/monitors/monitors-tests.factor @@ -0,0 +1,29 @@ +IN: io.monitors.tests +USING: io.monitors tools.test io.files system sequences +continuations namespaces concurrency.count-downs kernel io +threads calendar ; + +os { winnt macosx linux } member? [ + [ "monitor-test" temp-file delete-tree ] ignore-errors + + [ ] [ "monitor-test" temp-file make-directory ] unit-test + + [ ] [ "monitor-test" temp-file t "m" set ] unit-test + + [ ] [ 1 "c" set ] unit-test + + [ ] [ + [ + [ + "m" get next-change drop + dup print flush + "test.txt" tail? not + ] [ ] [ ] while + "c" get count-down + ] "Monitor test thread" spawn drop + ] unit-test + + [ ] [ "monitor-test/test.txt" touch-file ] unit-test + + [ ] [ "c" get 30 seconds await-timeout ] unit-test +] when From b63edfd493bc13c424edd81f96752918115610a8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 19:54:48 -0500 Subject: [PATCH 037/146] Add unit tests for monitors --- extra/io/monitors/monitors-tests.factor | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index fb687f6876..4bb5db9f0a 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -1,29 +1,34 @@ IN: io.monitors.tests USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io -threads calendar ; +threads calendar prettyprint ; os { winnt macosx linux } member? [ [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test" temp-file make-directory ] unit-test + [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ 1 "b" set ] unit-test + [ ] [ 1 "c" set ] unit-test [ ] [ [ + "b" get count-down [ "m" get next-change drop - dup print flush - "test.txt" tail? not + dup print flush right-trim-separators + "xyz" tail? not ] [ ] [ ] while "c" get count-down ] "Monitor test thread" spawn drop ] unit-test - [ ] [ "monitor-test/test.txt" touch-file ] unit-test + [ ] [ "b" get await ] unit-test + + [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test ] when From 48a16b542d0f4e5e23956012194c4fe61d76c6b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 9 Apr 2008 20:14:14 -0500 Subject: [PATCH 038/146] Unit test fixes --- core/definitions/definitions-tests.factor | 20 -------------------- extra/io/monitors/monitors-tests.factor | 4 ++++ 2 files changed, 4 insertions(+), 20 deletions(-) diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 3dc28139ea..b20d81ec7c 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -2,26 +2,6 @@ IN: definitions.tests USING: tools.test generic kernel definitions sequences compiler.units words ; -TUPLE: combination-1 ; - -M: combination-1 perform-combination drop [ ] define ; - -M: combination-1 make-default-method 2drop [ "No method" throw ] ; - -SYMBOL: generic-1 - -[ - generic-1 T{ combination-1 } define-generic - - object \ generic-1 create-method [ ] define -] with-compilation-unit - -[ ] [ - [ - { combination-1 { object generic-1 } } forget-all - ] with-compilation-unit -] unit-test - GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 4bb5db9f0a..7170e824c8 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -31,4 +31,8 @@ os { winnt macosx linux } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test [ ] [ "c" get 30 seconds await-timeout ] unit-test + + [ ] [ "m" get dispose ] unit-test + + [ "m" get dispose ] must-fail ] when From 0c351581b5c299450e4d081bde4260ee294b36a1 Mon Sep 17 00:00:00 2001 From: slava Date: Wed, 9 Apr 2008 20:15:24 -0500 Subject: [PATCH 039/146] Fix -no-monitors switch --- extra/tools/vocabs/monitor/monitor.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index 867c3b2903..185f8d157a 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -45,7 +45,7 @@ IN: tools.vocabs.monitor ] ignore-errors ; [ - "-no-monitors" cli-args get member? [ + "-no-monitors" cli-args member? [ start-monitor-thread ] unless ] "tools.vocabs.monitor" add-init-hook From b4c9bbdf805bc79256bc6f21f47d07cac0829251 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:00 -0500 Subject: [PATCH 040/146] processing: at-fraction --- extra/processing/processing.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 02a8325663..0f21634dc8 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays combinators combinators.lib combinators.cleave - rewrite-closures fry accessors + rewrite-closures fry accessors newfx processing.color processing.gadget ; @@ -28,6 +28,12 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; + +: at-fraction-of ( fraction seq -- val ) swap at-fraction ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: fill-color VAR: stroke-color @@ -282,7 +288,7 @@ VAR: frame-rate-value ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -VAR: slate +! VAR: slate VAR: loop-flag From a135aa479b9cf2c024e28a746dad0da9dea9093e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 9 Apr 2008 21:01:34 -0500 Subject: [PATCH 041/146] bubble-chamber: Refactoring --- .../bubble-chamber/bubble-chamber.factor | 207 ++++++++---------- 1 file changed, 91 insertions(+), 116 deletions(-) diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor index 2efa04efad..1a5fa37fa6 100644 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor @@ -32,6 +32,8 @@ IN: processing.gallery.bubble-chamber : dim ( -- dim ) 1000 ; +: center ( -- point ) dim 2 / dup {2} ; foldable + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! VAR: collision-theta @@ -73,7 +75,7 @@ VARS: particles muons quarks hadrons axions ; T{ rgba f 0.47 0.42 0.56 1 } } ; -: good-color ( i -- color ) good-colors nth-of ; +: anti-colors ( -- seq ) good-colors ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -89,6 +91,26 @@ VARS: particles muons quarks hadrons axions ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; + +: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: turn ( particle -- particle ) + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; +: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; +: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; +: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -120,32 +142,36 @@ TUPLE: muon < particle ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; + +: set-good-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ good-colors at-fraction-of >>myc ] + [ drop ] + if ; + +: set-anti-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ anti-colors at-fraction-of >>mya ] + [ drop ] + if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + METHOD: collide { muon } - dim 2 / dup 2array >>pos - 2 32 [a,b] random >>speed - 0.0001 0.001 2random >>speed-d + center >>pos + 2 32 [a,b] random >>speed + 0.0001 0.001 2random >>speed-d collision-theta> -0.1 0.1 2random + >>theta 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.001 < ] - [ -0.1 0.1 2random >>theta-dd ] - [ ] - while + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while - dup theta>> pi + - 2 pi * / - good-colors length 1 - * - [ ] [ good-colors length >= ] [ 0 < ] tri or - [ drop ] - [ - [ good-color >>myc ] - [ good-colors length swap - 1 - good-color >>mya ] - bi - ] - if + set-good-color + set-anti-color drop ; @@ -163,14 +189,11 @@ METHOD: move { muon } [ speed>> ] [ theta>> { sin cos } ] bi n*v move-by - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri - >>speed + step-theta + step-theta-d + step-speed-sub - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -182,7 +205,7 @@ TUPLE: quark < particle ; METHOD: collide { quark } - dim 2 / dup 2array >>pos + center >>pos collision-theta> -0.11 0.11 2random + >>theta 0.5 3.0 2random >>speed @@ -190,10 +213,7 @@ METHOD: collide { quark } 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while drop ; @@ -208,26 +228,20 @@ METHOD: move { quark } [ ] [ vel>> ] bi move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ dup speed>> neg >>speed 2 over speed-d>> - >>speed-d ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -239,18 +253,14 @@ TUPLE: hadron < particle ; METHOD: collide { hadron } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 0.5 3.5 2random >>speed - + center >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed 0.996 1.001 2random >>speed-d 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while 0 1 0 >>myc @@ -268,34 +278,22 @@ METHOD: move { hadron } dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul - ! 1000 random 997 > - 3/1000 chance + 1000 random 997 > [ 1.0 >>speed-d 0.00001 >>theta-dd - ! 100 random 70 > - 30/100 chance - [ - dim 2 / dup 2array >>pos - dup collide - ] - when + 100 random 70 > [ dup collide ] when ] when - out-of-bounds? - [ collide ] - [ drop ] - if ; + out-of-bounds? [ collide ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -307,82 +305,59 @@ TUPLE: axion < particle ; METHOD: collide { axion } - dim 2 / dup 2array >>pos - 2 pi * 1random >>theta - 1.0 6.0 2random >>speed - + center >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed 0.998 1.000 2random >>speed-d 0 >>theta-d 0 >>theta-dd - [ dup theta-dd>> abs 0.00001 < ] - [ -0.001 0.001 2random >>theta-dd ] - [ ] - while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; + +: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; +: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; + +: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; +: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + METHOD: move { axion } { 0.06 0.59 } stroke dup pos>> point - 1 4 [a,b] - [| dy | - 1 30 dy 6 * - 255.0 / 2array stroke - dup pos>> 0 dy neg 2array v+ point - ] with-locals - each - - 1 4 [a,b] - [| dy | - 0 30 dy 6 * - 255.0 / 2array stroke - dup pos>> dy v+y point - ] with-locals - each + 1 4 [a,b] [ axion-white axion-point- ] each + 1 4 [a,b] [ axion-black axion-point+ ] each dup vel>> move-by - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel + turn - [ ] [ theta>> ] [ theta-d>> ] tri + >>theta - [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d - [ ] [ speed>> ] [ speed-d>> ] tri * >>speed + step-theta + step-theta-d + step-speed-mul [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - ! 1000 random 996 > - 4/1000 chance + 1000 random 996 > [ - dup speed>> neg >>speed + dup speed>> neg >>speed dup speed-d>> neg 2 + >>speed-d - ! 100 random 30 > - 70/100 chance - [ - dim 2 / dup 2array >>pos - collide - ] - [ drop ] - if + 100 random 30 > [ collide ] [ drop ] if ] [ drop ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : draw ( -- ) - -! boom> -! [ particles> [ move ] each ] -! when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - : collide-all ( -- ) 2 pi * 1random >collision-theta From 2a85901ccaa040bf0481108c43b12f22e4192dd7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 19:35:06 -0500 Subject: [PATCH 042/146] add some windows messages --- extra/windows/messages/messages.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/extra/windows/messages/messages.factor b/extra/windows/messages/messages.factor index 733071d197..3b0db96d63 100644 --- a/extra/windows/messages/messages.factor +++ b/extra/windows/messages/messages.factor @@ -1001,3 +1001,25 @@ windows-messages set-global : LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline : LM_SETITEM WM_USER HEX: 0302 + ; inline : LM_GETITEM WM_USER HEX: 0303 + ; inline + + +: WA_INACTIVE 0 ; inline +: WA_ACTIVE 1 ; inline +: WA_CLICKACTIVE 2 ; inline + +: SC_SIZE HEX: f000 ; inline +: SC_MOVE HEX: f010 ; inline +: SC_MINIMIZE HEX: f020 ; inline +: SC_MAXIMIZE HEX: f030 ; inline +: SC_NEXTWINDOW HEX: f040 ; inline +: SC_PREVWINDOW HEX: f050 ; inline +: SC_CLOSE HEX: f060 ; inline +: SC_VSCROLL HEX: f070 ; inline +: SC_HSCROLL HEX: f080 ; inline +: SC_MOUSEMENU HEX: f090 ; inline +: SC_KEYMENU HEX: f100 ; inline +: SC_ARRANGE HEX: f110 ; inline +: SC_RESTORE HEX: f120 ; inline +: SC_TASKLIST HEX: f130 ; inline +: SC_SCREENSAVE HEX: f140 ; inline +: SC_HOTKEY HEX: f150 ; inline From 2cefe124d6c9c05b2b2dea665e7609ed63b85b3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 10 Apr 2008 21:17:23 -0500 Subject: [PATCH 043/146] try not to render to factor windows when they're minimized --- extra/ui/windows/windows.factor | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index e0c9f24122..0adfc676f8 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -7,7 +7,7 @@ vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads libc combinators continuations command-line shuffle opengl ui.render unicode.case ascii math.bitfields -locals symbols ; +locals symbols accessors ; IN: ui.windows SINGLETON: windows-ui-backend @@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; wParam keystroke>gesture hWnd window-focus send-gesture drop ; +: set-window-active ( hwnd uMsg wParam lParam ? -- n ) + >r 4dup r> 2nip nip + swap window set-world-active? DefWindowProc ; + : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) - dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ; + { + { [ over SC_MINIMIZE = ] [ f set-window-active ] } + { [ over SC_RESTORE = ] [ t set-window-active ] } + { [ over SC_MAXIMIZE = ] [ t set-window-active ] } + { [ dup alpha? ] [ 4drop 0 ] } + { [ t ] [ DefWindowProc ] } + } cond ; : cleanup-window ( handle -- ) dup win-title [ free ] when* From 688cbfaafacf383374b162d6163ca957f7b84032 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Fri, 11 Apr 2008 14:46:11 +1200 Subject: [PATCH 044/146] Delocalise grow-lr --- extra/peg/peg.factor | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor index 7390c15684..164f7c9ee9 100755 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -100,21 +100,21 @@ C: peg-head : setup-growth ( h p -- ) pos set dup involved-set>> clone >>eval-set drop ; -:: (grow-lr) ( h p r m -- ) - h p setup-growth - r eval-rule - dup m stop-growth? [ - drop +: (grow-lr) ( h p r m -- ) + >r >r [ setup-growth ] 2keep r> r> + >r dup eval-rule r> swap + dup pick stop-growth? [ + 4drop drop ] [ - m update-m - h p r m (grow-lr) + over update-m + (grow-lr) ] if ; inline -:: grow-lr ( h p r m -- ast ) - h p heads get set-at - h p r m (grow-lr) - p heads get delete-at - m pos>> pos set m ans>> +: grow-lr ( h p r m -- ast ) + >r >r [ heads get set-at ] 2keep r> r> + pick over >r >r (grow-lr) r> r> + swap heads get delete-at + dup pos>> pos set ans>> ; inline :: (setup-lr) ( r l s -- ) From a1b050fd88f5b3d3ba0a5b031dd1156d318e5b6a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 21:49:08 -0500 Subject: [PATCH 045/146] Fix interactor --- .../tools/interactor/interactor-tests.factor | 25 ++++++++++++++++++- extra/ui/tools/interactor/interactor.factor | 4 ++- 2 files changed, 27 insertions(+), 2 deletions(-) diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index fe0a654217..94953f9c72 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,27 @@ IN: ui.tools.interactor.tests -USING: ui.tools.interactor tools.test ; +USING: ui.tools.interactor ui.gadgets.panes namespaces +ui.gadgets.editors concurrency.promises threads listener +tools.test kernel calendar ; \ must-infer + +[ ] [ "interactor" set ] unit-test + +[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test + +[ ] [ "promise" set ] unit-test + +[ + "interactor" get stream-read-quot "promise" get fulfill +] "Interactor test" spawn drop + +! This should not throw an exception +[ ] [ "interactor" get evaluate-input ] unit-test + +[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + +[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test + +[ ] [ "interactor" get evaluate-input ] unit-test + +[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index 8232094e76..86ba51df95 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -138,7 +138,9 @@ M: interactor stream-read-partial drop parse-lines-interactive ] [ 2nip - dup delegate unexpected-eof? [ drop f ] when + dup parse-error? [ + dup error>> unexpected-eof? [ drop f ] when + ] when ] recover ; : handle-interactive ( lines interactor -- quot/f ? ) From 039c344e8745bc0f1a5afb975c0c57eb14eb1ea8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 10 Apr 2008 22:02:23 -0500 Subject: [PATCH 046/146] Fix unit test failure on BSD --- extra/tools/vocabs/vocabs-tests.factor | 8 ++++++++ extra/tools/vocabs/vocabs.factor | 6 +++--- 2 files changed, 11 insertions(+), 3 deletions(-) create mode 100644 extra/tools/vocabs/vocabs-tests.factor diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor new file mode 100644 index 0000000000..ae74d516e4 --- /dev/null +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -0,0 +1,8 @@ +IN: tools.vocabs.tests +USING: tools.test tools.vocabs namespaces continuations ; + +[ ] [ + changed-vocabs get-global + f changed-vocabs set-global + [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup +] unit-test diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 211b396c50..371bbc7813 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -76,11 +76,11 @@ SYMBOL: changed-vocabs [ f changed-vocabs set-global ] "tools.vocabs" add-init-hook : changed-vocab ( vocab -- ) - dup vocab - [ dup changed-vocabs get-global set-at ] [ drop ] if ; + dup vocab changed-vocabs get and + [ dup changed-vocabs get set-at ] [ drop ] if ; : unchanged-vocab ( vocab -- ) - changed-vocabs get-global delete-at ; + changed-vocabs get delete-at ; : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; From 1214f7e71334b2e355488471231b2f27d6c759ea Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:31:12 -0500 Subject: [PATCH 047/146] newfx: Move to generics for getters and setters --- extra/newfx/newfx.factor | 91 +++++++++++++++++++++++++++++++--------- 1 file changed, 72 insertions(+), 19 deletions(-) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index b123fef2a3..3df3b3ed05 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -1,56 +1,109 @@ USING: kernel sequences assocs qualified circular ; +USING: math multi-methods ; + QUALIFIED: sequences +QUALIFIED: assocs QUALIFIED: circular IN: newfx +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Now, we can see a new world coming into view. ! A world in which there is the very real prospect of a new world order. ! ! - George Herbert Walker Bush +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: at ( col key -- val ) +GENERIC: of ( key col -- val ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-at ( seq i -- val ) swap nth ; -: nth-of ( i seq -- val ) nth ; +GENERIC: grab ( col key -- col val ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is ( seq i val -- seq ) swap pick set-nth ; -: is-nth ( seq val i -- seq ) pick set-nth ; +GENERIC: is ( col key val -- col ) +GENERIC: as ( col val key -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ; -: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ; +GENERIC: is-of ( key val col -- col ) +GENERIC: as-of ( val key col -- col ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-nth ( seq i val -- ) swap rot set-nth ; -: mutate-nth-at ( seq val i -- ) rot set-nth ; - -: mutate-nth-of ( i val seq -- ) swapd set-nth ; -: mutate-nth-at-of ( val i seq -- ) set-nth ; +GENERIC: mutate-at ( col key val -- ) +GENERIC: mutate-as ( col val key -- ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-key ( tbl key -- val ) swap at ; -: key-of ( key tbl -- val ) at ; +GENERIC: at-mutate ( key val col -- ) +GENERIC: as-mutate ( val key col -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! sequence +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at { sequence number } swap nth ; +METHOD: of { number sequence } nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: key-is ( tbl key val -- tbl ) swap pick set-at ; -: is-key ( tbl val key -- tbl ) pick set-at ; +METHOD: grab { sequence number } dupd swap nth ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: mutate-key ( tbl key val -- ) swap rot set-at ; -: mutate-at-key ( tbl val key -- ) rot set-at ; +METHOD: is { sequence number object } swap pick set-nth ; +METHOD: as { sequence object number } pick set-nth ; -: mutate-key-of ( key val tbl -- ) swapd set-at ; -: mutate-at-key-of ( val key tbl -- ) set-at ; +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is-of { number object sequence } dup >r swapd set-nth r> ; +METHOD: as-of { object number sequence } dup >r set-nth r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: mutate-at { sequence number object } swap rot set-nth ; +METHOD: mutate-as { sequence object number } rot set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at-mutate { number object sequence } swapd set-nth ; +METHOD: as-mutate { object number sequence } set-nth ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! assoc +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at { assoc object } swap assocs:at ; +METHOD: of { object assoc } assocs:at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: grab { assoc object } dupd swap assocs:at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is { assoc object object } swap pick set-at ; +METHOD: as { assoc object object } pick set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: is-of { object object assoc } dup >r swapd set-at r> ; +METHOD: as-of { object object assoc } dup >r set-at r> ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: mutate-at { assoc object object } swap rot set-at ; +METHOD: mutate-as { assoc object object } rot set-at ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: at-mutate { object object assoc } swapd set-at ; +METHOD: as-mutate { object object assoc } set-at ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From c71a46d15e23881c57a4359bf28e703ab0ea3978 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:33:22 -0500 Subject: [PATCH 048/146] Remove bubble-chamber from gallery (moving to root) --- .../bubble-chamber/bubble-chamber-docs.factor | 97 ---- .../bubble-chamber/bubble-chamber.factor | 428 ------------------ 2 files changed, 525 deletions(-) delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor delete mode 100644 extra/processing/gallery/bubble-chamber/bubble-chamber.factor diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor deleted file mode 100644 index 21a845e089..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber-docs.factor +++ /dev/null @@ -1,97 +0,0 @@ - -USING: help.syntax help.markup ; - -IN: processing.gallery.bubble-chamber - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -HELP: muon - - { $class-description - "The muon is a colorful particle with an entangled friend." - "It draws both itself and its horizontally symmetric partner." - "A high range of speed and almost no speed decay allow the" - "muon to reach the extents of the window, often forming rings" - "where theta has decayed but speed remains stable. The result" - "is color almost everywhere in the general direction of collision," - "stabilized into fuzzy rings." } ; - -HELP: quark - - { $class-description - "The quark draws as a translucent black. Their large numbers" - "create fields of blackness overwritten only by the glowing shadows of " - "Hadrons. " - "quarks are allowed to accelerate away with speed decay values above 1.0. " - "Each quark has an entangled friend. Both particles are drawn identically," - "mirrored along the y-axis." } ; - -HELP: hadron - - { $class-description - "Hadrons collide from totally random directions. " - "Those hadrons that do not exit the drawing area, " - "tend to stabilize into perfect circular orbits. " - "Each hadron draws with a slight glowing emboss. " - "The hadron itself is not drawn." } ; - -HELP: axion - - { $class-description - "The axion particle draws a bold black path. Axions exist " - "in a slightly higher dimension and as such are drawn with " - "elevated embossed shadows. Axions are quick to stabilize " - "and fall into single pixel orbits axions automatically " - "recollide themselves after stabilizing." } ; - -{ muon quark hadron axion } related-words - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber" "Bubble Chamber" - - { $subsection "bubble-chamber-introduction" } - { $subsection "bubble-chamber-particles" } - { $subsection "bubble-chamber-author" } - { $subsection "bubble-chamber-running" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-introduction" "Introduction" - -"The Bubble Chamber is a generative painting system of imaginary " -"colliding particles. A single super-massive collision produces a " -"discrete universe of four particle types. Particles draw their " -"positions over time as pixel exposures. " ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-particles" "Particles" - -"Four types of particles exist. The behavior and graphic appearance of " -"each particle type is unique." - - { $subsection muon } - { $subsection quark } - { $subsection hadron } - { $subsection axion } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-author" "Author" - - "Bubble Chamber was created by Jared Tarbell. " - "It was originally implemented in Processing. " - "It was ported to Factor by Eduardo Cavazos. " - "The original work is on display here: " - { $url - "http://www.complexification.net/gallery/machines/bubblechamber/" } ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -ARTICLE: "bubble-chamber-running" "How to use" - - "After you run the vocabulary, a window will appear. Click the " - "mouse in a random area to fire 11 particles of each type. " - "Another way to fire particles is to press the " - "spacebar. This fires all the particles." ; \ No newline at end of file diff --git a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor b/extra/processing/gallery/bubble-chamber/bubble-chamber.factor deleted file mode 100644 index 1a5fa37fa6..0000000000 --- a/extra/processing/gallery/bubble-chamber/bubble-chamber.factor +++ /dev/null @@ -1,428 +0,0 @@ - -USING: kernel namespaces sequences combinators arrays threads - - math - math.libm - math.vectors - math.ranges - math.constants - math.functions - math.points - - ui - ui.gadgets - - random accessors multi-methods - combinators.cleave - vars locals - - newfx - - processing - processing.gadget - processing.color ; - -IN: processing.gallery.bubble-chamber - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dim ( -- dim ) 1000 ; - -: center ( -- point ) dim 2 / dup {2} ; foldable - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: collision-theta - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VAR: boom - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -VARS: particles muons quarks hadrons axions ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: good-colors ( -- seq ) - { - T{ rgba f 0.23 0.14 0.17 1 } - T{ rgba f 0.23 0.14 0.15 1 } - T{ rgba f 0.21 0.14 0.15 1 } - T{ rgba f 0.51 0.39 0.33 1 } - T{ rgba f 0.49 0.33 0.20 1 } - T{ rgba f 0.55 0.45 0.32 1 } - T{ rgba f 0.69 0.63 0.51 1 } - T{ rgba f 0.64 0.39 0.18 1 } - T{ rgba f 0.73 0.42 0.20 1 } - T{ rgba f 0.71 0.45 0.29 1 } - T{ rgba f 0.79 0.45 0.22 1 } - T{ rgba f 0.82 0.56 0.34 1 } - T{ rgba f 0.88 0.72 0.49 1 } - T{ rgba f 0.85 0.69 0.40 1 } - T{ rgba f 0.96 0.92 0.75 1 } - T{ rgba f 0.99 0.98 0.87 1 } - T{ rgba f 0.85 0.82 0.69 1 } - T{ rgba f 0.99 0.98 0.87 1 } - T{ rgba f 0.82 0.82 0.79 1 } - T{ rgba f 0.65 0.69 0.67 1 } - T{ rgba f 0.53 0.60 0.55 1 } - T{ rgba f 0.57 0.53 0.68 1 } - T{ rgba f 0.47 0.42 0.56 1 } - } ; - -: anti-colors ( -- seq ) good-colors ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: x ( particle -- x ) pos>> first ; -: y ( particle -- x ) pos>> second ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: out-of-bounds? ( particle -- particle ? ) - dup - { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave - or or or ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; - -: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: turn ( particle -- particle ) - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - >>vel ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; -: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; -: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; -: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: initialize-particle ( particle -- particle ) - - 0 0 {2} >>pos - 0 0 {2} >>vel - - 0 >>speed - 0 >>speed-d - 0 >>theta - 0 >>theta-d - 0 >>theta-dd - - 0 0 0 1 >>myc - 0 0 0 1 >>mya ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -GENERIC: collide ( particle -- ) -GENERIC: move ( particle -- ) - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: muon < particle ; - -: ( -- muon ) muon construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; - -: set-good-color ( particle -- particle ) - color-fraction dup 0 1 between? - [ good-colors at-fraction-of >>myc ] - [ drop ] - if ; - -: set-anti-color ( particle -- particle ) - color-fraction dup 0 1 between? - [ anti-colors at-fraction-of >>mya ] - [ drop ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { muon } - - center >>pos - 2 32 [a,b] random >>speed - 0.0001 0.001 2random >>speed-d - - collision-theta> -0.1 0.1 2random + >>theta - 0 >>theta-d - 0 >>theta-dd - - [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while - - set-good-color - set-anti-color - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { muon } - - dup myc>> 0.16 >>alpha stroke - dup pos>> point - - dup mya>> 0.16 >>alpha stroke - dup pos>> first2 >r dim swap - r> 2array point - - dup - [ speed>> ] [ theta>> { sin cos } ] bi n*v - move-by - - step-theta - step-theta-d - step-speed-sub - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: quark < particle ; - -: ( -- quark ) quark construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { quark } - - center >>pos - collision-theta> -0.11 0.11 2random + >>theta - 0.5 3.0 2random >>speed - - 0.996 1.001 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { quark } - - dup myc>> 0.13 >>alpha stroke - dup pos>> point - - dup pos>> first2 >r dim swap - r> 2array point - - [ ] [ vel>> ] bi move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - 1000 random 997 > - [ - dup speed>> neg >>speed - 2 over speed-d>> - >>speed-d - ] - when - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: hadron < particle ; - -: ( -- hadron ) hadron construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { hadron } - - center >>pos - 2 pi * 1random >>theta - 0.5 3.5 2random >>speed - 0.996 1.001 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - 0 1 0 >>myc - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { hadron } - - { 1 0.11 } stroke - dup pos>> 1 v-y point - - { 0 0.11 } stroke - dup pos>> 1 v+y point - - dup vel>> move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - 1000 random 997 > - [ - 1.0 >>speed-d - 0.00001 >>theta-dd - - 100 random 70 > [ dup collide ] when - ] - when - - out-of-bounds? [ collide ] [ drop ] if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -TUPLE: axion < particle ; - -: ( -- axion ) axion construct-empty initialize-particle ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: collide { axion } - - center >>pos - 2 pi * 1random >>theta - 1.0 6.0 2random >>speed - 0.998 1.000 2random >>speed-d - 0 >>theta-d - 0 >>theta-dd - - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while - - drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; - -: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; -: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; - -: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; -: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -METHOD: move { axion } - - { 0.06 0.59 } stroke - dup pos>> point - - 1 4 [a,b] [ axion-white axion-point- ] each - 1 4 [a,b] [ axion-black axion-point+ ] each - - dup vel>> move-by - - turn - - step-theta - step-theta-d - step-speed-mul - - [ ] [ speed-d>> 0.9999 * ] bi >>speed-d - - 1000 random 996 > - [ - dup speed>> neg >>speed - dup speed-d>> neg 2 + >>speed-d - - 100 random 30 > [ collide ] [ drop ] if - ] - [ drop ] - if ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: collide-all ( -- ) - - 2 pi * 1random >collision-theta - - particles> [ collide ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: collide-one ( -- ) - - dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta - - hadrons> random collide - quarks> random collide - muons> random collide ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: mouse-pressed ( -- ) - boom on - 1 background ! kludge - 11 [ drop collide-one ] each ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: key-released ( -- ) - key " " = - [ - boom on - 1 background - collide-all - ] - when ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: bubble-chamber ( -- ) - - 1000 1000 size* - - [ - 1 background - no-stroke - - 1789 [ drop ] map >muons - 1300 [ drop ] map >quarks - 1000 [ drop ] map >hadrons - 111 [ drop ] map >axions - - muons> quarks> hadrons> axions> 3append append >particles - - collide-one - ] setup - - [ - boom> - [ particles> [ move ] each ] - when - ] draw - - [ mouse-pressed ] button-down - [ key-released ] key-up - - ; - -: go ( -- ) [ bubble-chamber run ] with-ui ; - -MAIN: go \ No newline at end of file From bbf5234a9e1442d0561bc9b5e54ac99b7e742f0c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:26 -0500 Subject: [PATCH 049/146] processing: use 'at' --- extra/processing/processing.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor index 0f21634dc8..e089b15e7e 100644 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -28,7 +28,9 @@ IN: processing ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: at-fraction ( seq fraction -- val ) over length 1- * nth-at ; +! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ; + +: at-fraction ( seq fraction -- val ) over length 1- * at ; : at-fraction-of ( fraction seq -- val ) swap at-fraction ; From cd9c92d9011b6675a2c4607c5cbece8ed051cbfa Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 10 Apr 2008 22:34:43 -0500 Subject: [PATCH 050/146] bubble-chamber: big refactoring --- extra/bubble-chamber/bubble-chamber.factor | 88 +++++++++++++++++++ extra/bubble-chamber/common/common.factor | 12 +++ .../particle/axion/axion.factor | 67 ++++++++++++++ .../particle/hadron/hadron.factor | 60 +++++++++++++ .../particle/muon/colors/colors.factor | 53 +++++++++++ .../bubble-chamber/particle/muon/muon.factor | 62 +++++++++++++ extra/bubble-chamber/particle/particle.factor | 68 ++++++++++++++ .../particle/quark/quark.factor | 53 +++++++++++ 8 files changed, 463 insertions(+) create mode 100644 extra/bubble-chamber/bubble-chamber.factor create mode 100644 extra/bubble-chamber/common/common.factor create mode 100644 extra/bubble-chamber/particle/axion/axion.factor create mode 100644 extra/bubble-chamber/particle/hadron/hadron.factor create mode 100644 extra/bubble-chamber/particle/muon/colors/colors.factor create mode 100644 extra/bubble-chamber/particle/muon/muon.factor create mode 100644 extra/bubble-chamber/particle/particle.factor create mode 100644 extra/bubble-chamber/particle/quark/quark.factor diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor new file mode 100644 index 0000000000..4b0db46c35 --- /dev/null +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -0,0 +1,88 @@ + +USING: kernel namespaces sequences random math math.constants math.libm vars + ui + processing + processing.gadget + bubble-chamber.common + bubble-chamber.particle + bubble-chamber.particle.muon + bubble-chamber.particle.quark + bubble-chamber.particle.hadron + bubble-chamber.particle.axion ; + +IN: bubble-chamber + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VARS: particles muons quarks hadrons axions ; + +VAR: boom + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-all ( -- ) + + 2 pi * 1random >collision-theta + + particles> [ collide ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: collide-one ( -- ) + + dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta + + hadrons> random collide + quarks> random collide + muons> random collide ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: mouse-pressed ( -- ) + boom on + 1 background ! kludge + 11 [ drop collide-one ] each ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: key-released ( -- ) + key " " = + [ + boom on + 1 background + collide-all + ] + when ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: bubble-chamber ( -- ) + + 1000 1000 size* + + [ + 1 background + no-stroke + + 1789 [ drop ] map >muons + 1300 [ drop ] map >quarks + 1000 [ drop ] map >hadrons + 111 [ drop ] map >axions + + muons> quarks> hadrons> axions> 3append append >particles + + collide-one + ] setup + + [ + boom> + [ particles> [ move ] each ] + when + ] draw + + [ mouse-pressed ] button-down + [ key-released ] key-up ; + +: go ( -- ) [ bubble-chamber run ] with-ui ; + +MAIN: go \ No newline at end of file diff --git a/extra/bubble-chamber/common/common.factor b/extra/bubble-chamber/common/common.factor new file mode 100644 index 0000000000..c9ce687535 --- /dev/null +++ b/extra/bubble-chamber/common/common.factor @@ -0,0 +1,12 @@ + +USING: kernel math accessors combinators.cleave vars ; + +IN: bubble-chamber.common + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +VAR: collision-theta + +: dim ( -- dim ) 1000 ; + +: center ( -- point ) dim 2 / dup {2} ; foldable diff --git a/extra/bubble-chamber/particle/axion/axion.factor b/extra/bubble-chamber/particle/axion/axion.factor new file mode 100644 index 0000000000..9e9bf99272 --- /dev/null +++ b/extra/bubble-chamber/particle/axion/axion.factor @@ -0,0 +1,67 @@ + +USING: kernel sequences random accessors multi-methods + math math.constants math.ranges math.points combinators.cleave + processing bubble-chamber.common bubble-chamber.particle ; + +IN: bubble-chamber.particle.axion + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: axion < particle ; + +: ( -- axion ) axion construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { axion } + + center >>pos + 2 pi * 1random >>theta + 1.0 6.0 2random >>speed + 0.998 1.000 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ; + +: axion-white ( dy -- dy ) dup 1 swap dy>alpha {2} stroke ; +: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ; + +: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ; +: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { axion } + + { 0.06 0.59 } stroke + dup pos>> point + + 1 4 [a,b] [ axion-white axion-point- ] each + 1 4 [a,b] [ axion-black axion-point+ ] each + + dup vel>> move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + [ ] [ speed-d>> 0.9999 * ] bi >>speed-d + + 1000 random 996 > + [ + dup speed>> neg >>speed + dup speed-d>> neg 2 + >>speed-d + + 100 random 30 > [ collide ] [ drop ] if + ] + [ drop ] + if ; diff --git a/extra/bubble-chamber/particle/hadron/hadron.factor b/extra/bubble-chamber/particle/hadron/hadron.factor new file mode 100644 index 0000000000..2994577838 --- /dev/null +++ b/extra/bubble-chamber/particle/hadron/hadron.factor @@ -0,0 +1,60 @@ + +USING: kernel random math math.constants math.points accessors multi-methods + processing + processing.color + bubble-chamber.common + bubble-chamber.particle ; + +IN: bubble-chamber.particle.hadron + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: hadron < particle ; + +: ( -- hadron ) hadron construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { hadron } + + center >>pos + 2 pi * 1random >>theta + 0.5 3.5 2random >>speed + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + 0 1 0 >>myc + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { hadron } + + { 1 0.11 } stroke + dup pos>> 1 v-y point + + { 0 0.11 } stroke + dup pos>> 1 v+y point + + dup vel>> move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + 1000 random 997 > + [ + 1.0 >>speed-d + 0.00001 >>theta-dd + + 100 random 70 > [ dup collide ] when + ] + when + + out-of-bounds? [ collide ] [ drop ] if ; diff --git a/extra/bubble-chamber/particle/muon/colors/colors.factor b/extra/bubble-chamber/particle/muon/colors/colors.factor new file mode 100644 index 0000000000..ab72f65b4b --- /dev/null +++ b/extra/bubble-chamber/particle/muon/colors/colors.factor @@ -0,0 +1,53 @@ + +USING: kernel sequences math math.constants accessors + processing + processing.color ; + +IN: bubble-chamber.particle.muon.colors + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: good-colors ( -- seq ) + { + T{ rgba f 0.23 0.14 0.17 1 } + T{ rgba f 0.23 0.14 0.15 1 } + T{ rgba f 0.21 0.14 0.15 1 } + T{ rgba f 0.51 0.39 0.33 1 } + T{ rgba f 0.49 0.33 0.20 1 } + T{ rgba f 0.55 0.45 0.32 1 } + T{ rgba f 0.69 0.63 0.51 1 } + T{ rgba f 0.64 0.39 0.18 1 } + T{ rgba f 0.73 0.42 0.20 1 } + T{ rgba f 0.71 0.45 0.29 1 } + T{ rgba f 0.79 0.45 0.22 1 } + T{ rgba f 0.82 0.56 0.34 1 } + T{ rgba f 0.88 0.72 0.49 1 } + T{ rgba f 0.85 0.69 0.40 1 } + T{ rgba f 0.96 0.92 0.75 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.85 0.82 0.69 1 } + T{ rgba f 0.99 0.98 0.87 1 } + T{ rgba f 0.82 0.82 0.79 1 } + T{ rgba f 0.65 0.69 0.67 1 } + T{ rgba f 0.53 0.60 0.55 1 } + T{ rgba f 0.57 0.53 0.68 1 } + T{ rgba f 0.47 0.42 0.56 1 } + } ; + +: anti-colors ( -- seq ) good-colors ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ; + +: set-good-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ good-colors at-fraction-of >>myc ] + [ drop ] + if ; + +: set-anti-color ( particle -- particle ) + color-fraction dup 0 1 between? + [ anti-colors at-fraction-of >>mya ] + [ drop ] + if ; diff --git a/extra/bubble-chamber/particle/muon/muon.factor b/extra/bubble-chamber/particle/muon/muon.factor new file mode 100644 index 0000000000..44c7d9f134 --- /dev/null +++ b/extra/bubble-chamber/particle/muon/muon.factor @@ -0,0 +1,62 @@ + +USING: kernel arrays sequences random + math + math.ranges + math.functions + math.vectors + multi-methods accessors + combinators.cleave + processing + bubble-chamber.common + bubble-chamber.particle + bubble-chamber.particle.muon.colors ; + +IN: bubble-chamber.particle.muon + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: muon < particle ; + +: ( -- muon ) muon construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { muon } + + center >>pos + 2 32 [a,b] random >>speed + 0.0001 0.001 2random >>speed-d + + collision-theta> -0.1 0.1 2random + >>theta + 0 >>theta-d + 0 >>theta-dd + + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while + + set-good-color + set-anti-color + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { muon } + + dup myc>> 0.16 >>alpha stroke + dup pos>> point + + dup mya>> 0.16 >>alpha stroke + dup pos>> first2 >r dim swap - r> 2array point + + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + move-by + + step-theta + step-theta-d + step-speed-sub + + out-of-bounds? [ collide ] [ drop ] if ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/extra/bubble-chamber/particle/particle.factor b/extra/bubble-chamber/particle/particle.factor new file mode 100644 index 0000000000..755a414b71 --- /dev/null +++ b/extra/bubble-chamber/particle/particle.factor @@ -0,0 +1,68 @@ + +USING: kernel sequences combinators + math math.vectors math.functions multi-methods + accessors combinators.cleave processing processing.color + bubble-chamber.common ; + +IN: bubble-chamber.particle + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: collide ( particle -- ) +GENERIC: move ( particle -- ) + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: initialize-particle ( particle -- particle ) + + 0 0 {2} >>pos + 0 0 {2} >>vel + + 0 >>speed + 0 >>speed-d + 0 >>theta + 0 >>theta-d + 0 >>theta-dd + + 0 0 0 1 >>myc + 0 0 0 1 >>mya ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: move-by ( obj delta -- obj ) over pos>> v+ >>pos ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ; + +: random-theta-dd ( par a b -- par ) 2random >>theta-dd ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: turn ( particle -- particle ) + dup + [ speed>> ] [ theta>> { sin cos } ] bi n*v + >>vel ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ; +: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ; +: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ; +: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: x ( particle -- x ) pos>> first ; +: y ( particle -- x ) pos>> second ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: out-of-bounds? ( particle -- particle ? ) + dup + { [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave + or or or ; diff --git a/extra/bubble-chamber/particle/quark/quark.factor b/extra/bubble-chamber/particle/quark/quark.factor new file mode 100644 index 0000000000..32d95c8f00 --- /dev/null +++ b/extra/bubble-chamber/particle/quark/quark.factor @@ -0,0 +1,53 @@ + +USING: kernel arrays sequences random math accessors multi-methods + processing + bubble-chamber.common + bubble-chamber.particle ; + +IN: bubble-chamber.particle.quark + +TUPLE: quark < particle ; + +: ( -- quark ) quark construct-empty initialize-particle ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: collide { quark } + + center >>pos + collision-theta> -0.11 0.11 2random + >>theta + 0.5 3.0 2random >>speed + + 0.996 1.001 2random >>speed-d + 0 >>theta-d + 0 >>theta-dd + + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + + drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +METHOD: move { quark } + + dup myc>> 0.13 >>alpha stroke + dup pos>> point + + dup pos>> first2 >r dim swap - r> 2array point + + [ ] [ vel>> ] bi move-by + + turn + + step-theta + step-theta-d + step-speed-mul + + 1000 random 997 > + [ + dup speed>> neg >>speed + 2 over speed-d>> - >>speed-d + ] + when + + out-of-bounds? [ collide ] [ drop ] if ; From 56892ae74afe8b3050615380c8fc01e77521e4a4 Mon Sep 17 00:00:00 2001 From: slava Date: Fri, 11 Apr 2008 07:15:26 -0500 Subject: [PATCH 051/146] Overhaul monitors --- core/continuations/continuations-docs.factor | 6 +- core/io/files/files-docs.factor | 3 +- core/threads/threads.factor | 58 ++++---- .../mailboxes/mailboxes-docs.factor | 4 +- .../mailboxes/mailboxes-tests.factor | 39 +++++- extra/concurrency/mailboxes/mailboxes.factor | 46 +++++-- .../messaging/messaging-docs.factor | 5 +- .../messaging/messaging-tests.factor | 16 ++- extra/io/monitors/monitors-docs.factor | 84 +++++++++--- extra/io/monitors/monitors-tests.factor | 99 ++++++++++---- extra/io/monitors/monitors.factor | 92 ++++--------- .../monitors/recursive/recursive-tests.factor | 59 ++++++++ extra/io/monitors/recursive/recursive.factor | 105 ++++++++++++++ extra/io/timeouts/timeouts-docs.factor | 4 +- extra/io/unix/linux/linux.factor | 121 +--------------- extra/io/unix/linux/monitors/monitors.factor | 129 ++++++++++++++++++ extra/io/unix/macosx/macosx.factor | 19 ++- extra/io/unix/select/select.factor | 7 +- extra/tools/threads/threads.factor | 2 +- extra/tools/vocabs/monitor/monitor.factor | 27 ++-- extra/tools/vocabs/vocabs-tests.factor | 1 + extra/tools/vocabs/vocabs.factor | 9 +- 22 files changed, 627 insertions(+), 308 deletions(-) create mode 100644 extra/io/monitors/recursive/recursive-tests.factor create mode 100644 extra/io/monitors/recursive/recursive.factor create mode 100644 extra/io/unix/linux/monitors/monitors.factor diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index b3adb1b165..b1db09b6bc 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -90,7 +90,11 @@ ABOUT: "continuations" HELP: dispose { $values { "object" "a disposable object" } } -{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." } +{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." +$nl +"No further operations can be performed on a disposable object after this call." +$nl +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." } { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ; HELP: with-disposal diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index e3f86c079d..0d49e344a8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations" { $subsection "file-streams" } { $subsection "fs-meta" } { $subsection "directories" } -{ $subsection "delete-move-copy" } -{ $see-also "os" } ; +{ $subsection "delete-move-copy" } ; ABOUT: "io.files" diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..ba8f4f2e52 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -4,7 +4,7 @@ IN: threads USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private -dlists assocs system combinators init boxes ; +dlists assocs system combinators init boxes accessors ; SYMBOL: initial-thread @@ -18,11 +18,10 @@ mailbox variables sleep-entry ; ! Thread-local storage : tnamespace ( -- assoc ) - self dup thread-variables - [ ] [ H{ } clone dup rot set-thread-variables ] ?if ; + self variables>> [ H{ } clone dup self (>>variables) ] unless* ; : tget ( key -- value ) - self thread-variables at ; + self variables>> at ; : tset ( value key -- ) tnamespace set-at ; @@ -35,7 +34,7 @@ mailbox variables sleep-entry ; : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) - thread-id threads key? ; + id>> threads key? ; : check-unregistered dup thread-registered? @@ -48,38 +47,37 @@ mailbox variables sleep-entry ; > threads set-at ; : unregister-thread ( thread -- ) - check-registered thread-id threads delete-at ; + check-registered id>> threads delete-at ; : set-self ( thread -- ) 40 setenv ; inline PRIVATE> : ( quot name -- thread ) - \ thread counter [ ] { - set-thread-quot - set-thread-name - set-thread-id - set-thread-continuation - set-thread-exit-handler - } \ thread construct ; + \ thread construct-empty + swap >>name + swap >>quot + \ thread counter >>id + >>continuation + [ ] >>exit-handler ; : run-queue 42 getenv ; : sleep-queue 43 getenv ; : resume ( thread -- ) - f over set-thread-state + f >>state check-registered run-queue push-front ; : resume-now ( thread -- ) - f over set-thread-state + f >>state check-registered run-queue push-back ; : resume-with ( obj thread -- ) - f over set-thread-state + f >>state check-registered 2array run-queue push-front ; : sleep-time ( -- ms/f ) @@ -93,14 +91,14 @@ PRIVATE> : schedule-sleep ( thread ms -- ) >r check-registered dup r> sleep-queue heap-push* - swap set-thread-sleep-entry ; + >>sleep-entry drop ; : expire-sleep? ( heap -- ? ) dup heap-empty? [ drop f ] [ heap-peek nip millis <= ] if ; : expire-sleep ( thread -- ) - f over set-thread-sleep-entry resume ; + f >>sleep-entry resume ; : expire-sleep-loop ( -- ) sleep-queue @@ -123,21 +121,21 @@ PRIVATE> ] [ pop-back dup array? [ first2 ] [ f swap ] if dup set-self - f over set-thread-state - thread-continuation box> + f >>state + continuation>> box> continue-with ] if ; PRIVATE> : stop ( -- ) - self dup thread-exit-handler call + self dup exit-handler>> call unregister-thread next ; : suspend ( quot state -- obj ) [ - self thread-continuation >box - self set-thread-state + self continuation>> >box + self (>>state) self swap call next ] callcc1 2nip ; inline @@ -157,9 +155,9 @@ M: real sleep millis + >integer sleep-until ; : interrupt ( thread -- ) - dup thread-state [ - dup thread-sleep-entry [ sleep-queue heap-delete ] when* - f over set-thread-sleep-entry + dup state>> [ + dup sleep-entry>> [ sleep-queue heap-delete ] when* + f >>sleep-entry dup resume ] when drop ; @@ -171,7 +169,7 @@ M: real sleep V{ } set-catchstack { } set-retainstack >r { } set-datastack r> - thread-quot [ call stop ] call-clear + quot>> [ call stop ] call-clear ] 1 (throw) ] "spawn" suspend 2drop ; @@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- ) 43 setenv initial-thread global [ drop f "Initial" ] cache - over set-thread-continuation - f over set-thread-state + >>continuation + f >>state dup register-thread set-self ; diff --git a/extra/concurrency/mailboxes/mailboxes-docs.factor b/extra/concurrency/mailboxes/mailboxes-docs.factor index 50694776c5..a9b86e3bcd 100755 --- a/extra/concurrency/mailboxes/mailboxes-docs.factor +++ b/extra/concurrency/mailboxes/mailboxes-docs.factor @@ -57,7 +57,7 @@ HELP: mailbox-get? ARTICLE: "concurrency.mailboxes" "Mailboxes" -"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error." +"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary." { $subsection mailbox } { $subsection } "Removing the first element:" @@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes" "Testing if a mailbox is empty:" { $subsection mailbox-empty? } { $subsection while-mailbox-empty } ; + +ABOUT: "concurrency.mailboxes" diff --git a/extra/concurrency/mailboxes/mailboxes-tests.factor b/extra/concurrency/mailboxes/mailboxes-tests.factor index 2cb12bcaba..7fe09cdcf5 100755 --- a/extra/concurrency/mailboxes/mailboxes-tests.factor +++ b/extra/concurrency/mailboxes/mailboxes-tests.factor @@ -1,6 +1,7 @@ IN: concurrency.mailboxes.tests -USING: concurrency.mailboxes vectors sequences threads -tools.test math kernel strings ; +USING: concurrency.mailboxes concurrency.count-downs vectors +sequences threads tools.test math kernel strings namespaces +continuations calendar ; [ V{ 1 2 3 } ] [ 0 @@ -38,3 +39,37 @@ tools.test math kernel strings ; "junk2" over mailbox-put mailbox-get ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + [ "m" get mailbox-get drop ] + [ drop "d" get count-down ] recover +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test + + "m" set + +1 "c" set +1 "d" set + +[ + "c" get await + "m" get wait-for-close + "d" get count-down +] "Mailbox close test" spawn drop + +[ ] [ "c" get count-down ] unit-test +[ ] [ "m" get dispose ] unit-test +[ ] [ "d" get 5 seconds await-timeout ] unit-test + +[ ] [ "m" get dispose ] unit-test diff --git a/extra/concurrency/mailboxes/mailboxes.factor b/extra/concurrency/mailboxes/mailboxes.factor index 7b6405679f..36aafbdc84 100755 --- a/extra/concurrency/mailboxes/mailboxes.factor +++ b/extra/concurrency/mailboxes/mailboxes.factor @@ -3,41 +3,50 @@ IN: concurrency.mailboxes USING: dlists threads sequences continuations namespaces random math quotations words kernel arrays assocs -init system concurrency.conditions ; +init system concurrency.conditions accessors ; -TUPLE: mailbox threads data ; +TUPLE: mailbox threads data closed ; + +: check-closed ( mailbox -- ) + closed>> [ "Mailbox closed" throw ] when ; inline + +M: mailbox dispose + t >>closed threads>> notify-all ; : ( -- mailbox ) - mailbox construct-boa ; + f mailbox construct-boa ; : mailbox-empty? ( mailbox -- bool ) - mailbox-data dlist-empty? ; + data>> dlist-empty? ; : mailbox-put ( obj mailbox -- ) - [ mailbox-data push-front ] keep - mailbox-threads notify-all yield ; + [ data>> push-front ] + [ threads>> notify-all ] bi yield ; + +: wait-for-mailbox ( mailbox timeout -- ) + >r threads>> r> "mailbox" wait ; : block-unless-pred ( mailbox timeout pred -- ) - pick mailbox-data over dlist-contains? [ + pick check-closed + pick data>> over dlist-contains? [ 3drop ] [ - >r over mailbox-threads over "mailbox" wait r> - block-unless-pred + >r 2dup wait-for-mailbox r> block-unless-pred ] if ; inline : block-if-empty ( mailbox timeout -- mailbox ) + over check-closed over mailbox-empty? [ - over mailbox-threads over "mailbox" wait - block-if-empty + 2dup wait-for-mailbox block-if-empty ] [ drop ] if ; : mailbox-peek ( mailbox -- obj ) - mailbox-data peek-back ; + data>> peek-back ; : mailbox-get-timeout ( mailbox timeout -- obj ) - block-if-empty mailbox-data pop-back ; + block-if-empty data>> pop-back ; : mailbox-get ( mailbox -- obj ) f mailbox-get-timeout ; @@ -45,7 +54,7 @@ TUPLE: mailbox threads data ; : mailbox-get-all-timeout ( mailbox timeout -- array ) block-if-empty [ dup mailbox-empty? ] - [ dup mailbox-data pop-back ] + [ dup data>> pop-back ] [ ] unfold nip ; : mailbox-get-all ( mailbox -- array ) @@ -60,11 +69,18 @@ TUPLE: mailbox threads data ; : mailbox-get-timeout? ( mailbox timeout pred -- obj ) 3dup block-unless-pred - nip >r mailbox-data r> delete-node-if ; inline + nip >r data>> r> delete-node-if ; inline : mailbox-get? ( mailbox pred -- obj ) f swap mailbox-get-timeout? ; inline +: wait-for-close-timeout ( mailbox timeout -- ) + over closed>> + [ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ; + +: wait-for-close ( mailbox -- ) + f wait-for-close-timeout ; + TUPLE: linked-error thread ; : ( error thread -- linked ) diff --git a/extra/concurrency/messaging/messaging-docs.factor b/extra/concurrency/messaging/messaging-docs.factor index e7aa5d1a7e..1219982f51 100755 --- a/extra/concurrency/messaging/messaging-docs.factor +++ b/extra/concurrency/messaging/messaging-docs.factor @@ -32,7 +32,7 @@ HELP: spawn-linked { $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" } { $see-also spawn } ; -ARTICLE: { "concurrency" "messaging" } "Mailboxes" +ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages" "Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued." $nl "The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is." @@ -43,7 +43,8 @@ $nl { $subsection receive } { $subsection receive-timeout } { $subsection receive-if } -{ $subsection receive-if-timeout } ; +{ $subsection receive-if-timeout } +{ $see-also "concurrency.mailboxes" } ; ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends" "The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:" diff --git a/extra/concurrency/messaging/messaging-tests.factor b/extra/concurrency/messaging/messaging-tests.factor index 6de381b166..b69773f3b1 100755 --- a/extra/concurrency/messaging/messaging-tests.factor +++ b/extra/concurrency/messaging/messaging-tests.factor @@ -3,7 +3,8 @@ ! USING: kernel threads vectors arrays sequences namespaces tools.test continuations dlists strings math words -match quotations concurrency.messaging concurrency.mailboxes ; +match quotations concurrency.messaging concurrency.mailboxes +concurrency.count-downs ; IN: concurrency.messaging.tests [ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test @@ -52,4 +53,15 @@ SYMBOL: exit [ value , self , ] { } make "counter" get send receive exit "counter" get send -] unit-test \ No newline at end of file +] unit-test + +! Not yet + +! 1 "c" set + +! [ +! "c" get count-down +! receive drop +! ] "Bad synchronous send" spawn "t" set + +! [ 3 "t" get send-synchronous ] must-fail \ No newline at end of file diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index 4f24879e19..ae561cd666 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,58 +1,106 @@ IN: io.monitors -USING: help.markup help.syntax continuations ; +USING: help.markup help.syntax continuations +concurrency.mailboxes quotations ; + +HELP: with-monitors +{ $values { "quot" quotation } } +{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." } +{ $errors "Throws an error if the platform does not support file system change monitors." } ; HELP: { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } } -{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." -$nl -"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ; +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; + +HELP: (monitor) +{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } } +{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; +{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } +{ $errors "Throws an error if the monitor is closed from another thread." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } -{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ; +{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } +{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ; HELP: +add-file+ -{ $description "Indicates that the file has been added to the directory." } ; +{ $description "Indicates that a file has been added to its parent directory." } ; HELP: +remove-file+ -{ $description "Indicates that the file has been removed from the directory." } ; +{ $description "Indicates that a file has been removed from its parent directory." } ; HELP: +modify-file+ -{ $description "Indicates that the file contents have changed." } ; +{ $description "Indicates that a file's contents have changed." } ; -HELP: +rename-file+ -{ $description "Indicates that file has been renamed." } ; +HELP: +rename-file-old+ +{ $description "Indicates that a file has been renamed, and this is the old name." } ; + +HELP: +rename-file-new+ +{ $description "Indicates that a file has been renamed, and this is the new name." } ; ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } -{ $subsection +rename-file+ } -{ $subsection +add-file+ } ; +{ $subsection +rename-file-old+ } +{ $subsection +rename-file-new+ } ; + +ARTICLE: "io.monitors.platforms" "Monitors on different platforms" +"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." +{ $heading "Mac OS X" } +"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later." +$nl +{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link } " has no effect." +$nl +"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available." +{ $heading "Windows" } +"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows." +$nl +"Both recursive and non-recursive monitors are directly supported by the operating system." +{ $heading "Linux" } +"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." +$nl +"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." +{ $heading "BSD" } +"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." +$nl +"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +$nl +"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +{ $heading "Windows CE" } +"Windows CE does not support monitors." ; ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl +"Monitoring operations must be wrapped in a combinator:" +{ $subsection with-monitors } "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } +"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:" +{ $subsection (monitor) } { $subsection "io.monitors.descriptors" } -"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." -$nl -"A utility combinator which opens a monitor and cleans it up after:" +{ $subsection "io.monitors.platforms" } +"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:" { $subsection with-monitor } -"An example which watches the Factor directory for changes:" +"Monitors support the " { $link "io.timeouts" } "." +$nl +"An example which watches a directory for changes:" { $code "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" - "\"\" resource-path f [ watch-loop ] with-monitor" + ": watch-directory ( path -- )" + " [ t [ watch-loop ] with-monitor ] with-monitors" } ; ABOUT: "io.monitors" diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 7170e824c8..6f7478fce2 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,36 +3,89 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os { winnt macosx linux } member? [ - [ "monitor-test" temp-file delete-tree ] ignore-errors +os wince? [ + [ + [ "monitor-test" temp-file delete-tree ] ignore-errors - [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test + [ ] [ "monitor-test" temp-file make-directory ] unit-test - [ ] [ "monitor-test" temp-file t "m" set ] unit-test + [ ] [ "monitor-test" temp-file t "m" set ] unit-test - [ ] [ 1 "b" set ] unit-test + [ ] [ "monitor-test/a1" temp-file make-directory ] unit-test - [ ] [ 1 "c" set ] unit-test + [ ] [ "monitor-test/a2" temp-file make-directory ] unit-test - [ ] [ - [ - "b" get count-down - [ - "m" get next-change drop - dup print flush right-trim-separators - "xyz" tail? not - ] [ ] [ ] while - "c" get count-down - ] "Monitor test thread" spawn drop - ] unit-test + [ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test - [ ] [ "b" get await ] unit-test + [ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test - [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test - [ ] [ "c" get 30 seconds await-timeout ] unit-test + [ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test - [ ] [ "m" get dispose ] unit-test + [ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test + [ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test + [ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test - [ "m" get dispose ] must-fail -] when + [ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test + + [ ] [ "m" get dispose ] unit-test + ] with-monitors + + + [ + [ "monitor-test" temp-file delete-tree ] ignore-errors + + [ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test + + [ ] [ "monitor-test" temp-file t "m" set ] unit-test + + [ ] [ 1 "b" set ] unit-test + + [ ] [ 1 "c1" set ] unit-test + + [ ] [ 1 "c2" set ] unit-test + + [ ] [ + [ + "b" get count-down + + [ + "m" get next-change drop + dup print flush + dup parent-directory + [ right-trim-separators "xyz" tail? ] either? not + ] [ ] [ ] while + + "c1" get count-down + + [ + "m" get next-change drop + dup print flush + dup parent-directory + [ right-trim-separators "yxy" tail? ] either? not + ] [ ] [ ] while + + "c2" get count-down + ] "Monitor test thread" spawn drop + ] unit-test + + [ ] [ "b" get await ] unit-test + + [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test + + [ ] [ "c1" get 5 seconds await-timeout ] unit-test + + [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test + + [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test + + [ ] [ "c2" get 5 seconds await-timeout ] unit-test + + ! Dispose twice + [ ] [ "m" get dispose ] unit-test + + [ ] [ "m" get dispose ] unit-test + ] with-monitors +] unless diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 1678c2de41..8128acfea8 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -1,83 +1,49 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences -assocs hashtables sorting arrays threads boxes io.timeouts ; +assocs hashtables sorting arrays threads boxes io.timeouts +accessors concurrency.mailboxes ; IN: io.monitors -array ; - -M: monitor dispose - dup check-monitor - t over set-monitor-closed? - delegate dispose ; - -! Simple monitor; used on Linux and Mac OS X. On Windows, -! monitors are full-fledged ports. -TUPLE: simple-monitor handle callback timeout ; - -M: simple-monitor timeout simple-monitor-timeout ; - -M: simple-monitor set-timeout set-simple-monitor-timeout ; - -: ( handle -- simple-monitor ) - f (monitor) { - set-simple-monitor-handle - set-delegate - set-simple-monitor-callback - } simple-monitor construct ; - -: construct-simple-monitor ( handle class -- simple-monitor ) - >r r> construct-delegate ; inline - -: notify-callback ( simple-monitor -- ) - simple-monitor-callback [ resume ] if-box? ; - -M: simple-monitor timed-out - notify-callback ; - -M: simple-monitor fill-queue ( monitor -- ) +: with-monitors ( quot -- ) [ - [ swap simple-monitor-callback >box ] - "monitor" suspend drop - ] with-timeout - check-monitor ; + init-monitors + [ dispose-monitors ] [ ] cleanup + ] with-scope ; inline -M: simple-monitor dispose ( monitor -- ) - dup delegate dispose notify-callback ; +TUPLE: monitor < identity-tuple path queue timeout ; -PRIVATE> +M: monitor hashcode* path>> hashcode* ; -HOOK: io-backend ( path recursive? -- monitor ) +M: monitor timeout timeout>> ; + +M: monitor set-timeout (>>timeout) ; + +: construct-monitor ( path mailbox class -- monitor ) + construct-empty + swap >>queue + swap >>path ; inline + +: queue-change ( path changes monitor -- ) + dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + +HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) + +: ( path recursive? -- monitor ) + (monitor) ; : next-change ( monitor -- path changed ) - dup check-monitor - dup monitor-queue dup assoc-empty? [ - drop dup fill-queue next-change - ] [ nip dequeue-change ] if ; + [ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ; SYMBOL: +add-file+ SYMBOL: +remove-file+ SYMBOL: +modify-file+ -SYMBOL: +rename-file+ +SYMBOL: +rename-file-old+ +SYMBOL: +rename-file-new+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/monitors/recursive/recursive-tests.factor b/extra/io/monitors/recursive/recursive-tests.factor new file mode 100644 index 0000000000..3182747194 --- /dev/null +++ b/extra/io/monitors/recursive/recursive-tests.factor @@ -0,0 +1,59 @@ +USING: accessors math kernel namespaces continuations +io.files io.monitors io.monitors.recursive io.backend +concurrency.mailboxes +tools.test ; +IN: io.monitors.recursive.tests + +\ pump-thread must-infer + +SINGLETON: mock-io-backend + +TUPLE: counter i ; + +SYMBOL: dummy-monitor-created +SYMBOL: dummy-monitor-disposed + +TUPLE: dummy-monitor < monitor ; + +M: dummy-monitor dispose + drop dummy-monitor-disposed get [ 1+ ] change-i drop ; + +M: mock-io-backend (monitor) + nip + over exists? [ + dummy-monitor construct-monitor + dummy-monitor-created get [ 1+ ] change-i drop + ] [ + "Does not exist" throw + ] if ; + +M: mock-io-backend link-info + global [ link-info ] bind ; + +[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test +[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test + +[ ] [ + mock-io-backend io-backend [ + "" resource-path dispose + ] with-variable +] unit-test + +[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test + +[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test + +[ "doesnotexist" temp-file delete-tree ] ignore-errors + +[ + mock-io-backend io-backend [ + "doesnotexist" temp-file dispose + ] with-variable +] must-fail + +[ ] [ + mock-io-backend io-backend [ + "" resource-path + [ dispose ] [ dispose ] bi + ] with-variable +] unit-test diff --git a/extra/io/monitors/recursive/recursive.factor b/extra/io/monitors/recursive/recursive.factor new file mode 100644 index 0000000000..8c2560f681 --- /dev/null +++ b/extra/io/monitors/recursive/recursive.factor @@ -0,0 +1,105 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors sequences assocs arrays continuations combinators kernel +threads concurrency.messaging concurrency.mailboxes +concurrency.promises +io.files io.monitors ; +IN: io.monitors.recursive + +! Simulate recursive monitors on platforms that don't have them + +TUPLE: recursive-monitor < monitor children thread ready ; + +DEFER: add-child-monitor + +: qualify-path ( path -- path' ) + monitor tget path>> prepend-path ; + +: add-child-monitors ( path -- ) + #! We yield since this directory scan might take a while. + [ + directory* [ first add-child-monitor yield ] each + ] curry ignore-errors ; + +: add-child-monitor ( path -- ) + qualify-path dup link-info type>> +directory+ eq? [ + [ add-child-monitors ] + [ + [ f my-mailbox (monitor) ] keep + monitor tget children>> set-at + ] bi + ] [ drop ] if ; + +USE: io +USE: prettyprint + +: remove-child-monitor ( monitor -- ) + monitor tget children>> delete-at* + [ dispose ] [ drop ] if ; + +M: recursive-monitor dispose + dup queue>> closed>> [ + drop + ] [ + [ "stop" swap thread>> send-synchronous drop ] + [ queue>> dispose ] bi + ] if ; + +: stop-pump ( -- ) + monitor tget children>> [ nip dispose ] assoc-each ; + +: pump-step ( msg -- ) + first3 path>> swap >r prepend-path r> monitor tget 3array + monitor tget queue>> + mailbox-put ; + +: child-added ( path monitor -- ) + path>> prepend-path add-child-monitor ; + +: child-removed ( path monitor -- ) + path>> prepend-path remove-child-monitor ; + +: update-hierarchy ( msg -- ) + first3 swap [ + { + { +add-file+ [ child-added ] } + { +remove-file+ [ child-removed ] } + { +rename-file-old+ [ child-removed ] } + { +rename-file-new+ [ child-added ] } + [ 3drop ] + } case + ] with with each ; + +: pump-loop ( -- ) + receive dup synchronous? [ + >r stop-pump t r> reply-synchronous + ] [ + [ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi + pump-loop + ] if ; + +: monitor-ready ( error/t -- ) + monitor tget ready>> fulfill ; + +: pump-thread ( monitor -- ) + monitor tset + [ "" add-child-monitor t monitor-ready ] + [ [ self monitor-ready ] keep rethrow ] + recover + pump-loop ; + +: start-pump-thread ( monitor -- ) + dup [ pump-thread ] curry + "Recursive monitor pump" spawn + >>thread drop ; + +: wait-for-ready ( monitor -- ) + ready>> ?promise ?linked drop ; + +: ( path mailbox -- monitor ) + >r (normalize-path) r> + recursive-monitor construct-monitor + H{ } clone >>children + >>ready + dup start-pump-thread + dup wait-for-ready ; diff --git a/extra/io/timeouts/timeouts-docs.factor b/extra/io/timeouts/timeouts-docs.factor index df7e1389cc..64104083be 100755 --- a/extra/io/timeouts/timeouts-docs.factor +++ b/extra/io/timeouts/timeouts-docs.factor @@ -18,13 +18,13 @@ HELP: with-timeout { $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ; ARTICLE: "io.timeouts" "I/O timeout protocol" -"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." +"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed." { $subsection timeout } { $subsection set-timeout } "The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations." { $subsection timed-out } "A combinator to be used in operations which can time out:" { $subsection with-timeout } -{ $see-also "stream-protocol" "io.launcher" } ; +{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ; ABOUT: "io.timeouts" diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 30c61f6d21..e75f4c5f6b 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,125 +1,10 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel io.backend io.monitors io.monitors.private -io.files io.buffers io.nonblocking io.timeouts io.unix.backend -io.unix.select io.unix.launcher unix.linux.inotify assocs -namespaces threads continuations init math alien.c-types alien -vocabs.loader accessors system ; +USING: kernel io.backend io.monitors io.unix.backend +io.unix.select io.unix.linux.monitors system namespaces ; IN: io.unix.linux -TUPLE: linux-monitor ; - -: ( wd -- monitor ) - linux-monitor construct-simple-monitor ; - -TUPLE: inotify watches ; - -: watches ( -- assoc ) inotify get-global watches>> ; - -: wd>monitor ( wd -- monitor ) watches at ; - -: ( -- port/f ) - H{ } clone - inotify_init dup 0 < [ 2drop f ] [ - inotify - { set-inotify-watches set-delegate } inotify construct - ] if ; - -: inotify-fd inotify get-global handle>> ; - -: (add-watch) ( path mask -- wd ) - inotify-fd -rot inotify_add_watch dup io-error ; - -: check-existing ( wd -- ) - watches key? [ - "Cannot open multiple monitors for the same file" throw - ] when ; - -: add-watch ( path mask -- monitor ) - (add-watch) dup check-existing - [ dup ] keep watches set-at ; - -: remove-watch ( monitor -- ) - dup simple-monitor-handle watches delete-at - simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ; - -: check-inotify - inotify get [ - "inotify is not supported by this Linux release" throw - ] unless ; - -M: linux ( path recursive? -- monitor ) - check-inotify - drop IN_CHANGE_EVENTS add-watch ; - -M: linux-monitor dispose ( monitor -- ) - dup delegate dispose remove-watch ; - -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; - -: parse-action ( mask -- changed ) - [ - IN_CREATE +add-file+ ?flag - IN_DELETE +remove-file+ ?flag - IN_DELETE_SELF +remove-file+ ?flag - IN_MODIFY +modify-file+ ?flag - IN_ATTRIB +modify-file+ ?flag - IN_MOVED_FROM +rename-file+ ?flag - IN_MOVED_TO +rename-file+ ?flag - IN_MOVE_SELF +rename-file+ ?flag - drop - ] { } make ; - -: parse-file-notify ( buffer -- changed path ) - { inotify-event-name inotify-event-mask } get-slots - parse-action swap alien>char-string ; - -: events-exhausted? ( i buffer -- ? ) - fill>> >= ; - -: inotify-event@ ( i buffer -- alien ) - ptr>> ; - -: next-event ( i buffer -- i buffer ) - 2dup inotify-event@ - inotify-event-len "inotify-event" heap-size + - swap >r + r> ; - -: parse-file-notifications ( i buffer -- ) - 2dup events-exhausted? [ 2drop ] [ - 2dup inotify-event@ dup inotify-event-wd wd>monitor [ - monitor-queue [ - parse-file-notify changed-file - ] bind - ] keep notify-callback - next-event parse-file-notifications - ] if ; - -: read-notifications ( port -- ) - dup refill drop - 0 over parse-file-notifications - 0 swap buffer-reset ; - -TUPLE: inotify-task ; - -: ( port -- task ) - f inotify-task ; - -: init-inotify ( mx -- ) - dup [ - dup inotify set-global - swap register-io-task - ] [ - 2drop - ] if ; - -M: inotify-task do-io-task ( task -- ) - io-task-port read-notifications f ; - M: linux init-io ( -- ) - - [ mx set-global ] - [ init-inotify ] bi ; + mx set-global ; linux set-io-backend diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor new file mode 100644 index 0000000000..5f23199146 --- /dev/null +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -0,0 +1,129 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.backend io.monitors io.monitors.recursive +io.files io.buffers io.monitors io.nonblocking io.timeouts +io.unix.backend io.unix.select unix.linux.inotify assocs +namespaces threads continuations init math math.bitfields +alien.c-types alien vocabs.loader accessors system ; +IN: io.unix.linux.monitors + +TUPLE: linux-monitor < monitor wd ; + +: ( wd path mailbox -- monitor ) + linux-monitor construct-monitor + swap >>wd ; + +SYMBOL: watches + +SYMBOL: inotify + +: wd>monitor ( wd -- monitor ) watches get at ; + +: ( -- port/f ) + inotify_init dup 0 < [ drop f ] [ ] if ; + +: inotify-fd inotify get handle>> ; + +: check-existing ( wd -- ) + watches get key? [ + "Cannot open multiple monitors for the same file" throw + ] when ; + +: (add-watch) ( path mask -- wd ) + inotify-fd -rot inotify_add_watch dup io-error dup check-existing ; + +: add-watch ( path mask mailbox -- monitor ) + >r + >r (normalize-path) r> + [ (add-watch) ] [ drop ] 2bi r> + [ ] [ ] [ wd>> ] tri watches get set-at ; + +: check-inotify + inotify get [ + "Calling outside with-monitors" throw + ] unless ; + +M: linux (monitor) ( path recursive? mailbox -- monitor ) + swap [ + + ] [ + check-inotify + IN_CHANGE_EVENTS swap add-watch + ] if ; + +M: linux-monitor dispose ( monitor -- ) + [ wd>> watches get delete-at ] + [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; + +: ignore-flags? ( mask -- ? ) + { + IN_DELETE_SELF + IN_MOVE_SELF + IN_UNMOUNT + IN_Q_OVERFLOW + IN_IGNORED + } flags bitand 0 > ; + +: parse-action ( mask -- changed ) + [ + IN_CREATE +add-file+ ?flag + IN_DELETE +remove-file+ ?flag + IN_MODIFY +modify-file+ ?flag + IN_ATTRIB +modify-file+ ?flag + IN_MOVED_FROM +rename-file-old+ ?flag + IN_MOVED_TO +rename-file-new+ ?flag + drop + ] { } make ; + +: parse-file-notify ( buffer -- path changed ) + dup inotify-event-mask ignore-flags? [ + drop f f + ] [ + [ inotify-event-name alien>char-string ] + [ inotify-event-mask parse-action ] bi + ] if ; + +: events-exhausted? ( i buffer -- ? ) + fill>> >= ; + +: inotify-event@ ( i buffer -- alien ) + ptr>> ; + +: next-event ( i buffer -- i buffer ) + 2dup inotify-event@ + inotify-event-len "inotify-event" heap-size + + swap >r + r> ; + +: parse-file-notifications ( i buffer -- ) + 2dup events-exhausted? [ 2drop ] [ + 2dup inotify-event@ dup inotify-event-wd wd>monitor + >r parse-file-notify r> queue-change + next-event parse-file-notifications + ] if ; + +: inotify-read-loop ( port -- ) + dup wait-to-read1 + 0 over parse-file-notifications + 0 over buffer-reset + inotify-read-loop ; + +: inotify-read-thread ( port -- ) + [ inotify-read-loop ] curry ignore-errors ; + +M: linux init-monitors + H{ } clone watches set + [ + [ inotify set ] + [ + [ inotify-read-thread ] curry + "Linux monitor thread" spawn drop + ] bi + ] [ + "Linux kernel version is too old" throw + ] if* ; + +M: linux dispose-monitors + inotify get dispose ; diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index c1c73ea018..039b1b250b 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,23 +1,22 @@ -USING: io.unix.bsd io.backend io.monitors io.monitors.private -continuations kernel core-foundation.fsevents sequences -namespaces arrays system ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents +continuations kernel sequences namespaces arrays system locals ; IN: io.unix.macosx macosx set-io-backend -TUPLE: macosx-monitor ; +TUPLE: macosx-monitor < monitor handle ; : enqueue-notifications ( triples monitor -- ) tuck monitor-queue [ [ first { +modify-file+ } swap changed-file ] each ] bind notify-callback ; -M: macosx - drop - f macosx-monitor construct-simple-monitor +M:: macosx (monitor) ( path recursive? mailbox -- monitor ) + path mailbox macosx-monitor construct-monitor dup [ enqueue-notifications ] curry - rot 1array 0 0 - over set-simple-monitor-handle ; + path 1array 0 0 >>handle ; M: macosx-monitor dispose - dup simple-monitor-handle dispose delegate dispose ; + handle>> dispose ; diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index aceee0f311..6527a87010 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ; [ handle-fd ] 2curry assoc-each ; : init-fdset ( tasks fdset -- ) - ! dup clear-bits [ >r drop t swap munge r> set-nth ] curry assoc-each ; : read-fdset/tasks @@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ; [ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ; : init-fdsets ( mx -- nfds read write except ) - [ num-fds ] keep - [ read-fdset/tasks tuck init-fdset ] keep - write-fdset/tasks tuck init-fdset + [ num-fds ] + [ read-fdset/tasks tuck init-fdset ] + [ write-fdset/tasks tuck init-fdset ] tri f ; M: select-mx wait-for-events ( ms mx -- ) diff --git a/extra/tools/threads/threads.factor b/extra/tools/threads/threads.factor index 552247e2c4..060377d127 100755 --- a/extra/tools/threads/threads.factor +++ b/extra/tools/threads/threads.factor @@ -22,7 +22,7 @@ heaps.private system math math.parser ; : threads. ( -- ) standard-table-style [ [ - { "ID" "Name" "Waiting on" "Remaining sleep" } + { "ID:" "Name:" "Waiting on:" "Remaining sleep:" } [ [ write ] with-cell ] each ] with-row diff --git a/extra/tools/vocabs/monitor/monitor.factor b/extra/tools/vocabs/monitor/monitor.factor index f763a1520d..ab5e8c66b7 100755 --- a/extra/tools/vocabs/monitor/monitor.factor +++ b/extra/tools/vocabs/monitor/monitor.factor @@ -22,22 +22,29 @@ IN: tools.vocabs.monitor : path>vocab ( path -- vocab ) chop-vocab-root path>vocab-name vocab-dir>vocab-name ; -: monitor-thread ( monitor -- ) +: monitor-loop ( monitor -- ) #! On OS X, monitors give us the full path, so we chop it #! off if its there. - next-change drop path>vocab changed-vocab reset-cache ; + dup next-change drop path>vocab changed-vocab + reset-cache + monitor-loop ; + +: monitor-thread ( -- ) + [ + [ + "" resource-path t + + H{ } clone changed-vocabs set-global + vocabs [ changed-vocab ] each + + monitor-loop + ] with-monitors + ] ignore-errors ; : start-monitor-thread ( -- ) #! Silently ignore errors during monitor creation since #! monitors are not supported on all platforms. - [ - "" resource-path t [ monitor-thread t ] curry - "Vocabulary monitor" spawn-server drop - - H{ } clone changed-vocabs set-global - - vocabs [ changed-vocab ] each - ] ignore-errors ; + [ monitor-thread ] "Vocabulary monitor" spawn drop ; [ "-no-monitors" cli-args member? [ diff --git a/extra/tools/vocabs/vocabs-tests.factor b/extra/tools/vocabs/vocabs-tests.factor index ae74d516e4..04e628d080 100644 --- a/extra/tools/vocabs/vocabs-tests.factor +++ b/extra/tools/vocabs/vocabs-tests.factor @@ -4,5 +4,6 @@ USING: tools.test tools.vocabs namespaces continuations ; [ ] [ changed-vocabs get-global f changed-vocabs set-global + [ t ] [ "kernel" changed-vocab? ] unit-test [ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup ] unit-test diff --git a/extra/tools/vocabs/vocabs.factor b/extra/tools/vocabs/vocabs.factor index 371bbc7813..a65a8f093a 100755 --- a/extra/tools/vocabs/vocabs.factor +++ b/extra/tools/vocabs/vocabs.factor @@ -85,10 +85,11 @@ SYMBOL: changed-vocabs : unchanged-vocabs ( vocabs -- ) [ unchanged-vocab ] each ; +: changed-vocab? ( vocab -- ? ) + changed-vocabs get dup [ key? ] [ 2drop t ] if ; + : filter-changed ( vocabs -- vocabs' ) - changed-vocabs get [ - [ key? ] curry subset - ] when* ; + [ changed-vocab? ] subset ; SYMBOL: modified-sources SYMBOL: modified-docs @@ -96,7 +97,7 @@ SYMBOL: modified-docs : (to-refresh) ( vocab variable loaded? path -- ) dup [ swap [ - pick changed-vocabs get key? [ + pick changed-vocab? [ source-modified? [ get push ] [ 2drop ] if ] [ 3drop ] if ] [ drop get push ] if From 0c7e742b8c9796d5352b5721001245f68e9a13cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:07 -0500 Subject: [PATCH 052/146] step-into for hooks --- core/generic/standard/standard.factor | 10 ++++++++-- extra/tools/walker/walker.factor | 1 + 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index ed5134a624..98194e7ef3 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -110,6 +110,9 @@ ERROR: no-next-method class generic ; \ if , ] [ ] make ; +: single-effective-method ( obj word -- method ) + [ order [ instance? ] with find-last nip ] keep method ; + TUPLE: standard-combination # ; C: standard-combination @@ -142,8 +145,7 @@ M: standard-combination next-method-quot* ] with-standard ; M: standard-generic effective-method - [ dispatch# (picker) call ] keep - [ order [ instance? ] with find-last nip ] keep method ; + [ dispatch# (picker) call ] keep single-effective-method ; TUPLE: hook-combination var ; @@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ; M: hook-generic extra-values drop 1 ; +M: hook-generic effective-method + [ "combination" word-prop var>> get ] keep + single-effective-method ; + M: hook-combination make-default-method [ error-method ] with-hook ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 4d1a4da6b1..42c8f93e4c 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -72,6 +72,7 @@ M: object add-breakpoint ; { { [ dup "step-into" word-prop ] [ "step-into" word-prop call ] } { [ dup standard-generic? ] [ effective-method (step-into-execute) ] } + { [ dup hook-generic? ] [ effective-method (step-into-execute) ] } { [ dup primitive? ] [ execute break ] } { [ t ] [ word-def (step-into-quot) ] } } cond ; From 82d793b14183ab06e597738811e6950f8848c599 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 08:35:21 -0500 Subject: [PATCH 053/146] Update Mac OS X monitors for new API --- extra/core-foundation/fsevents/fsevents.factor | 4 +--- extra/io/monitors/monitors.factor | 3 ++- extra/io/unix/macosx/macosx.factor | 17 +++++++++++------ 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index 55f2462061..f181d8a761 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -151,12 +151,10 @@ SYMBOL: event-stream-callbacks [ event-stream-callbacks global - [ [ drop expired? not ] assoc-subset ] change-at + [ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at 1 \ event-stream-counter set-global ] "core-foundation" add-init-hook -event-stream-callbacks global [ H{ } assoc-like ] change-at - : add-event-source-callback ( quot -- id ) event-stream-counter [ event-stream-callbacks get set-at ] keep ; diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8128acfea8..8d2ddba5f2 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -29,7 +29,8 @@ M: monitor set-timeout (>>timeout) ; swap >>path ; inline : queue-change ( path changes monitor -- ) - dup [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; + 3dup and and + [ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ; HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor ) diff --git a/extra/io/unix/macosx/macosx.factor b/extra/io/unix/macosx/macosx.factor index 039b1b250b..68eb2f13bb 100644 --- a/extra/io/unix/macosx/macosx.factor +++ b/extra/io/unix/macosx/macosx.factor @@ -1,17 +1,20 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents -continuations kernel sequences namespaces arrays system locals ; +continuations kernel sequences namespaces arrays system locals +accessors ; IN: io.unix.macosx -macosx set-io-backend - TUPLE: macosx-monitor < monitor handle ; : enqueue-notifications ( triples monitor -- ) - tuck monitor-queue - [ [ first { +modify-file+ } swap changed-file ] each ] bind - notify-callback ; + [ + >r first { +modify-file+ } r> queue-change + ] curry each ; + +M: macosx init-monitors ; + +M: macosx dispose-monitors ; M:: macosx (monitor) ( path recursive? mailbox -- monitor ) path mailbox macosx-monitor construct-monitor @@ -20,3 +23,5 @@ M:: macosx (monitor) ( path recursive? mailbox -- monitor ) M: macosx-monitor dispose handle>> dispose ; + +macosx set-io-backend From d132bce5a3603eb9df65f390cce6301c5903adff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 09:54:50 -0500 Subject: [PATCH 054/146] Implement monitors for BSD --- extra/io/monitors/monitors-docs.factor | 6 +- extra/io/monitors/monitors-tests.factor | 4 +- extra/io/monitors/monitors.factor | 1 + extra/io/unix/backend/backend.factor | 3 + extra/io/unix/bsd/bsd.factor | 19 +++- extra/io/unix/kqueue/kqueue.factor | 104 +++++++++++++++---- extra/io/unix/linux/monitors/monitors.factor | 5 +- 7 files changed, 113 insertions(+), 29 deletions(-) mode change 100755 => 100644 extra/io/unix/backend/backend.factor mode change 100755 => 100644 extra/io/unix/kqueue/kqueue.factor diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index ae561cd666..df4f7ae352 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -42,13 +42,17 @@ HELP: +rename-file-old+ HELP: +rename-file-new+ { $description "Indicates that a file has been renamed, and this is the new name." } ; +HELP: +rename-file+ +{ $description "Indicates that a file has been renamed." } ; + ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } { $subsection +modify-file+ } { $subsection +rename-file-old+ } -{ $subsection +rename-file-new+ } ; +{ $subsection +rename-file-new+ } +{ $subsection +rename-file+ } ; ARTICLE: "io.monitors.platforms" "Monitors on different platforms" "Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link } " is platform-specific. User code should not assume either case." diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 6f7478fce2..0216baf699 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -3,7 +3,7 @@ USING: io.monitors tools.test io.files system sequences continuations namespaces concurrency.count-downs kernel io threads calendar prettyprint ; -os wince? [ +os { winnt linux macosx } member? [ [ [ "monitor-test" temp-file delete-tree ] ignore-errors @@ -88,4 +88,4 @@ os wince? [ [ ] [ "m" get dispose ] unit-test ] with-monitors -] unless +] when diff --git a/extra/io/monitors/monitors.factor b/extra/io/monitors/monitors.factor index 8d2ddba5f2..51cbdd5b1b 100755 --- a/extra/io/monitors/monitors.factor +++ b/extra/io/monitors/monitors.factor @@ -45,6 +45,7 @@ SYMBOL: +remove-file+ SYMBOL: +modify-file+ SYMBOL: +rename-file-old+ SYMBOL: +rename-file-new+ +SYMBOL: +rename-file+ : with-monitor ( path recursive? quot -- ) >r r> with-disposal ; inline diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor old mode 100755 new mode 100644 index 865490b0ce..0fb8b0c5f2 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -203,3 +203,6 @@ M: mx-task do-io-task : multiplexer-error ( n -- ) 0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 12a64a41f9..03723a65e5 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -1,8 +1,21 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.unix.bsd -USING: io.backend io.unix.backend io.unix.select -namespaces system ; +USING: namespaces system kernel accessors assocs continuations +unix +io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ; M: bsd init-io ( -- ) - mx set-global ; + mx set-global + kqueue-mx set-global + kqueue-mx get-global + dup io-task-fd + [ mx get-global reads>> set-at ] + [ mx get-global writes>> set-at ] 2bi ; + +M: bsd init-monitors ; + +M: bsd dispose-monitors ; + +M: bsd (monitor) ( path recursive? mailbox -- ) + nip ; diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor old mode 100755 new mode 100644 index 97b186edf3..3735caa7d2 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -1,12 +1,14 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types kernel io.nonblocking io.unix.backend -sequences assocs unix unix.time unix.kqueue unix.process math namespaces -combinators threads vectors io.launcher -io.unix.launcher ; +USING: alien.c-types kernel math math.bitfields namespaces +locals accessors combinators threads vectors hashtables +sequences assocs continuations +unix unix.time unix.kqueue unix.process +io.nonblocking io.unix.backend io.launcher io.unix.launcher +io.monitors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events ; +TUPLE: kqueue-mx events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ; : ( -- mx ) kqueue-mx construct-mx - kqueue dup io-error over set-mx-fd - max-events "kevent" over set-kqueue-mx-events ; + H{ } clone >>monitors + kqueue dup io-error >>fd + max-events "kevent" >>events ; GENERIC: io-task-filter ( task -- n ) @@ -24,14 +27,19 @@ M: input-task io-task-filter drop EVFILT_READ ; M: output-task io-task-filter drop EVFILT_WRITE ; +GENERIC: io-task-fflags ( task -- n ) + +M: io-task io-task-fflags drop 0 ; + : make-kevent ( task flags -- event ) "kevent" tuck set-kevent-flags over io-task-fd over set-kevent-ident + over io-task-fflags over set-kevent-fflags swap io-task-filter over set-kevent-filter ; : register-kevent ( kevent mx -- ) - mx-fd swap 1 f 0 f kevent + fd>> swap 1 f 0 f kevent 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) @@ -43,33 +51,52 @@ M: kqueue-mx unregister-io-task ( task mx -- ) swap EV_DELETE make-kevent swap register-kevent ; : wait-kevent ( mx timespec -- n ) - >r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent + >r [ fd>> f 0 ] keep events>> max-events r> kevent dup multiplexer-error ; -: kevent-read-task ( mx fd -- ) - over mx-reads at handle-io-task ; +:: kevent-read-task ( mx fd kevent -- ) + mx fd mx reads>> at handle-io-task ; -: kevent-write-task ( mx fd -- ) - over mx-reads at handle-io-task ; +:: kevent-write-task ( mx fd kevent -- ) + mx fd mx writes>> at handle-io-task ; -: kevent-proc-task ( pid -- ) - dup wait-for-pid swap find-process +:: kevent-proc-task ( mx pid kevent -- ) + pid wait-for-pid + pid find-process dup [ swap notify-exit ] [ 2drop ] if ; +: parse-action ( mask -- changed ) + [ + NOTE_DELETE +remove-file+ ?flag + NOTE_WRITE +modify-file+ ?flag + NOTE_EXTEND +modify-file+ ?flag + NOTE_ATTRIB +modify-file+ ?flag + NOTE_RENAME +rename-file+ ?flag + NOTE_REVOKE +remove-file+ ?flag + drop + ] { } make prune ; + +:: kevent-vnode-task ( mx kevent fd -- ) + "" + kevent kevent-fflags parse-action + fd mx monitors>> at queue-change ; + : handle-kevent ( mx kevent -- ) - dup kevent-ident swap kevent-filter { + [ ] [ kevent-ident ] [ kevent-filter ] tri { { [ dup EVFILT_READ = ] [ drop kevent-read-task ] } { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] } - { [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] } + { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] } + { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] } } cond ; : handle-kevents ( mx n -- ) - [ over kqueue-mx-events kevent-nth handle-kevent ] with each ; + [ over events>> kevent-nth handle-kevent ] with each ; M: kqueue-mx wait-for-events ( ms mx -- ) swap dup [ make-timespec ] when dupd wait-kevent handle-kevents ; +! Procs : make-proc-kevent ( pid -- kevent ) "kevent" tuck set-kevent-ident @@ -77,5 +104,44 @@ M: kqueue-mx wait-for-events ( ms mx -- ) EVFILT_PROC over set-kevent-filter NOTE_EXIT over set-kevent-fflags ; -: add-pid-task ( pid mx -- ) +: register-pid-task ( pid mx -- ) swap make-proc-kevent swap register-kevent ; + +! VNodes +TUPLE: vnode-monitor < monitor fd ; + +: vnode-fflags ( -- n ) + { + NOTE_DELETE + NOTE_WRITE + NOTE_EXTEND + NOTE_ATTRIB + NOTE_LINK + NOTE_RENAME + NOTE_REVOKE + } flags ; + +: make-vnode-kevent ( fd flags -- kevent ) + "kevent" + tuck set-kevent-flags + tuck set-kevent-ident + EVFILT_VNODE over set-kevent-filter + vnode-fflags over set-kevent-fflags ; + +: register-monitor ( monitor mx -- ) + >r dup fd>> r> + [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ] + [ monitors>> set-at ] 3bi ; + +: unregister-monitor ( monitor mx -- ) + >r fd>> r> + [ monitors>> delete-at ] + [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ; + +: ( path mailbox -- monitor ) + >r [ O_RDONLY 0 open dup io-error ] keep r> + vnode-monitor construct-monitor swap >>fd + [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ; + +M: vnode-monitor dispose + [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ; diff --git a/extra/io/unix/linux/monitors/monitors.factor b/extra/io/unix/linux/monitors/monitors.factor index 5f23199146..a257873ed5 100644 --- a/extra/io/unix/linux/monitors/monitors.factor +++ b/extra/io/unix/linux/monitors/monitors.factor @@ -55,9 +55,6 @@ M: linux-monitor dispose ( monitor -- ) [ wd>> watches get delete-at ] [ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ; -: ?flag ( n mask symbol -- n ) - pick rot bitand 0 > [ , ] [ drop ] if ; - : ignore-flags? ( mask -- ? ) { IN_DELETE_SELF @@ -76,7 +73,7 @@ M: linux-monitor dispose ( monitor -- ) IN_MOVED_FROM +rename-file-old+ ?flag IN_MOVED_TO +rename-file-new+ ?flag drop - ] { } make ; + ] { } make prune ; : parse-file-notify ( buffer -- path changed ) dup inotify-event-mask ignore-flags? [ From 1f759a7b2d6377ae6227445fcb1e15dae9b4a768 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 10:09:45 -0500 Subject: [PATCH 055/146] Fix documentation --- extra/io/monitors/monitors-docs.factor | 6 ++---- extra/io/unix/bsd/bsd.factor | 3 ++- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/extra/io/monitors/monitors-docs.factor b/extra/io/monitors/monitors-docs.factor index df4f7ae352..cd6a06a8e9 100755 --- a/extra/io/monitors/monitors-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -69,15 +69,13 @@ $nl { $heading "Linux" } "Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later." $nl -"Since " { $snippet "inotify" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." +"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code." $nl "Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory." { $heading "BSD" } "Factor uses " { $snippet "kqueue" } " to implement monitors on BSD." $nl -"Since " { $snippet "kqueue" } " can only monitor a single directory, Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory. This is transparent to user code." -$nl -"Because " { $snippet "kqueue" } " requires that a file descriptor is allocated for each directory being monitored, monitoring of large directory hierarchies may exhaust file descriptors or exhibit suboptimal performance. Furthermore, unmounting a subdirectory of a recursively-monitored directory is not possible." +"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents." { $heading "Windows CE" } "Windows CE does not support monitors." ; diff --git a/extra/io/unix/bsd/bsd.factor b/extra/io/unix/bsd/bsd.factor index 03723a65e5..1b51b3c4e4 100755 --- a/extra/io/unix/bsd/bsd.factor +++ b/extra/io/unix/bsd/bsd.factor @@ -18,4 +18,5 @@ M: bsd init-monitors ; M: bsd dispose-monitors ; M: bsd (monitor) ( path recursive? mailbox -- ) - nip ; + swap [ "Recursive kqueue monitors not supported" throw ] when + ; From 8460780f61906a7d39df01df785741d7c0863f58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:18:39 -0500 Subject: [PATCH 056/146] Do a runloop so that monitors work in terminal --- extra/cocoa/application/application.factor | 9 +++--- extra/core-foundation/core-foundation.factor | 2 +- .../core-foundation/fsevents/fsevents.factor | 23 +++++++++----- .../core-foundation/run-loop/run-loop.factor | 30 +++++++++++++++++++ extra/io/monitors/monitors-tests.factor | 4 +-- 5 files changed, 52 insertions(+), 16 deletions(-) create mode 100644 extra/core-foundation/run-loop/run-loop.factor diff --git a/extra/cocoa/application/application.factor b/extra/cocoa/application/application.factor index 0cf020a087..129b949b1d 100755 --- a/extra/cocoa/application/application.factor +++ b/extra/cocoa/application/application.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien io kernel namespaces core-foundation cocoa.messages -cocoa cocoa.classes cocoa.runtime sequences threads -debugger init inspector kernel.private ; +USING: alien io kernel namespaces core-foundation +core-foundation.run-loop cocoa.messages cocoa cocoa.classes +cocoa.runtime sequences threads debugger init inspector +kernel.private ; IN: cocoa.application : ( str -- alien ) -> autorelease ; @@ -21,8 +22,6 @@ IN: cocoa.application : with-cocoa ( quot -- ) [ NSApp drop call ] with-autorelease-pool ; -: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; - : next-event ( app -- event ) 0 f CFRunLoopDefaultMode 1 -> nextEventMatchingMask:untilDate:inMode:dequeue: ; diff --git a/extra/core-foundation/core-foundation.factor b/extra/core-foundation/core-foundation.factor index 73b8fce229..5025ab39a7 100644 --- a/extra/core-foundation/core-foundation.factor +++ b/extra/core-foundation/core-foundation.factor @@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef TYPEDEF: void* CFStringRef TYPEDEF: void* CFURLRef TYPEDEF: void* CFUUIDRef -TYPEDEF: void* CFRunLoopRef TYPEDEF: bool Boolean TYPEDEF: int CFIndex +TYPEDEF: int SInt32 TYPEDEF: double CFTimeInterval TYPEDEF: double CFAbsoluteTime diff --git a/extra/core-foundation/fsevents/fsevents.factor b/extra/core-foundation/fsevents/fsevents.factor index f181d8a761..24211a59c7 100644 --- a/extra/core-foundation/fsevents/fsevents.factor +++ b/extra/core-foundation/fsevents/fsevents.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax kernel math sequences -namespaces assocs init continuations core-foundation ; +namespaces assocs init accessors continuations combinators +core-foundation core-foundation.run-loop ; IN: core-foundation.fsevents ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! @@ -182,11 +183,11 @@ SYMBOL: event-stream-callbacks } "cdecl" [ [ >event-triple ] 3curry map - swap event-stream-callbacks get at call - drop + swap event-stream-callbacks get at + dup [ call drop ] [ 3drop ] if ] alien-callback ; -TUPLE: event-stream info handle ; +TUPLE: event-stream info handle closed ; : ( quot paths latency flags -- event-stream ) >r >r >r @@ -194,9 +195,15 @@ TUPLE: event-stream info handle ; >r master-event-source-callback r> r> r> r> dup enable-event-stream - event-stream construct-boa ; + f event-stream construct-boa ; M: event-stream dispose - dup event-stream-info remove-event-source-callback - event-stream-handle dup disable-event-stream - FSEventStreamRelease ; + dup closed>> [ drop ] [ + t >>closed + { + [ info>> remove-event-source-callback ] + [ handle>> disable-event-stream ] + [ handle>> FSEventStreamInvalidate ] + [ handle>> FSEventStreamRelease ] + } cleave + ] if ; diff --git a/extra/core-foundation/run-loop/run-loop.factor b/extra/core-foundation/run-loop/run-loop.factor new file mode 100644 index 0000000000..7cd148e022 --- /dev/null +++ b/extra/core-foundation/run-loop/run-loop.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2008 Slava Pestov +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax kernel threads init +cocoa.application core-foundation ; +IN: core-foundation.run-loop + +: kCFRunLoopRunFinished 1 ; inline +: kCFRunLoopRunStopped 2 ; inline +: kCFRunLoopRunTimedOut 3 ; inline +: kCFRunLoopRunHandledSource 4 ; inline + +TYPEDEF: void* CFRunLoopRef + +FUNCTION: SInt32 CFRunLoopRunInMode ( + CFStringRef mode, + CFTimeInterval seconds, + Boolean returnAfterSourceHandled +) ; + +: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" ; + +: run-loop-thread ( -- ) + CFRunLoopDefaultMode 0 f CFRunLoopRunInMode + kCFRunLoopRunHandledSource = [ 1000 sleep ] unless + run-loop-thread ; + +: start-run-loop-thread ( -- ) + [ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ; + +[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor index 0216baf699..ab919dd008 100644 --- a/extra/io/monitors/monitors-tests.factor +++ b/extra/io/monitors/monitors-tests.factor @@ -75,13 +75,13 @@ os { winnt linux macosx } member? [ [ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test - [ ] [ "c1" get 5 seconds await-timeout ] unit-test + [ ] [ "c1" get 15 seconds await-timeout ] unit-test [ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test [ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test - [ ] [ "c2" get 5 seconds await-timeout ] unit-test + [ ] [ "c2" get 15 seconds await-timeout ] unit-test ! Dispose twice [ ] [ "m" get dispose ] unit-test From c5de8189259991d11bbec37bce6be5882784e7ae Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 11 Apr 2008 12:47:49 -0500 Subject: [PATCH 057/146] Use inheritance in Unix I?O backend --- extra/io/unix/backend/backend.factor | 32 ++++++++++++---------------- extra/io/unix/epoll/epoll.factor | 8 +++---- extra/io/unix/kqueue/kqueue.factor | 12 ++++++----- extra/io/unix/select/select.factor | 6 +++--- extra/io/unix/sockets/sockets.factor | 16 +++++++------- 5 files changed, 35 insertions(+), 39 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 0fb8b0c5f2..d42f8827b1 100644 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ; : io-task-fd port>> handle>> ; : ( port continuation/f class -- task ) - >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa - r> construct-delegate ; inline + construct-empty + swap [ 1vector ] [ V{ } clone ] if* >>callbacks + swap >>port ; inline -TUPLE: input-task ; +TUPLE: input-task < io-task ; -: ( port continuation class -- task ) - >r input-task r> construct-delegate ; inline - -TUPLE: output-task ; - -: ( port continuation class -- task ) - >r output-task r> construct-delegate ; inline +TUPLE: output-task < io-task ; GENERIC: do-io-task ( task -- ? ) GENERIC: io-task-container ( mx task -- hashtable ) @@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ; M: output-task io-task-container drop writes>> ; -: ( -- mx ) f H{ } clone H{ } clone mx construct-boa ; - -: construct-mx ( class -- obj ) swap construct-delegate ; +: construct-mx ( class -- obj ) + construct-empty + H{ } clone >>reads + H{ } clone >>writes ; inline GENERIC: register-io-task ( task mx -- ) GENERIC: unregister-io-task ( task mx -- ) @@ -140,10 +136,10 @@ M: unix cancel-io ( port -- ) drop t ] if ; -TUPLE: read-task ; +TUPLE: read-task < input-task ; : ( port continuation -- task ) - read-task ; + read-task ; M: read-task do-io-task io-task-port dup refill @@ -158,10 +154,10 @@ M: input-port (wait-to-read) dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ; -TUPLE: write-task ; +TUPLE: write-task < output-task ; : ( port continuation -- task ) - write-task ; + write-task ; M: write-task do-io-task io-task-port dup [ buffer-empty? ] [ port-error ] bi or @@ -193,7 +189,7 @@ TUPLE: mx-port mx ; dup fd>> f mx-port { set-mx-port-mx set-delegate } mx-port construct ; -TUPLE: mx-task ; +TUPLE: mx-task < io-task ; : ( port -- task ) f mx-task ; diff --git a/extra/io/unix/epoll/epoll.factor b/extra/io/unix/epoll/epoll.factor index 1459549f9e..2d7ca9ba3f 100644 --- a/extra/io/unix/epoll/epoll.factor +++ b/extra/io/unix/epoll/epoll.factor @@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math namespaces structs ; IN: io.unix.epoll -TUPLE: epoll-mx events ; +TUPLE: epoll-mx < mx events ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ; epoll_ctl io-error ; M: epoll-mx register-io-task ( task mx -- ) - 2dup EPOLL_CTL_ADD do-epoll-ctl - delegate register-io-task ; + [ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ; M: epoll-mx unregister-io-task ( task mx -- ) - 2dup delegate unregister-io-task - EPOLL_CTL_DEL do-epoll-ctl ; + [ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ; : wait-event ( mx timeout -- n ) >r { mx-fd epoll-mx-events } get-slots max-events diff --git a/extra/io/unix/kqueue/kqueue.factor b/extra/io/unix/kqueue/kqueue.factor index 3735caa7d2..3a140bdbec 100644 --- a/extra/io/unix/kqueue/kqueue.factor +++ b/extra/io/unix/kqueue/kqueue.factor @@ -8,7 +8,7 @@ io.nonblocking io.unix.backend io.launcher io.unix.launcher io.monitors ; IN: io.unix.kqueue -TUPLE: kqueue-mx events monitors ; +TUPLE: kqueue-mx < mx events monitors ; : max-events ( -- n ) #! We read up to 256 events at a time. This is an arbitrary @@ -43,12 +43,14 @@ M: io-task io-task-fflags drop 0 ; 0 < [ err_no ESRCH = [ (io-error) ] unless ] when ; M: kqueue-mx register-io-task ( task mx -- ) - over EV_ADD make-kevent over register-kevent - delegate register-io-task ; + [ >r EV_ADD make-kevent r> register-kevent ] + [ call-next-method ] + 2bi ; M: kqueue-mx unregister-io-task ( task mx -- ) - 2dup delegate unregister-io-task - swap EV_DELETE make-kevent swap register-kevent ; + [ call-next-method ] + [ >r EV_DELETE make-kevent r> register-kevent ] + 2bi ; : wait-kevent ( mx timespec -- n ) >r [ fd>> f 0 ] keep events>> max-events r> kevent diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor index 6527a87010..facaf4d73d 100755 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -5,7 +5,7 @@ bit-arrays sequences assocs unix math namespaces structs accessors ; IN: io.unix.select -TUPLE: select-mx read-fdset write-fdset ; +TUPLE: select-mx < mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for @@ -15,8 +15,8 @@ TUPLE: select-mx read-fdset write-fdset ; : ( -- mx ) select-mx construct-mx - FD_SETSIZE 8 * >>read-fdset - FD_SETSIZE 8 * >>write-fdset ; + FD_SETSIZE 8 * >>read-fdset + FD_SETSIZE 8 * >>write-fdset ; : clear-nth ( n seq -- ? ) [ nth ] [ f -rot set-nth ] 2bi ; diff --git a/extra/io/unix/sockets/sockets.factor b/extra/io/unix/sockets/sockets.factor index a54205a878..9ad1338b96 100755 --- a/extra/io/unix/sockets/sockets.factor +++ b/extra/io/unix/sockets/sockets.factor @@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- ) : init-client-socket ( fd -- ) SOL_SOCKET SO_OOBINLINE sockopt ; -TUPLE: connect-task ; +TUPLE: connect-task < output-task ; : ( port continuation -- task ) - connect-task ; + connect-task ; M: connect-task do-io-task io-task-port dup port-handle f 0 write @@ -61,10 +61,10 @@ USE: unix : init-server-socket ( fd -- ) SOL_SOCKET SO_REUSEADDR sockopt ; -TUPLE: accept-task ; +TUPLE: accept-task < input-task ; : ( port continuation -- task ) - accept-task ; + accept-task ; : accept-sockaddr ( port -- fd sockaddr ) dup port-handle swap server-port-addr sockaddr-type @@ -128,10 +128,10 @@ packet-size receive-buffer set-global rot head ] if ; -TUPLE: receive-task ; +TUPLE: receive-task < input-task ; : ( stream continuation -- task ) - receive-task ; + receive-task ; M: receive-task do-io-task io-task-port @@ -157,10 +157,10 @@ M: unix receive ( datagram -- packet addrspec ) : do-send ( socket data sockaddr len -- n ) >r >r dup length 0 r> r> sendto ; -TUPLE: send-task packet sockaddr len ; +TUPLE: send-task < output-task packet sockaddr len ; : ( packet sockaddr len stream continuation -- task ) - send-task [ + send-task [ { set-send-task-packet set-send-task-sockaddr From ce57aca4f541b9236e2aad46af8ca7eb235d9e08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:51:50 -0500 Subject: [PATCH 058/146] case now executes its keys if they are words cond now accepts a default quotation --- core/combinators/combinators-docs.factor | 10 +- core/combinators/combinators-tests.factor | 232 +++++++++++++++++++++- core/combinators/combinators.factor | 30 ++- 3 files changed, 254 insertions(+), 18 deletions(-) diff --git a/core/combinators/combinators-docs.factor b/core/combinators/combinators-docs.factor index f497fd20e5..54c62c44fa 100755 --- a/core/combinators/combinators-docs.factor +++ b/core/combinators/combinators-docs.factor @@ -64,9 +64,9 @@ HELP: alist>quot { $notes "This word is used to implement compile-time behavior for " { $link cond } ", and it is also used by the generic word system. Note that unlike " { $link cond } ", the constructed quotation performs the tests starting from the end and not the beginning." } ; HELP: cond -{ $values { "assoc" "a sequence of quotation pairs" } } +{ $values { "assoc" "a sequence of quotation pairs and an optional quotation" } } { $description - "Calls the second quotation in the first pair whose first quotation yields a true value." + "Calls the second quotation in the first pair whose first quotation yields a true value. A single quotation will always yield a true value." $nl "The following two phrases are equivalent:" { $code "{ { [ X ] [ Y ] } { [ Z ] [ T ] } } cond" } @@ -78,7 +78,7 @@ HELP: cond "{" " { [ dup 0 > ] [ \"positive\" ] }" " { [ dup 0 < ] [ \"negative\" ] }" - " { [ dup zero? ] [ \"zero\" ] }" + " [ \"zero\" ]" "} cond" } } ; @@ -88,9 +88,9 @@ HELP: no-cond { $error-description "Thrown by " { $link cond } " if none of the test quotations yield a true value. Some uses of " { $link cond } " include a default case where the test quotation is " { $snippet "[ t ]" } "; such a " { $link cond } " form will never throw this error." } ; HELP: case -{ $values { "obj" object } { "assoc" "a sequence of object/quotation pairs, with an optional quotation at the end" } } +{ $values { "obj" object } { "assoc" "a sequence of object/word,quotation pairs, with an optional quotation at the end" } } { $description - "Compares " { $snippet "obj" } " against the first element of every pair. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." + "Compares " { $snippet "obj" } " against the first element of every pair, first evaluating the first element if it is a word. If some pair matches, removes " { $snippet "obj" } " from the stack and calls the second element of that pair, which must be a quotation." $nl "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied." $nl diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 8abc53e43f..b612669b71 100755 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -1,7 +1,54 @@ -IN: combinators.tests USING: alien strings kernel math tools.test io prettyprint -namespaces combinators words ; +namespaces combinators words classes sequences ; +IN: combinators.tests +! Compiled +: cond-test-1 ( obj -- str ) + { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond ; + +\ cond-test-1 must-infer + +[ "even" ] [ 2 cond-test-1 ] unit-test +[ "odd" ] [ 3 cond-test-1 ] unit-test + +: cond-test-2 ( obj -- str ) + { + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + [ drop "something else" ] + } cond ; + +\ cond-test-2 must-infer + +[ "true" ] [ t cond-test-2 ] unit-test +[ "false" ] [ f cond-test-2 ] unit-test +[ "something else" ] [ "ohio" cond-test-2 ] unit-test + +: cond-test-3 ( obj -- str ) + { + [ drop "something else" ] + { [ dup t = ] [ drop "true" ] } + { [ dup f = ] [ drop "false" ] } + } cond ; + +\ cond-test-3 must-infer + +[ "something else" ] [ t cond-test-3 ] unit-test +[ "something else" ] [ f cond-test-3 ] unit-test +[ "something else" ] [ "ohio" cond-test-3 ] unit-test + +: cond-test-4 ( -- ) + { + } cond ; + +\ cond-test-4 must-infer + +[ cond-test-4 ] [ class \ no-cond = ] must-fail-with + +! Interpreted [ "even" ] [ 2 { { [ dup 2 mod 0 = ] [ drop "even" ] } @@ -21,11 +68,66 @@ namespaces combinators words ; { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] unit-test -: case-test-1 +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "neither" ] [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + [ drop "neither" ] + } cond +] unit-test + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +[ "early" ] [ + 2 { + { [ dup 2 mod 1 = ] [ drop "odd" ] } + [ drop "early" ] + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ "really early" ] [ + 2 { + [ drop "really early" ] + { [ dup 2 mod 1 = ] [ drop "odd" ] } + { [ dup 2 mod 0 = ] [ drop "even" ] } + } cond +] unit-test + +[ { } cond ] [ class \ no-cond = ] must-fail-with + +! Compiled +: case-test-1 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -33,6 +135,8 @@ namespaces combinators words ; { 4 [ "four" ] } } case ; +\ case-test-1 must-infer + [ "two" ] [ 2 case-test-1 ] unit-test ! Interpreted @@ -40,7 +144,7 @@ namespaces combinators words ; [ "x" case-test-1 ] must-fail -: case-test-2 +: case-test-2 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -49,12 +153,14 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-2 must-infer + [ 25 ] [ 5 case-test-2 ] unit-test ! Interpreted [ 25 ] [ 5 \ case-test-2 word-def call ] unit-test -: case-test-3 +: case-test-3 ( obj -- obj' ) { { 1 [ "one" ] } { 2 [ "two" ] } @@ -65,8 +171,122 @@ namespaces combinators words ; [ sq ] } case ; +\ case-test-3 must-infer + [ "an array" ] [ { 1 2 3 } case-test-3 ] unit-test +: case-const-1 1 ; +: case-const-2 2 ; inline + +! Compiled +: case-test-4 ( obj -- str ) + { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case ; + +\ case-test-4 must-infer + +[ "uno" ] [ 1 case-test-4 ] unit-test +[ "dos" ] [ 2 case-test-4 ] unit-test +[ "tres" ] [ 3 case-test-4 ] unit-test +[ "demasiado" ] [ 100 case-test-4 ] unit-test + +: case-test-5 ( obj -- ) + { + { case-const-1 [ "uno" print ] } + { case-const-2 [ "dos" print ] } + { 3 [ "tres" print ] } + { 4 [ "cuatro" print ] } + { 5 [ "cinco" print ] } + [ drop "demasiado" print ] + } case ; + +\ case-test-5 must-infer + +[ ] [ 1 case-test-5 ] unit-test + +! Interpreted +[ "uno" ] [ + 1 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "dos" ] [ + 2 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "tres" ] [ + 3 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +[ "demasiado" ] [ + 100 { + { case-const-1 [ "uno" ] } + { case-const-2 [ "dos" ] } + { 3 [ "tres" ] } + { 4 [ "cuatro" ] } + { 5 [ "cinco" ] } + [ drop "demasiado" ] + } case +] unit-test + +: do-not-call "do not call" throw ; + +: test-case-6 + { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case ; + +[ "three" ] [ 3 test-case-6 ] unit-test +[ "do-not-call" ] [ \ do-not-call test-case-6 ] unit-test + +[ "three" ] [ + 3 { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + [ do-not-call ] first { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + +[ "do-not-call" ] [ + \ do-not-call { + { \ do-not-call [ "do-not-call" ] } + { 3 [ "three" ] } + } case +] unit-test + ! Interpreted [ "a hashtable" ] [ H{ } \ case-test-3 word-def call ] unit-test diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 96c4009ba9..11ad8d60e7 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -3,7 +3,7 @@ IN: combinators USING: arrays sequences sequences.private math.private kernel kernel.private math assocs quotations vectors -hashtables sorting ; +hashtables sorting words ; : cleave ( x seq -- ) [ call ] with each ; @@ -34,13 +34,24 @@ hashtables sorting ; ERROR: no-cond ; : cond ( assoc -- ) - [ first call ] find nip dup [ second call ] [ no-cond ] if ; + [ dup callable? [ drop t ] [ first call ] if ] find nip + [ dup callable? [ call ] [ second call ] if ] + [ no-cond ] if* ; ERROR: no-case ; +: case-find ( obj assoc -- obj' ) + [ + dup array? [ + dupd first dup word? [ + execute + ] [ + dup wrapper? [ wrapped ] when + ] if = + ] [ quotation? ] if + ] find nip ; : case ( obj assoc -- ) - [ dup array? [ dupd first = ] [ quotation? ] if ] find nip - { + case-find { { [ dup array? ] [ nip second call ] } { [ dup quotation? ] [ call ] } { [ dup not ] [ no-case ] } @@ -73,11 +84,14 @@ M: hashtable hashcode* [ rot \ if 3array append [ ] like ] assoc-each ; : cond>quot ( assoc -- quot ) + [ dup callable? [ [ t ] swap 2array ] when ] map reverse [ no-cond ] swap alist>quot ; : linear-case-quot ( default assoc -- quot ) - [ >r [ dupd = ] curry r> \ drop prefix ] assoc-map - alist>quot ; + [ + [ 1quotation \ dup prefix \ = suffix ] + [ \ drop prefix ] bi* + ] assoc-map alist>quot ; : (distribute-buckets) ( buckets pair keys -- ) dup t eq? [ @@ -135,7 +149,9 @@ M: hashtable hashcode* dup empty? [ drop ] [ - dup length 4 <= [ + dup length 4 <= + over keys [ word? ] contains? or + [ linear-case-quot ] [ dup keys contiguous-range? [ From 9348b9b8a7d09d6fa0120e6f5367d5fe59491fc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:52:56 -0500 Subject: [PATCH 059/146] gensyms don't output a number in the name now --- core/words/words.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/core/words/words.factor b/core/words/words.factor index 7794a7f41f..e1d2f11356 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -2,8 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs -quotations assocs hashtables sorting math.parser words.private -vocabs combinators ; +quotations assocs hashtables sorting words.private vocabs ; IN: words : word ( -- word ) \ word get-global ; @@ -66,11 +65,11 @@ SYMBOL: bootstrapping? GENERIC: crossref? ( word -- ? ) M: word crossref? - { - { [ dup "forgotten" word-prop ] [ f ] } - { [ dup word-vocabulary ] [ t ] } - { [ t ] [ f ] } - } cond nip ; + dup "forgotten" word-prop [ + drop f + ] [ + word-vocabulary >boolean + ] if ; GENERIC# (quot-uses) 1 ( obj assoc -- ) @@ -191,7 +190,7 @@ M: word subwords drop f ; { "methods" "combination" "default-method" } reset-props ; : gensym ( -- word ) - "G:" \ gensym counter number>string append f ; + "( gensym )" f ; : define-temp ( quot -- word ) gensym dup rot define ; From bced4022e59438846e7c362d445884e895a7bc46 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:53:22 -0500 Subject: [PATCH 060/146] updating usages of cond/case --- core/alien/alien-docs.factor | 2 +- core/alien/compiler/compiler.factor | 4 +-- core/alien/syntax/syntax.factor | 2 +- core/classes/algebra/algebra.factor | 14 +++++----- core/classes/mixin/mixin.factor | 2 +- core/compiler/tests/simple.factor | 4 +-- core/cpu/x86/32/32.factor | 3 +-- core/cpu/x86/assembler/assembler.factor | 2 +- core/debugger/debugger.factor | 2 +- core/dlists/dlists.factor | 2 +- core/effects/effects.factor | 2 +- core/generator/fixup/fixup.factor | 4 +-- core/generator/generator.factor | 2 +- core/generator/registers/registers.factor | 6 ++--- core/generic/math/math.factor | 2 +- .../engines/predicate/predicate.factor | 2 +- core/inference/backend/backend.factor | 4 +-- core/io/encodings/utf8/utf8.factor | 6 ++--- core/io/files/files.factor | 27 ++++++++++--------- core/math/intervals/intervals.factor | 6 ++--- core/math/parser/parser.factor | 10 +++---- core/optimizer/control/control-tests.factor | 14 +++++----- core/optimizer/control/control.factor | 2 +- core/optimizer/inlining/inlining.factor | 8 +++--- .../pattern-match/pattern-match.factor | 2 +- .../specializers/specializers.factor | 2 +- core/parser/parser.factor | 2 +- core/prettyprint/prettyprint.factor | 2 +- core/syntax/syntax.factor | 2 +- core/threads/threads.factor | 2 +- 30 files changed, 71 insertions(+), 73 deletions(-) diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor index 136af91bb2..7d13080e3c 100755 --- a/core/alien/alien-docs.factor +++ b/core/alien/alien-docs.factor @@ -78,7 +78,7 @@ $nl "<< \"freetype\" {" " { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }" " { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }" - " { [ t ] [ drop ] }" + " [ drop ]" "} cond >>" } "Note the parse time evaluation with " { $link POSTPONE: << } "." } ; diff --git a/core/alien/compiler/compiler.factor b/core/alien/compiler/compiler.factor index 0f74f52d60..594c42268c 100755 --- a/core/alien/compiler/compiler.factor +++ b/core/alien/compiler/compiler.factor @@ -375,7 +375,7 @@ TUPLE: callback-context ; return>> { { [ dup "void" = ] [ drop [ ] ] } { [ dup large-struct? ] [ heap-size [ memcpy ] curry ] } - { [ t ] [ c-type c-type-prep ] } + [ c-type c-type-prep ] } cond ; : wrap-callback-quot ( node -- quot ) @@ -390,7 +390,7 @@ TUPLE: callback-context ; { { [ dup abi>> "stdcall" = ] [ alien-stack-frame ] } { [ dup return>> large-struct? ] [ drop 4 ] } - { [ t ] [ drop 0 ] } + [ drop 0 ] } cond ; : %callback-return ( node -- ) diff --git a/core/alien/syntax/syntax.factor b/core/alien/syntax/syntax.factor index 6e4b8b4e21..67ea30f379 100755 --- a/core/alien/syntax/syntax.factor +++ b/core/alien/syntax/syntax.factor @@ -68,7 +68,7 @@ M: alien pprint* { { [ dup expired? ] [ drop "( alien expired )" text ] } { [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] } - { [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } + [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] } cond ; M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 4614e4c4ce..faf57fcd0d 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -84,7 +84,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup members ] [ right-union-class< ] } { [ over superclass ] [ superclass< ] } - { [ t ] [ 2drop f ] } + [ 2drop f ] } cond ; : anonymous-union-intersect? ( first second -- ? ) @@ -104,14 +104,14 @@ C: anonymous-complement { [ over tuple eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } { [ over tuple-class? ] [ [ class< ] [ swap class< ] 2bi or ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : builtin-class-intersect? ( first second -- ? ) { { [ 2dup eq? ] [ 2drop t ] } { [ over builtin-class? ] [ 2drop f ] } - { [ t ] [ swap classes-intersect? ] } + [ swap classes-intersect? ] } cond ; : (classes-intersect?) ( first second -- ? ) @@ -154,7 +154,7 @@ C: anonymous-complement { [ over members ] [ left-union-and ] } { [ over anonymous-union? ] [ left-anonymous-union-and ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection-and ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : left-anonymous-union-or ( first second -- class ) @@ -169,7 +169,7 @@ C: anonymous-complement { [ 2dup swap class< ] [ drop ] } { [ dup anonymous-union? ] [ right-anonymous-union-or ] } { [ over anonymous-union? ] [ left-anonymous-union-or ] } - { [ t ] [ 2array ] } + [ 2array ] } cond ; : (class-not) ( class -- complement ) @@ -177,7 +177,7 @@ C: anonymous-complement { [ dup anonymous-complement? ] [ class>> ] } { [ dup object eq? ] [ drop null ] } { [ dup null eq? ] [ drop object ] } - { [ t ] [ ] } + [ ] } cond ; : largest-class ( seq -- n elt ) @@ -205,7 +205,7 @@ C: anonymous-complement { [ dup builtin-class? ] [ dup set ] } { [ dup members ] [ members [ (flatten-class) ] each ] } { [ dup superclass ] [ superclass (flatten-class) ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : flatten-class ( class -- assoc ) diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index aefd522269..9bbe89d7d9 100755 --- a/core/classes/mixin/mixin.factor +++ b/core/classes/mixin/mixin.factor @@ -49,7 +49,7 @@ M: mixin-instance equal? { [ over mixin-instance? not ] [ f ] } { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] } { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; M: mixin-instance hashcode* diff --git a/core/compiler/tests/simple.factor b/core/compiler/tests/simple.factor index 09b0c190e6..dce2ec562a 100755 --- a/core/compiler/tests/simple.factor +++ b/core/compiler/tests/simple.factor @@ -187,7 +187,7 @@ DEFER: countdown-b { [ dup string? ] [ drop "string" ] } { [ dup float? ] [ drop "float" ] } { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } + [ drop "neither" ] } cond ] compile-call ] unit-test @@ -196,7 +196,7 @@ DEFER: countdown-b [ 3 { { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } + [ drop t ] } cond ] compile-call ] unit-test diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index 699670aecd..cc3fceff23 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -246,9 +246,8 @@ M: x86.32 %cleanup ( alien-node -- ) } { [ dup return>> large-struct? ] [ drop EAX PUSH ] - } { - [ t ] [ drop ] } + [ drop ] } cond ; M: x86.32 %unwind ( n -- ) %epilogue-later RET ; diff --git a/core/cpu/x86/assembler/assembler.factor b/core/cpu/x86/assembler/assembler.factor index a3ab256ea1..450aa8f980 100755 --- a/core/cpu/x86/assembler/assembler.factor +++ b/core/cpu/x86/assembler/assembler.factor @@ -189,7 +189,7 @@ UNION: operand register indirect ; { { [ dup register-128? ] [ drop operand-64? ] } { [ dup not ] [ drop operand-64? ] } - { [ t ] [ nip operand-64? ] } + [ nip operand-64? ] } cond and ; : rex.r diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 071535a01e..dea1904e92 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -160,7 +160,7 @@ PREDICATE: kernel-error < array { { [ dup empty? ] [ drop f ] } { [ dup first "kernel-error" = not ] [ drop f ] } - { [ t ] [ second 0 15 between? ] } + [ second 0 15 between? ] } cond ; : kernel-errors diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index 56134f3b54..b4ae207455 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -126,7 +126,7 @@ PRIVATE> { { [ over front>> over eq? ] [ drop pop-front* ] } { [ over back>> over eq? ] [ drop pop-back* ] } - { [ t ] [ unlink-node dec-length ] } + [ unlink-node dec-length ] } cond ; : delete-node-if* ( dlist quot -- obj/f ? ) diff --git a/core/effects/effects.factor b/core/effects/effects.factor index aed4a64c6c..7da290992c 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -20,7 +20,7 @@ TUPLE: effect in out terminated? ; { [ dup effect-terminated? ] [ f ] } { [ 2dup [ effect-in length ] bi@ > ] [ f ] } { [ 2dup [ effect-height ] bi@ = not ] [ f ] } - { [ t ] [ t ] } + [ t ] } cond 2nip ; GENERIC: (stack-picture) ( obj -- str ) diff --git a/core/generator/fixup/fixup.factor b/core/generator/fixup/fixup.factor index 5cc0442464..3a5a6571b7 100755 --- a/core/generator/fixup/fixup.factor +++ b/core/generator/fixup/fixup.factor @@ -40,8 +40,8 @@ M: label fixup* M: word fixup* { - { %prologue-later [ dup [ %prologue ] if-stack-frame ] } - { %epilogue-later [ dup [ %epilogue ] if-stack-frame ] } + { \ %prologue-later [ dup [ %prologue ] if-stack-frame ] } + { \ %epilogue-later [ dup [ %epilogue ] if-stack-frame ] } } case ; SYMBOL: relocation-table diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3514947e3d..7858205384 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -16,7 +16,7 @@ SYMBOL: compiled { [ dup compiled get key? ] [ drop ] } { [ dup inlined-block? ] [ drop ] } { [ dup primitive? ] [ drop ] } - { [ t ] [ dup compile-queue get set-at ] } + [ dup compile-queue get set-at ] } cond ; : maybe-compile ( word -- ) diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index f3dc0fb10e..8abd1cd3e0 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -195,7 +195,7 @@ INSTANCE: constant value { [ dup byte-array class< ] [ drop %unbox-byte-array ] } { [ dup bit-array class< ] [ drop %unbox-byte-array ] } { [ dup float-array class< ] [ drop %unbox-byte-array ] } - { [ t ] [ drop %unbox-any-c-ptr ] } + [ drop %unbox-any-c-ptr ] } cond ; inline : %move-via-temp ( dst src -- ) @@ -357,14 +357,14 @@ SYMBOL: fresh-objects { [ dup unboxed-c-ptr eq? ] [ over { unboxed-byte-array unboxed-alien } member? ] } - { [ t ] [ f ] } + [ f ] } cond 2nip ; : allocation ( value spec -- reg-class ) { { [ dup quotation? ] [ 2drop f ] } { [ 2dup compatible? ] [ 2drop f ] } - { [ t ] [ nip reg-spec>class ] } + [ nip reg-spec>class ] } cond ; : alloc-vreg-for ( value spec -- vreg ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index fce908bdef..884ab8027e 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -19,7 +19,7 @@ PREDICATE: math-class < class { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } - { [ t ] [ drop { 100 100 } ] } + [ drop { 100 100 } ] } cond ; : math-class-max ( class class -- class ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index ce7d5c6c21..5335074dea 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -18,7 +18,7 @@ C: predicate-dispatch-engine { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } { [ dup length 1 = ] [ first second { } ] } { [ dup keep-going? ] [ 1 tail-slice prune-redundant-predicates ] } - { [ t ] [ [ first second ] [ 1 tail-slice ] bi ] } + [ [ first second ] [ 1 tail-slice ] bi ] } cond ; : sort-methods ( assoc -- assoc' ) diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 3dcb1d2360..1945ed1a38 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -251,7 +251,7 @@ TUPLE: cannot-unify-specials ; { [ dup [ curried? ] all? ] [ unify-curries ] } { [ dup [ composed? ] all? ] [ unify-composed ] } { [ dup [ special? ] contains? ] [ cannot-unify-specials ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : unify-stacks ( seq -- stack ) @@ -395,7 +395,7 @@ TUPLE: effect-error word effect ; { [ dup "infer" word-prop ] [ custom-infer ] } { [ dup "no-effect" word-prop ] [ no-effect ] } { [ dup "inferred-effect" word-prop ] [ cached-infer ] } - { [ t ] [ dup infer-word make-call-node ] } + [ dup infer-word make-call-node ] } cond ; TUPLE: recursive-declare-error word ; diff --git a/core/io/encodings/utf8/utf8.factor b/core/io/encodings/utf8/utf8.factor index e98860f25d..7a22107f19 100644 --- a/core/io/encodings/utf8/utf8.factor +++ b/core/io/encodings/utf8/utf8.factor @@ -33,7 +33,7 @@ TUPLE: utf8 ; { [ dup -5 shift BIN: 110 number= ] [ double ] } { [ dup -4 shift BIN: 1110 number= ] [ triple ] } { [ dup -3 shift BIN: 11110 number= ] [ quad ] } - { [ t ] [ drop replacement-char ] } + [ drop replacement-char ] } cond ; : decode-utf8 ( stream -- char/f ) @@ -59,12 +59,12 @@ M: utf8 decode-char 2dup -6 shift encoded encoded ] } - { [ t ] [ + [ 2dup -18 shift BIN: 11110000 bitor swap stream-write1 2dup -12 shift encoded 2dup -6 shift encoded encoded - ] } + ] } cond ; M: utf8 encode-char diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6719d1334c..061e6386da 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -95,7 +95,7 @@ ERROR: no-parent-directory path ; 1 tail left-trim-separators append-path-empty ] } { [ dup head..? ] [ drop no-parent-directory ] } - { [ t ] [ nip ] } + [ nip ] } cond ; PRIVATE> @@ -105,7 +105,7 @@ PRIVATE> { [ dup "\\\\?\\" head? ] [ t ] } { [ dup length 2 < ] [ f ] } { [ dup second CHAR: : = ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond ; : absolute-path? ( path -- ? ) @@ -114,7 +114,7 @@ PRIVATE> { [ dup "resource:" head? ] [ t ] } { [ os windows? ] [ windows-absolute-path? ] } { [ dup first path-separator? ] [ t ] } - { [ t ] [ f ] } + [ f ] } cond nip ; : append-path ( str1 str2 -- str ) @@ -130,10 +130,10 @@ PRIVATE> { [ over absolute-path? over first path-separator? and ] [ >r 2 head r> append ] } - { [ t ] [ + [ >r right-trim-separators "/" r> left-trim-separators 3append - ] } + ] } cond ; : prepend-path ( str1 str2 -- str ) @@ -220,10 +220,10 @@ HOOK: make-directory io-backend ( path -- ) { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } { [ dup exists? ] [ ] } - { [ t ] [ + [ dup parent-directory make-directories dup make-directory - ] } + ] } cond drop ; ! Directory listings @@ -322,9 +322,10 @@ C: pathname M: pathname <=> [ pathname-string ] compare ; ! Home directory -: home ( -- dir ) - { - { [ os winnt? ] [ "USERPROFILE" os-env ] } - { [ os wince? ] [ "" resource-path ] } - { [ os unix? ] [ "HOME" os-env ] } - } cond ; +HOOK: home os ( -- dir ) + +M: winnt home "USERPROFILE" os-env ; + +M: wince home "" resource-path ; + +M: unix home "HOME" os-env ; diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index cc51060f63..4ca1a8637c 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -103,7 +103,7 @@ C: interval 2drop over second over second and [ ] [ 2drop f ] if ] } - { [ t ] [ 2drop ] } + [ 2drop ] } cond ; : interval-intersect ( i1 i2 -- i3 ) @@ -202,7 +202,7 @@ SYMBOL: incomparable { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup left-endpoint-< ] [ f ] } { [ 2dup right-endpoint-< ] [ f ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : left-endpoint-<= ( i1 i2 -- ? ) @@ -215,7 +215,7 @@ SYMBOL: incomparable { { [ 2dup interval-intersect not ] [ (interval<) ] } { [ 2dup right-endpoint-<= ] [ t ] } - { [ t ] [ incomparable ] } + [ incomparable ] } cond 2nip ; : interval> ( i1 i2 -- ? ) diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 68c4768c87..1a1a080564 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -62,7 +62,7 @@ SYMBOL: negative? { { [ dup empty? ] [ drop f ] } { [ f over memq? ] [ drop f ] } - { [ t ] [ radix get [ < ] curry all? ] } + [ radix get [ < ] curry all? ] } cond ; : string>integer ( str -- n/f ) @@ -77,7 +77,7 @@ PRIVATE> { { [ CHAR: / over member? ] [ string>ratio ] } { [ CHAR: . over member? ] [ string>float ] } - { [ t ] [ string>integer ] } + [ string>integer ] } cond r> [ dup [ neg ] when ] when ] with-radix ; @@ -134,10 +134,8 @@ M: ratio >base } { [ CHAR: . over member? ] [ ] - } { - [ t ] - [ ".0" append ] } + [ ".0" append ] } cond ; M: float >base @@ -145,7 +143,7 @@ M: float >base { [ dup 1.0/0.0 = ] [ drop "1.0/0.0" ] } { [ dup -1.0/0.0 = ] [ drop "-1.0/0.0" ] } { [ dup fp-nan? ] [ drop "0.0/0.0" ] } - { [ t ] [ float>string fix-float ] } + [ float>string fix-float ] } cond ; : number>string ( n -- str ) 10 >base ; diff --git a/core/optimizer/control/control-tests.factor b/core/optimizer/control/control-tests.factor index d7638fa66d..ce77cdd43a 100755 --- a/core/optimizer/control/control-tests.factor +++ b/core/optimizer/control/control-tests.factor @@ -9,23 +9,23 @@ optimizer ; { [ over #label? not ] [ 2drop f ] } { [ over #label-word over eq? not ] [ 2drop f ] } { [ over #label-loop? not ] [ 2drop f ] } - { [ t ] [ 2drop t ] } + [ 2drop t ] } cond ] curry node-exists? ; : label-is-not-loop? ( node word -- ? ) [ { - { [ over #label? not ] [ 2drop f ] } - { [ over #label-word over eq? not ] [ 2drop f ] } - { [ over #label-loop? ] [ 2drop f ] } - { [ t ] [ 2drop t ] } - } cond + { [ over #label? not ] [ f ] } + { [ over #label-word over eq? not ] [ f ] } + { [ over #label-loop? ] [ f ] } + [ t ] + } cond 2nip ] curry node-exists? ; : loop-test-1 ( a -- ) dup [ 1+ loop-test-1 ] [ drop ] if ; inline - + [ t ] [ [ loop-test-1 ] dataflow dup detect-loops \ loop-test-1 label-is-loop? diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index 11228c879a..f9f8901c41 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -156,7 +156,7 @@ SYMBOL: potential-loops { [ dup null class< ] [ drop f f ] } { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } - { [ t ] [ drop f f ] } + [ drop f f ] } cond ] if ; diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9d41d6eae1..8447d1be5f 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -36,7 +36,7 @@ DEFER: (flat-length) ! not inline { [ dup inline? not ] [ drop 1 ] } ! inline - { [ t ] [ dup dup set word-def (flat-length) ] } + [ dup dup set word-def (flat-length) ] } cond ; : (flat-length) ( seq -- n ) @@ -45,7 +45,7 @@ DEFER: (flat-length) { [ dup quotation? ] [ (flat-length) 1+ ] } { [ dup array? ] [ (flat-length) ] } { [ dup word? ] [ word-flat-length ] } - { [ t ] [ drop 1 ] } + [ drop 1 ] } cond ] map sum ; @@ -94,7 +94,7 @@ DEFER: (flat-length) dup node-param { { [ dup standard-generic? ] [ inline-standard-method ] } { [ dup math-generic? ] [ inline-math-method ] } - { [ t ] [ 2drop t ] } + [ 2drop t ] } cond ; ! Resolve type checks at compile time where possible @@ -217,5 +217,5 @@ M: #call optimize-node* { [ dup optimize-predicate? ] [ optimize-predicate ] } { [ dup optimistic-inline? ] [ optimistic-inline ] } { [ dup method-body-inline? ] [ optimistic-inline ] } - { [ t ] [ inline-method ] } + [ inline-method ] } cond dup not ; diff --git a/core/optimizer/pattern-match/pattern-match.factor b/core/optimizer/pattern-match/pattern-match.factor index 0e7e801938..5beb2555f0 100755 --- a/core/optimizer/pattern-match/pattern-match.factor +++ b/core/optimizer/pattern-match/pattern-match.factor @@ -19,7 +19,7 @@ SYMBOL: @ { [ dup @ eq? ] [ drop match-@ ] } { [ dup class? ] [ match-class ] } { [ over value? not ] [ 2drop f ] } - { [ t ] [ swap value-literal = ] } + [ swap value-literal = ] } cond ; : node-match? ( node values pattern -- ? ) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index d115d0a1c6..b33a9e8fc2 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -57,7 +57,7 @@ IN: optimizer.specializers [ dup "specializer" word-prop ] [ "specializer" word-prop specialize-quot ] } - { [ t ] [ drop ] } + [ drop ] } cond ; : specialized-length ( specializer -- n ) diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6c09e08f84..1e1d6a5606 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -324,7 +324,7 @@ M: staging-violation summary { [ dup not ] [ drop unexpected-eof t ] } { [ dup delimiter? ] [ unexpected t ] } { [ dup parsing? ] [ nip execute-parsing t ] } - { [ t ] [ pick push drop t ] } + [ pick push drop t ] } cond ; : (parse-until) ( accum end -- accum ) diff --git a/core/prettyprint/prettyprint.factor b/core/prettyprint/prettyprint.factor index 03d3e456ca..e1a53696af 100755 --- a/core/prettyprint/prettyprint.factor +++ b/core/prettyprint/prettyprint.factor @@ -107,7 +107,7 @@ SYMBOL: -> { [ dup word? not ] [ , ] } { [ dup "break?" word-prop ] [ drop ] } { [ dup "step-into?" word-prop ] [ remove-step-into ] } - { [ t ] [ , ] } + [ , ] } cond ] each ] [ ] make ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 005672c1c6..0c759265e9 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -61,7 +61,7 @@ IN: bootstrap.syntax scan { { [ dup length 1 = ] [ first ] } { [ "\\" ?head ] [ next-escape drop ] } - { [ t ] [ name>char-hook get call ] } + [ name>char-hook get call ] } cond parsed ] define-syntax diff --git a/core/threads/threads.factor b/core/threads/threads.factor index d7d7988893..d568153034 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -86,7 +86,7 @@ PRIVATE> { { [ run-queue dlist-empty? not ] [ 0 ] } { [ sleep-queue heap-empty? ] [ f ] } - { [ t ] [ sleep-queue heap-peek nip millis [-] ] } + [ sleep-queue heap-peek nip millis [-] ] } cond ; Date: Fri, 11 Apr 2008 12:53:46 -0500 Subject: [PATCH 061/146] refactor tar a bit --- extra/tar/tar.factor | 81 +++++++++++++++----------------------------- 1 file changed, 28 insertions(+), 53 deletions(-) diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 99af06b80f..038078969d 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -1,7 +1,7 @@ USING: combinators io io.files io.streams.duplex io.streams.string kernel math math.parser continuations namespaces pack prettyprint sequences strings system -hexdump io.encodings.binary ; +hexdump io.encodings.binary inspector accessors ; IN: tar : zero-checksum 256 ; @@ -79,87 +79,67 @@ SYMBOL: filename ] keep ] if ; -TUPLE: unknown-typeflag str ; -: ( ch -- obj ) - 1string \ unknown-typeflag construct-boa ; - -TUPLE: unimplemented-typeflag header ; -: ( header -- obj ) - global [ "Unimplemented typeflag: " print dup . flush ] bind - tar-header-typeflag - 1string \ unimplemented-typeflag construct-boa ; +ERROR: unknown-typeflag ch ; +M: unknown-typeflag summary ( obj -- str ) + ch>> 1string + "Unknown typeflag: " prepend ; : tar-append-path ( path -- newpath ) base-dir get prepend-path ; ! Normal file : typeflag-0 - tar-header-name tar-append-path binary + name>> tar-append-path binary [ read-data-blocks ] keep dispose ; ! Hard link -: typeflag-1 ( header -- ) - throw ; +: typeflag-1 ( header -- ) unknown-typeflag ; ! Symlink -: typeflag-2 ( header -- ) - throw ; +: typeflag-2 ( header -- ) unknown-typeflag ; ! character special -: typeflag-3 ( header -- ) - throw ; +: typeflag-3 ( header -- ) unknown-typeflag ; ! Block special -: typeflag-4 ( header -- ) - throw ; +: typeflag-4 ( header -- ) unknown-typeflag ; ! Directory : typeflag-5 ( header -- ) tar-header-name tar-append-path make-directories ; ! FIFO -: typeflag-6 ( header -- ) - throw ; +: typeflag-6 ( header -- ) unknown-typeflag ; ! Contiguous file -: typeflag-7 ( header -- ) - throw ; +: typeflag-7 ( header -- ) unknown-typeflag ; ! Global extended header -: typeflag-8 ( header -- ) - throw ; +: typeflag-8 ( header -- ) unknown-typeflag ; ! Extended header -: typeflag-9 ( header -- ) - throw ; +: typeflag-9 ( header -- ) unknown-typeflag ; ! Global POSIX header -: typeflag-g ( header -- ) - throw ; +: typeflag-g ( header -- ) unknown-typeflag ; ! Extended POSIX header -: typeflag-x ( header -- ) - throw ; +: typeflag-x ( header -- ) unknown-typeflag ; ! Solaris access control list -: typeflag-A ( header -- ) - throw ; +: typeflag-A ( header -- ) unknown-typeflag ; ! GNU dumpdir -: typeflag-D ( header -- ) - throw ; +: typeflag-D ( header -- ) unknown-typeflag ; ! Solaris extended attribute file -: typeflag-E ( header -- ) - throw ; +: typeflag-E ( header -- ) unknown-typeflag ; ! Inode metadata -: typeflag-I ( header -- ) - throw ; +: typeflag-I ( header -- ) unknown-typeflag ; ! Long link name -: typeflag-K ( header -- ) - throw ; +: typeflag-K ( header -- ) unknown-typeflag ; ! Long file name : typeflag-L ( header -- ) @@ -169,24 +149,19 @@ TUPLE: unimplemented-typeflag header ; filename get tar-append-path make-directories ; ! Multi volume continuation entry -: typeflag-M ( header -- ) - throw ; +: typeflag-M ( header -- ) unknown-typeflag ; ! GNU long file name -: typeflag-N ( header -- ) - throw ; +: typeflag-N ( header -- ) unknown-typeflag ; ! Sparse file -: typeflag-S ( header -- ) - throw ; +: typeflag-S ( header -- ) unknown-typeflag ; ! Volume header -: typeflag-V ( header -- ) - throw ; +: typeflag-V ( header -- ) unknown-typeflag ; ! Vendor extended header type -: typeflag-X ( header -- ) - throw ; +: typeflag-X ( header -- ) unknown-typeflag ; : (parse-tar) ( -- ) 512 read @@ -218,7 +193,7 @@ TUPLE: unimplemented-typeflag header ; { CHAR: S [ typeflag-S ] } { CHAR: V [ typeflag-V ] } { CHAR: X [ typeflag-X ] } - [ throw ] + [ unknown-typeflag ] } case ! dup tar-header-size zero? [ ! out-stream get [ dispose ] when @@ -237,7 +212,7 @@ TUPLE: unimplemented-typeflag header ; : parse-tar ( path -- obj ) binary [ - "tar-test" resource-path base-dir set + "resource:tar-test" base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) From 1e01d73e616de962e68b2bab525724c02caa98dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 11 Apr 2008 12:54:33 -0500 Subject: [PATCH 062/146] fix usages of cond/case --- extra/ui/gadgets/buttons/buttons.factor | 2 +- extra/ui/gadgets/gadgets.factor | 2 +- extra/ui/gadgets/panes/panes.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- extra/ui/render/render.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 6 +++--- extra/ui/tools/listener/listener.factor | 2 +- extra/ui/tools/walker/walker.factor | 2 +- extra/ui/traverse/traverse.factor | 2 +- extra/ui/windows/windows.factor | 4 ++-- extra/ui/x11/x11.factor | 4 ++-- 12 files changed, 16 insertions(+), 16 deletions(-) diff --git a/extra/ui/gadgets/buttons/buttons.factor b/extra/ui/gadgets/buttons/buttons.factor index 7e649b7ff7..978e5d48e2 100755 --- a/extra/ui/gadgets/buttons/buttons.factor +++ b/extra/ui/gadgets/buttons/buttons.factor @@ -55,7 +55,7 @@ C: button-paint { [ dup button-pressed? ] [ drop button-paint-pressed ] } { [ dup button-selected? ] [ drop button-paint-selected ] } { [ dup button-rollover? ] [ drop button-paint-rollover ] } - { [ t ] [ drop button-paint-plain ] } + [ drop button-paint-plain ] } cond ; M: button-paint draw-interior diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index 3ad76b0a16..f4e5ca2a46 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -378,7 +378,7 @@ SYMBOL: in-layout? { { [ 2dup eq? ] [ 2drop t ] } { [ dup not ] [ 2drop f ] } - { [ t ] [ gadget-parent child? ] } + [ gadget-parent child? ] } cond ; GENERIC: focusable-child* ( gadget -- child/t ) diff --git a/extra/ui/gadgets/panes/panes.factor b/extra/ui/gadgets/panes/panes.factor index fedacbd2af..439e938186 100755 --- a/extra/ui/gadgets/panes/panes.factor +++ b/extra/ui/gadgets/panes/panes.factor @@ -88,7 +88,7 @@ C: pane-stream dup gadget-children { { [ dup empty? ] [ 2drop ""